Changeset 2267

Timestamp:

06/19/19 20:02:16 (5 years ago)

Author:

nanardon

Message:

Add a way to dump object and all related objects

Location:

trunk/LATMOS-Accounts

Files:

• bin/la-query (modified) (1 diff)
• lib/LATMOS/Accounts/Bases/Objects.pm (modified) (3 diffs)
• lib/LATMOS/Accounts/Bases/Sql/User.pm (modified) (1 diff)
• lib/LATMOS/Accounts/Bases/Sql/objects.pm (modified) (1 diff)
• lib/LATMOS/Accounts/Cli/Base.pm (modified) (3 diffs)
• lib/LATMOS/Accounts/Cli/Object.pm (modified) (1 diff)

trunk/LATMOS-Accounts/bin/la-query

@@ -74 +74 @@
 (Only if obj_id is specified) Include also read-only attributes as comments.
 
+=item --recur
+
+Dump also all related objects
+
 =item --fmt format
 

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

@@ -839 +839 @@
     my ($self, $config, $base) = @_;
 
+    $config->{level} ||= 0;
     my $otype = $self->type;
     $base ||= $self->base;
     my $dump;
     if (ref $self) {
-        $dump .= sprintf "# base %s: object %s/%s\n",
+        $dump .= sprintf "%s# base %s: object %s/%s\n",
+            ' ' x $config->{level},
             $base->label, $self->type, $self->id;
     }
-    $dump .= sprintf "# %s\n", scalar(localtime);
+    $dump .= sprintf(
+        "%s# %s\n", 
+        ' ' x $config->{level},
+        scalar(localtime)
+    );
 
     foreach my $attr (sort { $a cmp $b } $base->list_canonical_fields($otype,
@@ -866 +872 @@
                     $_ ||= '';
                     s/\r?\n/\\n/g;
-                    $dump .= sprintf("%s%s:%s\n", 
+                    $dump .= sprintf("%s%s%s%s:%s\n",
+                        ' ' x $config->{level},
                         $oattr->ro ? '# (ro) ' : '',
+                        $config->{level} ? $self->type . '[' . $self->id . '].' : '',
                         $attr, $_ ? " $_" : '');
                 }
@@ -883 +891 @@
         }
     }
+
+    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 });
+              }
+          }
+    }
+
     return $dump;
 }

trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/User.pm

@@ -66 +66 @@
         address => 'user',
         employment => 'user',
+        nethost => [ 'owner', 'user' ],
     },
 }

trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/objects.pm

@@ -313 +313 @@
 
 sub ParentObject { }
+
+=head2 ListChildObjects
+
+Return objects having this object as Parent
+
+=cut
+
+sub ListChildObjects {
+    my ($self) = @_;
+
+    my $Subotype = $self->GetOtypeDef or return;
+
+    my %res;
+
+    foreach my $otype (keys %$Subotype) {
+        foreach my $attr (ref $Subotype->{$otype} ? @{ $Subotype->{$otype} } : $Subotype->{$otype}) {
+            my @list = $self->base->search_objects( $otype, $attr . '=' . $self->id );
+            if (@list) {
+                push(@{ $res{$otype} }, @list);
+            }
+        }
+    }
+
+    %res;
+}
 
 sub _get_ikey {

trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Cli/Base.pm

@@ -225 +225 @@
 Instead displaying attribute list use C<format> as formating string
 
+=item recur
+
+Dump object and all related objects
+
 =back
 
@@ -241 +245 @@
                         'fmt=s'      => \my $fmt,
                         'filefmt=s'  => \my $filefmt,
+                        'recur'      => \my $recur,
                     }, @_
                 );
@@ -271 +276 @@
                     } else {
                         $_->text_dump( $self->Context->Out, {
+                            recur => $recur,
                             empty_attr => $empty_attr,
                             only_rw => !$with_ro,

trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Cli/Object.pm

@@ -519 +519 @@
         });
     }
+    if (1) { # TODO test SQL base
+        $self->add_func('extract', {
+            help => 'extract information about objects',
+            code => sub {
+                my ($env, $action) = @_;
+                foreach my $obj (sort @{$env->{_objects}}) {
+                    print $OUT $obj->dump({ recur => 1 });
+                }
+                $env->rollback;
+            },
+        });
+    }
 
     return $self;