/[cvs]/nfo/perl/libs/Data/Storage/Handler/Tangram.pm

Diff of /nfo/perl/libs/Data/Storage/Handler/Tangram.pm

Parent Directory | Revision Log | View Patch Patch

-revision 1.35 by jonen,
Sat Apr 19 16:09:48 2003 UTC
+revision 1.38 by joko,
Tue May 13 16:38:38 2003 UTC
 Line 3
  #  $Id$
  #
  #  $Log$
+ #  Revision 1.38  2003/05/13 16:38:38  joko
+ #  problems with "tied" on 5.6.1/win32
+ #
+ #  Revision 1.37  2003/05/10 17:37:39  jonen
+ #  corrected last commit
+ #
+ #  Revision 1.36  2003/05/10 17:31:18  jonen
+ #  + added new functions related to 'create' item
+ #   - createNode()
+ #     # creates non-persistent 'deep dummy filled' object
+ #   - insertChildNode()
+ #     # inserts child node at given parent (child node haven't to exists,
+ #         createNode will be injected transparently)
+ #
  #  Revision 1.35  2003/04/19 16:09:48  jonen
  #  + added operator dispatching (currently for getting ref-type) at 'getListFiltered'
  #
-Line 714 
 sub sendQuery {
+Line 728 
 sub sendQuery {
        $self->erase($object);
+     } elsif ($crud eq 'CREATE') {
+       my $nodename = $query->{node};
+       my $newnode = $self->createNode($nodename);
+       my $id = $self->{_COREHANDLE}->insert($newnode);
+       print "Saved new node $nodename with GUID $newnode->{guid}, OID '$id': " . Dumper($newnode) . "\n";
+       return $newnode;
      }
    }
-Line 868 
 sub disconnect2 {
+Line 892 
 sub disconnect2 {
    $self->{dataStorageLayer}->disconnect();
  }
+ sub createNode {
+   my $self = shift;
+   my $classname = shift;
+   my $obj = $classname->new();
+   my $attr_options = Class::Tangram::attribute_options($classname);
+   #print "Attribute Options: " . Dumper($attr_options);
+   my $attr_types = Class::Tangram::attribute_types($classname);
+   #print "Attribute Types: " . Dumper($attr_types);
+   foreach(keys %{$attr_types}) {
+     if($attr_types->{$_} eq 'string') {
+       $obj->{$_} = '';
+     } elsif($attr_types->{$_} eq 'int') {
+       $obj->{$_} = 0;
+     } elsif($attr_types->{$_} eq 'real') {
+       $obj->{$_} = 0;
+     } elsif($attr_types->{$_} eq 'rawdatetime') {
+       $obj->{$_} = '0000-00-00 00:00:00';
+     } elsif($attr_types->{$_} eq 'ref') {
+       if($attr_options->{$_}->{class}) {
+         $obj->{$_} = $self->createNode($attr_options->{$_}->{class});
+       } else {
+         #$obj->{$_} = undef();
+       }
+     } elsif($attr_types->{$_} eq 'iarray') {
+         $obj->{$_} = [ ];
+     } elsif($attr_types->{$_} eq 'hash') {
+         $obj->{$_} = {  };
+     } elsif($attr_types->{$_} eq 'flat_hash') {
+         $obj->{$_} = { };
+     }
+   }
+   #print "New Object: " . Dumper($obj);
+   return $obj;
+ }
+   sub insertChildNode {
+     my $self = shift;
+     my $child_entry = shift;
+     my $query_args = shift;
+     my $core = $self->{_COREHANDLE};
+     my $nodename = $query_args->{nodename};
+     # get parent object
+     my $query = {
+           node => $query_args->{parent}->{nodename},
+           options => { GUID => $query_args->{parent}->{guid}, },
+           };
+     my $cursor = $self->sendQuery($query);
+     my $parent = $cursor->getNextEntry();
+     # debug
+     #print "Parent_org: " . Dumper($parent);
+     # Create child node object if isn't already done
+     # ($child_entry have to be the class name then...)
+     if(!ref($child_entry)) {
+       $child_entry = $self->createNode($child_entry);
+       # it could be insert 'manually' or will be insert 'transparent' if parent will be updated
+       #$core->insert($child_entry);
+       #print "Create child object [$nodename]: " . Dumper($child_entry);
+     }
+     # get reference of tied node (seems, only on Linux node's are tied!!)
+     my $tied_node = tied $parent->{$nodename};
+     # insert/change child entry at parent
+     #print "reference: " . ref($parent->{$nodename}) . "\n";
+     if(ref($parent->{$nodename}) eq 'ARRAY') {
+       # (seems, only on Linux node's are tied!!)
+       if($tied_node) {
+         # all tangram types are tied as 'SCALAR' with special 'FETCH', 'STORE' methods per type,
+         # so a 'PUSH' is not implemented (which could be then done transparently)
+         my $array = $tied_node->FETCH;
+         push @$array, $child_entry;
+         $tied_node->STORE($array);
+         # node will be normaly untied at 'STORE'
+         if(tied $parent->{$nodename}) { print "already tied !!\n"; }
+         else { undef $tied_node; }
+       } else {
+         push @{$parent->{$nodename}}, $child_entry;
+       }
+     }
+     elsif(ref($parent->{$nodename}) eq 'HASH') {
+       if(my $key = $query_args->{hash_key}) {
+         # (seems, only on Linux node's are tied!!)
+         if($tied_node) {
+           # same problem as with 'ARRAY':
+           # all tangram types are tied as 'SCALAR' with special 'FETCH', 'STORE' methods per type.
+           my $hash = $tied_node->FETCH;
+           $hash->{$key} = $child_entry;
+           $tied_node->STORE($hash);
+           # node will be normaly untied at 'STORE'
+           if(tied $parent->{$nodename}) { print "already tied !!\n"; }
+           else { undef $tied_node; }
+         } else {
+           $parent->{$nodename}->{$key} = $child_entry;
+         }
+       } else {
+        print "ERROR: No HASH KEY given, so not able to insert hash entry!";
+       }
+     }
+     else {
+       $parent->{$nodename} = $child_entry;
+     }
+     # debug
+     #print "Parent_new: " . Dumper($parent);
+     # save parent
+     $core->update($parent);
+     # debug
+     #print "Saved Parent: ". Dumper($parent);
+     return $child_entry;
+   }
 ;
  __END__

 Legend:



Removed from v.1.35
 


changed lines


 
Added in v.1.38
 Legend:



Removed from v.1.35
 


changed lines


 
Added in v.1.38
-Removed from v.1.35
+Added in v.1.38

MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26