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