/[cvs]/nfo/perl/libs/Data/Transfer/Sync/StorageInterface.pm
ViewVC logotype

Diff of /nfo/perl/libs/Data/Transfer/Sync/StorageInterface.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by joko, Mon Jan 20 16:58:46 2003 UTC revision 1.9 by joko, Wed Apr 9 07:53:34 2003 UTC
# Line 6  Line 6 
6  ##  ##
7  ##    ----------------------------------------------------------------------------------------  ##    ----------------------------------------------------------------------------------------
8  ##    $Log$  ##    $Log$
9    ##    Revision 1.9  2003/04/09 07:53:34  joko
10    ##    minor namespace update
11    ##
12    ##    Revision 1.8  2003/04/09 07:27:02  joko
13    ##    minor update (just cosmetics)
14    ##
15    ##    Revision 1.7  2003/03/27 15:31:16  joko
16    ##    fixes to modules regarding new namespace(s) below Data::Mungle::*
17    ##
18    ##    Revision 1.6  2003/02/21 01:47:53  joko
19    ##    renamed core function
20    ##
21    ##    Revision 1.5  2003/02/20 20:24:33  joko
22    ##    + additional pre-flight checks
23    ##
24    ##    Revision 1.4  2003/02/14 14:14:38  joko
25    ##    + new code refactored here
26    ##
27    ##    Revision 1.3  2003/02/11 07:54:55  joko
28    ##    + modified module usage
29    ##    + debugging trials
30    ##
31    ##    Revision 1.2  2003/02/09 05:05:58  joko
32    ##    + major structure changes
33    ##    - refactored code to sister modules
34    ##    + refactored code to this place
35    ##
36  ##    Revision 1.1  2003/01/20 16:58:46  joko  ##    Revision 1.1  2003/01/20 16:58:46  joko
37  ##    + initial check-in: here they are....  ##    + initial check-in: here they are....
38  ##  ##
# Line 25  use mixin::with qw( Data::Transfer::Sync Line 52  use mixin::with qw( Data::Transfer::Sync
52    
53  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -   main  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -   main
54    
 # get logger instance  
 my $logger = Log::Dispatch::Config->instance;  
   
