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