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