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