Changeset 2276

Timestamp:

08/21/19 18:50:19 (5 years ago)

Author:

nanardon

Message:

Allow to dump object as perl code

File:

• trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm (modified) (3 diffs)

trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm

@@ -818 +818 @@
 }
 
+=head2 DataDump($config)
+
+Return a structure about the object
+
+=cut
+
+sub DataDump {
+    my ($self, $config, $base) = @_;
+
+    # {
+    #   base => # base latmoslocal: object address/thauvin-GY
+    #   otype => 'otype',
+    #   id => 'name',
+    #   roAttrs => []
+    #   Attrs => {
+    #       'Attr' => [],
+    #   }
+    #   subObjs => {
+    #       'otype' => [],
+    #   }
+    # }
+
+
+    $config->{level} ||= 0;
+    my $otype = $self->type;
+    $base ||= $self->base;
+    my $dump = {
+        otype => $otype,
+        id => $self->id,
+    };
+    if (ref $self) {
+        $dump->{base} = $base->label;
+    }
+
+    my %roAttrs = ();
+    foreach my $attr (sort { $a cmp $b } $base->list_canonical_fields($otype,
+        $config->{only_rw} ? 'rw' : 'r')) {
+        my $oattr = ref $self ? $self->attribute($attr) : $base->attribute($otype, $attr);
+        next if ($oattr->hidden);
+
+        if (ref $self) {
+            my $val = $self->get_c_field($attr);
+            if ($val || $config->{empty_attr}) {
+                my @vals = ref $val ? @{ $val } : $val;
+                $dump->{Attrs}{$attr} = \@vals;
+                $roAttrs{ $attr } = 1 if ($oattr->ro);
+            }
+        } else {
+            $dump->{Attrs}{$attr} = undef;
+            $roAttrs{ $attr } = 1 if ($oattr->ro);
+        }
+
+        $dump->{roAttrs} = [ sort keys %roAttrs ];
+    }
+
+    if ($config->{cb}) {
+        $config->{cb}->($config, $dump);
+    }
+
+    if (ref $self && $config->{recur}) {
+          my %subobj = $self->ListChildObjects;
+          foreach my $otype (sort keys %subobj) {
+              foreach my $oname (sort @{ $subobj{$otype} }) {
+                  my $obj = $self->base->get_object($otype, $oname) or next;
+                  push(@{ $dump->{subObjs}{$otype} }, $obj->DataDump({ %{$config || {}}, recur => $config->{recur}, level => $config->{level} + 2 }));
+              }
+          }
+    }
+
+    return $dump;
+}
+
 =head2 text_dump ($handle, $config, $base)
 
@@ -832 +904 @@
 =head2 dump
 
-Return dump for tihs object
+Return dump for this object
 
 =cut
 
 sub dump {
-    my ($self, $config, $base) = @_;
-
-    $config->{level} ||= 0;
-    my $otype = $self->type;
+    my ($self, $InitConfig, $base) = @_;
+
+    $InitConfig->{level} ||= 0;
     $base ||= $self->base;
-    my $dump;
-    if (ref $self) {
-        $dump .= sprintf "%s# base %s: object %s/%s\n",
+    my $dump = '';
+
+    $InitConfig->{cb} = sub {
+        my ( $config, $Dump ) = @_;
+
+        if ($config->{level}) {
+            $dump .= "\n";
+        }
+
+        if (ref $self) {
+            $dump .= sprintf "%s# base %s: object %s/%s\n",
+                ' ' x $config->{level},
+                $Dump->{base}, $Dump->{otype}, $Dump->{id};
+        }
+        $dump .= sprintf(
+            "%s# %s\n",
             ' ' x $config->{level},
-            $base->label, $self->type, $self->id;
-    }
-    $dump .= sprintf(
-        "%s# %s\n", 
-        ' ' x $config->{level},
-        scalar(localtime)
-    );
-
-    foreach my $attr (sort { $a cmp $b } $base->list_canonical_fields($otype,
-        $config->{only_rw} ? 'rw' : 'r')) {
-        my $oattr = ref $self ? $self->attribute($attr) : $base->attribute($otype, $attr);
-        if ($oattr->hidden) { next; }
-        if (ref $self) {
-            my $val = $self->get_c_field($attr);
-            if ($val || $config->{empty_attr}) {
-                if (my @allowed = $base->obj_attr_allowed_values($otype, $attr)) {
-                    $dump .= sprintf("# %s must be%s: %s\n",
+            scalar(localtime)
+        );
+
+        my %roAttrs = map { $_ => 1 } @{ $Dump->{roAttrs} || [] };
+
+        foreach my $attr (sort { $a cmp $b } sort keys %{ $Dump->{Attrs} || {} }) {
+            my $val = $Dump->{Attrs}{$attr};
+            my $oattr = $base->attribute($Dump->{otype}, $attr);
+            if ($val) {
+                if (my @allowed = $base->obj_attr_allowed_values($Dump->{otype}, $attr)) {
+                    $dump .= sprintf("%s# %s must be%s: %s\n",
+                        ' ' x $config->{level},
                         $attr,
                         ($oattr->mandatory ? '' : ' empty or either'),
@@ -868 +947 @@
                     );
                 }
-                my @vals = ref $val ? @{ $val } : $val;
-                foreach (@vals) {
+
+                foreach (@$val) {
                     $_ ||= '';
                     s/\r?\n/\\n/g;
                     $dump .= sprintf("%s%s%s%s:%s\n",
                         ' ' x $config->{level},
-                        $oattr->ro ? '# (ro) ' : '',
-                        $config->{level} ? $self->type . '[' . $self->id . '].' : '',
+                        $roAttrs{$attr} ? '# (ro) ' : '',
+                        $config->{level} ? $Dump->{otype} . '[' . $Dump->{id} . '].' : '',
                         $attr, $_ ? " $_" : '');
                 }
+            } elsif ( $config->{empty_attr} || ! ref $self) {
+                if (my @allowed = $base->obj_attr_allowed_values($Dump->{otype}, $attr)) {
+                    $dump .= sprintf("%s# %s must be%s: %s\n",
+                        ' ' x $config->{level},
+                        $attr,
+                        ($oattr->mandatory ? '' : ' empty or either'),
+                        join(', ', @allowed)
+                    );
+                }
+                $dump .= sprintf("%s%s%s%s:\n",
+                    ' ' x $config->{level},
+                    $roAttrs{$attr} ? '# (ro) ' : '',
+                    $config->{level} ? $Dump->{otype} . '[' . $Dump->{id} . '].' : '',
+                    $attr);
             }
-        } else {
-            if (my @allowed = $base->obj_attr_allowed_values($otype, $attr)) {
-                $dump .= sprintf("# %s must be empty or either: %s\n",
-                    $attr,
-                    join(', ', @allowed)
-                );
-            }
-            $dump .= sprintf("%s%s: %s\n", 
-                $oattr->ro ? '# (ro) ' : '',
-                $attr, '');
-        }
-    }
-
-    if (ref $self && $config->{recur}) {
-          my %subobj = $self->ListChildObjects;
-          foreach my $otype (keys %subobj) {
-              foreach my $oname (sort @{ $subobj{$otype} }) {
-                  my $obj = $self->base->get_object($otype, $oname) or next;
-                  $dump .= "\n";
-                  $dump .= $obj->dump({ %{$config || {}}, recur => $config->{recur}, level => $config->{level} + 2 });
-              }
-          }
-    }
+        }
+    };
+
+    $self->DataDump($InitConfig, $base);
 
     return $dump;