55  use Data::Dumper;  use Data::Dumper;
56    use Hash::Merge qw( merge );
57    use shortcuts::database qw( hash2sql );
58    use Data::Mungle::Transform::Deep qw( merge_to );
59    
60    
61    # get logger instance
62    my $logger = Log::Dispatch::Config->instance;
63    
64  # this is a shortcut method  # this is a shortcut method
65  # ... let's try to avoid _any_ redundant code in here (ok... - at the cost of method lookups...)  # ... let's try to avoid _any_ redundant code in here (ok... - at the cost of method lookups...)
66  sub _getNodeList {  sub _getNodeList {
67    my $self = shift;    my $self = shift;
68    my $descent = shift;    my $descent = shift;
69    my $filter = shift;    my $filter = shift;
70      $logger->debug( __PACKAGE__ . "->_getNodeList( descent=$descent, accessorName=$self->{meta}->{$descent}->{accessorName} )" );
71    #$results ||= $self->{source}->getListUnfiltered($self->{meta}->{source}->{node});    #$results ||= $self->{source}->getListUnfiltered($self->{meta}->{source}->{node});
72    #$results ||= $self->{meta}->{source}->{storage}->getListUnfiltered($self->{meta}->{source}->{node});    #$results ||= $self->{meta}->{source}->{storage}->getListUnfiltered($self->{meta}->{source}->{node});
73    my $list = $self->{meta}->{$descent}->{storage}->getListFiltered($self->{meta}->{$descent}->{nodeName}, $filter);    my $list = $self->{meta}->{$descent}->{storage}->getListFiltered($self->{meta}->{$descent}->{accessorName}, $filter);
74  #print Dumper($list);  #print Dumper($list);
75    return $list;    return $list;
76  }  }
# Line 48  sub _resolveNodeIdent { Line 79  sub _resolveNodeIdent {
79    my $self = shift;    my $self = shift;
80    my $descent = shift;    my $descent = shift;
81        
82    #print Dumper($self->{node}->{$descent});    # trace
83        #print Dumper($self->{node}->{$descent});
84        #print Dumper($self);
85        #exit;
86        
87      $logger->debug( __PACKAGE__ . "->_resolveNodeIdent( descent=$descent, accessorName=$self->{meta}->{$descent}->{accessorName} )" );
88        
89    # get to the payload    # get to the payload
90      #my $item = $specifier->{item};      #my $item = $specifier->{item};
# Line 59  sub _resolveNodeIdent { Line 95  sub _resolveNodeIdent {
95      #my $ident = $self->{$descent}->id($item);      #my $ident = $self->{$descent}->id($item);
96      #my $ident = $self->{meta}->{$descent}->{storage}->id($item);      #my $ident = $self->{meta}->{$descent}->{storage}->id($item);
97    
98      # trace
99        #print Dumper($self->{meta}->{$descent});
100        #exit;
101    
102      my $ident;      my $ident;
103      my $provider_method = $self->{meta}->{$descent}->{IdentProvider}->{method};      my $provider_method = $self->{meta}->{$descent}->{IdentProvider}->{method};
104      my $provider_arg = $self->{meta}->{$descent}->{IdentProvider}->{arg};      my $provider_arg = $self->{meta}->{$descent}->{IdentProvider}->{arg};
105    
106      #print "provider_method: $provider_method", "\n";      # trace
107      #print "provider_arg: $provider_arg", "\n";        #print "provider_method: $provider_method", "\n";
108          #print "provider_arg: $provider_arg", "\n";
109          #print Dumper($payload);
110    
111      # resolve to ident      # resolve to ident
112      if (lc $provider_method eq 'property') {      if (lc $provider_method eq 'property') {
# Line 103  sub _statloadNode { Line 145  sub _statloadNode {
145    my $ident = shift;    my $ident = shift;
146    my $force = shift;    my $force = shift;
147    
148    =pod
149      #print "isa: ", UNIVERSAL::isa($self->{meta}->{$descent}->{storage}), "\n";
150    
151      # this seems to be the first time we access this side,
152      # so just check (again) for a valid storage handle
153      if (! ref $self->{meta}->{$descent}->{storage}) {
154        $logger->critical( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident ): Storage handle undefined!" );
155        return;
156      }
157    =cut
158    
159      #$logger->debug( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident )" );
160    
161    # fetch entry to retrieve checksum from    # fetch entry to retrieve checksum from
162    # was:    # was:
163    if (!$self->{node}->{$descent} || $force) {    if (!$self->{node}->{$descent} || $force) {
# Line 119  sub _statloadNode { Line 174  sub _statloadNode {
174        return;        return;
175      }      }
176    
177  #print "yai!", "\n";      #print Dumper($self->{meta});
178    
179      my $query = {      my $query = {
180        node => $self->{meta}->{$descent}->{nodeName},        node => $self->{meta}->{$descent}->{accessorName},
181        subnodes => [qw( cs )],        subnodes => [qw( cs )],
182        criterias => [        criterias => [
183          { key => $self->{meta}->{$descent}->{IdentProvider}->{arg},          { key => $self->{meta}->{$descent}->{IdentProvider}->{arg},
# Line 131  sub _statloadNode { Line 186  sub _statloadNode {
186        ]        ]
187      };      };
188    
189  print Dumper($query);      # send query and fetch first entry from result
190          my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query);
191      my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query);        my $entry = $result->getNextEntry();
192    
193        # trace
194          #print Dumper($entry);
195          #print "pers: " . $self->{meta}->{$descent}->{storage}->is_persistent($entry), "\n";
196          #my $state = $self->{meta}->{$descent}->{storage}->_fetch_object_state($entry, { name => 'TransactionHop' } );
197          #print Dumper($state);
198    
199      my $entry = $result->getNextEntry();      # be informed about the status of the query
200          my $status = $result->getStatus();
 #print Dumper($entry);  
 #print "pers: " . $self->{meta}->{$descent}->{storage}->is_persistent($entry), "\n";  
 #my $state = $self->{meta}->{$descent}->{storage}->_fetch_object_state($entry, { name => 'TransactionHop' } );  
 #print Dumper($state);  
   
     my $status = $result->getStatus();  
201    
202  #print Dumper($status);  #print Dumper($status);
203            
# Line 183  print Dumper($query); Line 238  print Dumper($query);
238  }  }
239    
240    
241    sub _touchNodeSet {
242      my $self = shift;
243    
244      $logger->debug( __PACKAGE__ . "->touchNodeSet" );
245    
246      # check descents/nodes: does descent exist / is node available?
247      foreach my $descent (keys %{$self->{meta}}) {
248        
249        # 1. check metadata of descent(s)
250          if (!$self->{meta}->{$descent}) {
251            $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not find descent '$descent' in configuration metadata." );
252            next;
253          }
254    
255        # 2. check storage handle(s)
256          my $dbkey = $self->{meta}->{$descent}->{dbKey};
257          if (!$self->{meta}->{$descent}->{storage}) {
258            $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not access storage ( descent='$descent', dbKey='$dbkey' ) - configuration-error?" );
259            next;
260          }
261        
262        # 2.b check storage handle type
263          my $dbType = $self->{meta}->{$descent}->{storage}->{locator}->{type};
264          if (!$dbType) {
265            $logger->critical( __PACKAGE__ . "->touchNodeSet: Storage ( descent='$descent', dbKey='$dbkey' ) has no 'dbType' - configuration-error?" );
266            next;
267          }
268    
269        # 3. check if descents (and nodes?) are actually available....
270          # TODO:
271          # eventually pre-check mode of access-attempt (read/write) here to provide an "early-croak" if possible
272        
273        # trace
274          # print Dumper($self->{meta}->{$descent}->{storage}->{locator});
275    
276    
277          my $nodeName = $self->{meta}->{$descent}->{nodeName};
278          my $accessorType = $self->{meta}->{$descent}->{accessorType};
279          my $accessorName = $self->{meta}->{$descent}->{accessorName};
280    
281    
282        # 4. check nodeset
283    
284        # debug message containing database type and used/determined accessor name
285        $logger->debug( __PACKAGE__ . "->touchNodeSet: Accessing dbType=$dbType, accessorName=$accessorName" );
286        
287        # if target node(s) do(es) not exist, check if we should create it automagically
288        if ($dbType ne 'DBI' && !$self->{meta}->{$descent}->{storage}->existsChildNode($accessorName)) {
289    
290          if ($descent eq 'target' && $self->{options}->{target}->{autocreateFolders}) {
291            if (!$self->{meta}->{$descent}->{storage}->createChildNode($accessorName)) {
292              $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not create node '$self->{meta}->{$descent}->{nodeName}\@$self->{meta}->{$descent}->{dbKey}' [$self->{meta}->{$descent}->{nodeType}]." );
293              next;
294            }
295          } else {
296            $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not reach node \"$nodeName\" (accessorName=$accessorName, accessorType=$accessorType) at descent \"$descent\"" );
297            next;
298          }
299        }
300        
301      }
302    
303      # trace
304        #print Dumper($self->{meta});
305        #exit;
306    
307      
308      return 1;
309    
310    }
311    
312    
313    
314    sub _modifyNode {
315      my $self = shift;
316      my $descent = shift;
317      my $action = shift;
318      my $map = shift;
319      my $crit = shift;
320    
321      # map for new style callbacks
322      my $map_callbacks = {};
323    
324      # checks go first!
325      
326        # TODO: this should be reviewed first - before extending  ;-)
327        # TODO: this should be extended:
328        # count this cases inside the caller to this sub and provide a better overall message
329        # if this counts still zero in the end:
330        #     "No nodes have been touched for modify: Do you have column-headers in your csv file?"
331        if (not defined $self->{node}) {
332          #$logger->critical( __PACKAGE__ . "->_modifyNode failed: \"$descent\" node is empty." );
333          #return;
334        }
335    
336      # transfer callback nodes from value map to callback map - handle them afterwards! - (new style callbacks)
337      if (my $callbacks = $self->{meta}->{$descent}->{Callback}) {
338        foreach my $callback (keys %{$callbacks->{write}}) {
339          $map_callbacks->{write}->{$callback} = $map->{$callback};
340          delete $map->{$callback};
341        }
342      }
343      
344      
345      # trace
346        #print Dumper($self->{meta});
347    
348    
349      # --------------------------------------------------------------------------
350      # DBI speaks SQL
351      if ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'DBI') {
352    
353        # trace
354          #print Dumper($map);
355          #delete $map->{cs};
356    
357        # transfer data
358          # TODO: wrap this around '$storageHandle->sendQuery(...)'!?
359          my $sql_main;
360          if (lc($action) eq 'insert') {
361            $sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_INSERT');
362          } elsif (lc $action eq 'update') {
363            $crit ||= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'";
364            $sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_UPDATE', $crit);
365          }
366          my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main);
367    
368        # handle errors
369          if ($sqlHandle->err) {
370            #if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; }
371            $self->{node}->{status}->{error} = {
372              statement => $sql_main,
373              state => $sqlHandle->state,
374              err => $sqlHandle->err,
375              errstr => $sqlHandle->errstr,
376            };
377          } else {
378            $self->{node}->{status}->{ok} = 1;
379          }
380    
381    
382      # --------------------------------------------------------------------------
383      # Tangram does it the oo-way (naturally)
384      } elsif ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'Tangram') {
385        my $sql_main;
386        my $object;
387    
388        # determine classname
389        my $classname = $self->{meta}->{$descent}->{nodeType};
390        
391        # attributes/properties to exclude
392          # push declared ones from metadata
393          my @exclude = @{$self->{meta}->{$descent}->{subnodes_exclude}};
394          # push the attributes associated with the identifier
395          if (my $identProvider = $self->{meta}->{$descent}->{IdentProvider}) {
396            push @exclude, $identProvider->{arg};
397          }
398    
399        # trace
400          #print Dumper($self->{meta});
401          #exit;
402    
403        # new feature:
404        #     - check TypeProvider metadata property from other side
405        #     - use argument (arg) inside as a classname for object creation on this side
406        #my $otherSide = $self->_otherSide($descent);
407        if (my $typeProvider = $self->{meta}->{$descent}->{TypeProvider}) {
408          #print Dumper($map);
409          $classname = $map->{$typeProvider->{arg}};
410          # remove nodes from map also (push nodes to "subnodes_exclude" list)
411          push @exclude, $typeProvider->{arg};
412        }
413        
414        # exclude banned properties (remove from map)
415        #map { delete $self->{node}->{map}->{$_} } @{$self->{args}->{exclude}};
416        map { delete $map->{$_} } @exclude;
417    
418        # list of properties
419        my @props = keys %{$map};
420    
421        # transfer data
422        if (lc $action eq 'insert') {
423    
424          # make the object persistent in four steps:
425          #   - raw create (perl / class tangram scope)
426          #   - orm insert (tangram scope)   ... this establishes inheritance - don't try to fill in inherited properties before!
427          #      is this a Tangram bug?
428          #   - raw fill-in from hash (perl scope)
429          #   - orm update (tangram scope)  ... this updates all properties just filled in
430          
431          
432          # ==========================
433          # TODO: REVIEW HERE!!!
434          # can't we achieve this more elegant?
435          #   o use DesignPattern::Object???
436          #   o use Hash::Merge!!! (take care about the cloning behaviour)
437          
438            # check if object exists (is classname a valid perl package/module?)
439    
440              # we can just check if the classname is valid here
441              if (!$classname) {
442                $logger->critical( __PACKAGE__ . "->_modifyNode: classname is undefined" );
443                # FIXME: stop syncing here?
444                return;
445              }
446            
447              # try to match against the classes known by Class::Tangram
448              # FIXME: do "/i" on win32 only!
449              my $classname_find = quotemeta($classname);
450              if (!grep(m/$classname_find/i, Class::Tangram::known_classes())) {
451                $logger->critical( __PACKAGE__ . "->_modifyNode: Classname '$classname' is not known by Class::Tangram" );
452                # FIXME: stop syncing here?
453                return;
454              }
455          
456            # create new object ...
457              # V1
458                # build array to initialize object
459                #my @initarray = ();
460                #map { push @initarray, $_, undef; } @props;
461                #my $object = $classname->new( @initarray );
462              # V2
463                $object = $classname->new();
464              # V3
465                # $object = DesignPattern::Object->new($data);
466    
467            # ... pass to orm first ...
468            $self->{meta}->{$descent}->{storage}->insert($object);
469      
470            # ... and initialize with empty (undef'd) properties afterwards.
471            map { $object->{$_} = undef; } @props;
472      
473            # trace
474              #print "\n";
475              #print Dumper($map);
476              #print Dumper($object);
477              #exit;
478    
479            # mix in (merge) values ...
480              # TODO: use Hash::Merge here? benchmark!
481              # no! we'd need a Object::Merge here! it's *...2object*
482              merge_to($object, $map);
483      
484            # trace
485              #print Dumper($object);
486              #exit;
487    
488          # TODO: REVIEW HERE!!!
489          # ==========================
490    
491          # ... and re-update@orm.
492            $self->{meta}->{$descent}->{storage}->update($object);
493    
494          # asymmetry: get ident after insert
495          # TODO:
496          #   - just do this if it is an IdentAuthority
497          #   - use IdentProvider metadata here
498    #print Dumper($self->{meta}->{$descent});
499          my $oid = $self->{meta}->{$descent}->{storage}->id($object);
500    #print "oid: $oid", "\n";
501          $self->{node}->{$descent}->{ident} = $oid;
502    
503    
504        } elsif (lc $action eq 'update') {
505          
506          # Get fresh object from orm first.
507          # TODO: Review, is a 'sendQuery' required in this place?
508          # By now: NO! It's more expensive and we can just expect existing objects for update operations.
509          # If it doesn't exist either, we assume the engine will fail on issuing the 'update' operation later...
510          $object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident});
511    
512          # mix in values
513          merge_to($object, $map);
514    
515          # update orm
516          $self->{meta}->{$descent}->{storage}->update($object);
517            
518        }
519    
520        my $error = 0;
521    
522        # handle new style callbacks - this is a HACK - do this without an eval!
523        #print Dumper($map);
524        #print "cb: ", Dumper($self->{meta}->{$descent}->{Callback});
525        #print Dumper($map_callbacks);
526        foreach my $node (keys %{$map_callbacks->{write}}) {
527          #print Dumper($node);
528    
529          # ------------  half-redundant: make $self->callCallback($object, $value, $opts)
530          my $perl_callback = $self->{meta}->{$descent}->{nodeType} . '::' . $node . '_write';
531          my $evalstring = $perl_callback . '( { object => $object, value => $map_callbacks->{write}->{$node}, storage => $self->{meta}->{$descent}->{storage} } );';
532          #print $evalstring, "\n"; exit;
533          eval($evalstring);
534          if ($@) {
535            $error = 1;
536            $logger->error( __PACKAGE__ . "->_modifyNode: $@" );
537            next;
538          }
539          # ------------  half-redundant: make $self->callCallback($object, $value, $opts)
540          
541          #print "after eval", "\n";
542          
543          if (!$error) {
544            # re-update@orm
545            $self->{meta}->{$descent}->{storage}->update($object);
546          }
547        }
548      
549        # handle errors
550        if ($error) {
551          #print "error", "\n";
552    =pod
553          my $sqlHandle;
554          #if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; }
555          $self->{node}->{status}->{error} = {
556            statement => $sql_main,
557            state => $sqlHandle->state,
558            err => $sqlHandle->err,
559            errstr => $sqlHandle->errstr,
560          };
561    =cut
562          # rollback....
563          #print "rollback", "\n";
564          $self->{meta}->{$descent}->{storage}->erase($object);
565          #print "after rollback", "\n";
566        } else {
567          $self->{node}->{status}->{ok} = 1;
568        }
569    
570      }
571    
572    }
573    
574    sub _erase_all {
575      my $self = shift;
576      my $descent = shift;
577      #my $node = shift;
578      #print Dumper($self->{meta}->{$descent});
579      #my $node = $self->{meta}->{$descent}->{nodeName};
580      my $node = $self->{meta}->{$descent}->{accessorName};
581      $logger->debug( __PACKAGE__ . "->_erase_all( node $node )" );
582      $self->{meta}->{$descent}->{storage}->eraseAll($node);
583    }
584    
585  1;  1;
586    __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.9
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed