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