/[cvs]/nfo/perl/libs/Data/Transfer/Sync.pm
ViewVC logotype

Annotation of /nfo/perl/libs/Data/Transfer/Sync.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Sun Jan 19 00:50:05 2003 UTC (21 years, 7 months ago) by joko
Branch: MAIN
Changes since 1.11: +4 -1 lines
FILE REMOVED
- moved to Data/Transfer/Sync/ - Core.pm, API.pm

1 joko 1.12 ## $Id: Sync.pm,v 1.11 2002/12/23 07:10:59 joko Exp $
2 joko 1.1 ##
3     ## Copyright (c) 2002 Andreas Motl <andreas.motl@ilo.de>
4     ##
5     ## See COPYRIGHT section in pod text below for usage and distribution rights.
6     ##
7     ## ----------------------------------------------------------------------------------------
8 joko 1.2 ## $Log: Sync.pm,v $
9 joko 1.12 ## Revision 1.11 2002/12/23 07:10:59 joko
10     ## + using MD5 for checksum generation again - the 32-bit integer hash from DBI seems to be too lazy
11     ##
12 joko 1.11 ## Revision 1.10 2002/12/19 01:07:16 joko
13     ## + fixed output done via $logger
14     ##
15 joko 1.10 ## Revision 1.9 2002/12/16 07:02:34 jonen
16     ## + added comment
17     ##
18 jonen 1.9 ## Revision 1.8 2002/12/15 02:03:09 joko
19     ## + fixed logging-messages
20     ## + additional metadata-checks
21     ##
22 joko 1.8 ## Revision 1.7 2002/12/13 21:49:34 joko
23     ## + sub configure
24     ## + sub checkOptions
25     ##
26 joko 1.7 ## Revision 1.6 2002/12/06 04:49:10 jonen
27     ## + disabled output-puffer here
28     ##
29 jonen 1.6 ## Revision 1.5 2002/12/05 08:06:05 joko
30     ## + bugfix with determining empty fields (Null) with DBD::CSV
31     ## + debugging
32     ## + updated comments
33     ##
34 joko 1.5 ## Revision 1.4 2002/12/03 15:54:07 joko
35     ## + {import}-flag is now {prepare}-flag
36     ##
37 joko 1.4 ## Revision 1.3 2002/12/01 22:26:59 joko
38     ## + minor cosmetics for logging
39     ##
40 joko 1.3 ## Revision 1.2 2002/12/01 04:43:25 joko
41     ## + mapping deatil entries may now be either an ARRAY or a HASH
42     ## + erase flag is used now (for export-operations)
43     ## + expressions to refer to values inside deep nested structures
44     ## - removed old mappingV2-code
45     ## + cosmetics
46     ## + sub _erase_all
47     ##
48 joko 1.2 ## Revision 1.1 2002/11/29 04:45:50 joko
49     ## + initial check in
50     ##
51 joko 1.1 ## Revision 1.1 2002/10/10 03:44:21 cvsjoko
52     ## + new
53     ## ----------------------------------------------------------------------------------------
54    
55    
56     package Data::Transfer::Sync;
57    
58     use strict;
59     use warnings;
60    
61     use Data::Dumper;
62 joko 1.7 #use Hash::Merge qw( merge );
63    
64 joko 1.1 use misc::HashExt;
65     use libp qw( md5_base64 );
66     use libdb qw( quotesql hash2Sql );
67 joko 1.2 use Data::Transform::Deep qw( hash2object refexpr2perlref );
68 joko 1.1 use Data::Compare::Struct qw( getDifference isEmpty );
69    
70     # get logger instance
71     my $logger = Log::Dispatch::Config->instance;
72    
73 jonen 1.6 $| = 1;
74 joko 1.1
75     sub new {
76     my $invocant = shift;
77     my $class = ref($invocant) || $invocant;
78 joko 1.7 my $self = {};
79 joko 1.1 $logger->debug( __PACKAGE__ . "->new(@_)" );
80     bless $self, $class;
81 joko 1.7 $self->configure(@_);
82 joko 1.1 return $self;
83     }
84    
85    
86 joko 1.7 sub configure {
87     my $self = shift;
88     my @args = @_;
89     if (!isEmpty(\@args)) {
90     my %properties = @_;
91     # merge args to properties
92     map { $self->{$_} = $properties{$_}; } keys %properties;
93     $self->_init();
94     } else {
95     #print "no args!", "\n";
96     }
97     #print Dumper($self);
98     }
99    
100 joko 1.1 sub _init {
101     my $self = shift;
102 joko 1.7
103     $self->{configured} = 1;
104 joko 1.1
105     # build new container if necessary
106     $self->{container} = Data::Storage::Container->new() if !$self->{container};
107    
108     # add storages to container (optional)
109     foreach (keys %{$self->{storages}}) {
110     $self->{container}->addStorage($_, $self->{storages}->{$_});
111     }
112    
113     # tag storages with id-authority and checksum-provider information
114     # TODO: better store tag inside metadata to hold bits together!
115     map { $self->{container}->{storage}->{$_}->{isIdentAuthority} = 1 } @{$self->{id_authorities}};
116     map { $self->{container}->{storage}->{$_}->{isChecksumAuthority} = 1; } @{$self->{checksum_authorities}};
117     map { $self->{container}->{storage}->{$_}->{isWriteProtected} = 1; } @{$self->{write_protected}};
118    
119     }
120    
121    
122 joko 1.7 sub prepareOptions {
123    
124     my $self = shift;
125     my $opts = shift;
126    
127     #print Dumper($opts);
128    
129     $opts->{mode} ||= '';
130     $opts->{erase} ||= 0;
131     #$opts->{import} ||= 0;
132    
133 joko 1.10 $logger->notice( __PACKAGE__ . "->prepareOptions( source_node $opts->{source_node} mode $opts->{mode} erase $opts->{erase} prepare $opts->{prepare} )");
134 joko 1.7
135     if (!$opts->{mapping} || !$opts->{mapping_module}) {
136     $logger->warning( __PACKAGE__ . "->prepareOptions: No mapping supplied - please check key 'mappings' in BizWorks/Config.pm");
137     }
138    
139     my $evstring = "use $opts->{mapping_module};";
140     eval($evstring);
141     if ($@) {
142     $logger->warning( __PACKAGE__ . "->prepareOptions: error while trying to access mapping - $@");
143     return;
144     }
145    
146     # resolve mapping metadata (returned from sub)
147     my $mapObject = $opts->{mapping_module}->new();
148     #print Dumper($map);
149     my $source_node_name = $opts->{source_node};
150     # check if mapping for certain node is contained in mapping object
151     if (!$mapObject->can($source_node_name)) {
152     $logger->warning( __PACKAGE__ . "->prepareOptions: Can't access mapping for node \"$source_node_name\" - please check $opts->{mapping_module}.");
153     return;
154     }
155     my $map = $mapObject->$source_node_name;
156    
157     # remove asymmetries from $map (patch keys)
158     $map->{source_node} = $map->{source}; delete $map->{source};
159     $map->{target_node} = $map->{target}; delete $map->{target};
160     $map->{mapping} = $map->{details}; delete $map->{details};
161     $map->{direction} = $map->{mode}; delete $map->{mode};
162    
163     # defaults (mostly for backward-compatibility)
164     $map->{source_node} ||= $source_node_name;
165     $map->{source_ident} ||= 'storage_method:id';
166     $map->{target_ident} ||= 'property:oid';
167     $map->{direction} ||= $opts->{mode}; # | PUSH | PULL | FULL
168     $map->{method} ||= 'checksum'; # | timestamp
169     $map->{source_exclude} ||= [qw( cs )];
170    
171     # merge map to opts
172     map { $opts->{$_} = $map->{$_}; } keys %$map;
173    
174     #print Dumper($opts);
175    
176     # TODO: move this to checkOptions...
177    
178     # check - do we have a target?
179     if (!$opts->{target_node}) {
180     $logger->warning( __PACKAGE__ . "->prepareOptions: No target given - please check metadata declaration.");
181     return;
182     }
183    
184    
185     #return $opts;
186     return 1;
187    
188     }
189    
190    
191     sub checkOptions {
192     my $self = shift;
193     my $opts = shift;
194    
195     my $result = 1;
196    
197     # check - do we have a target node?
198     if (!$opts->{target_node}) {
199     $logger->warning( __PACKAGE__ . "->checkOptions: Error while resolving resource metadata - no 'target node' could be determined.");
200     $result = 0;
201     }
202    
203     # check - do we have a mapping?
204     if (!$opts->{mapping} && !$opts->{mapping_module}) {
205     $logger->warning( __PACKAGE__ . "->checkOptions: Error while resolving resource metadata - no 'mapping' could be determined.");
206     $result = 0;
207     }
208    
209     return $result;
210    
211     }
212    
213    
214 joko 1.1 # TODO: some feature to show off the progress of synchronization (cur/max * 100)
215     sub syncNodes {
216    
217     my $self = shift;
218     my $args = shift;
219    
220 joko 1.7 if (!$self->{configured}) {
221     $logger->critical( __PACKAGE__ . "->syncNodes: Synchronization object is not configured/initialized correctly." );
222     return;
223     }
224    
225 joko 1.1 # remember arguments through the whole processing
226     $self->{args} = $args;
227    
228     $logger->debug( __PACKAGE__ . "->syncNodes: starting" );
229    
230     # hash to hold and/or fill in metadata required for the processing
231     $self->{meta} = {};
232    
233     # hash to sum up results
234     my $direction_arrow = '';
235    
236     # detect synchronization method to determine which optical symbol (directed arrow) to use
237     if (lc $self->{args}->{direction} eq 'push') {
238     $direction_arrow = '->';
239     } elsif (lc $self->{args}->{direction} eq 'pull') {
240     $direction_arrow = '<-';
241     } elsif (lc $self->{args}->{direction} eq 'full') {
242     $direction_arrow = '<->';
243     } else {
244     }
245    
246     # decompose identifiers for each partner
247 joko 1.7 # TODO: refactor!!! take this list from already established/given metadata
248 joko 1.1 foreach ('source', 'target') {
249    
250     # get/set metadata for further processing
251    
252     # Partner and Node (e.g.: "L:Country" or "R:countries.csv")
253     if (my $item = $self->{args}->{$_}) {
254     my @item = split(':', $item);
255     $self->{meta}->{$_}->{dbkey} = $item[0];
256     $self->{meta}->{$_}->{node} = $item[1];
257     }
258    
259     # Filter
260     if (my $item_filter = $self->{args}->{$_ . '_filter'}) {
261     $self->{meta}->{$_}->{filter} = $item_filter;
262     }
263    
264     # IdentProvider
265     if (my $item_ident = $self->{args}->{$_ . '_ident'}) {
266     my @item_ident = split(':', $item_ident);
267     $self->{meta}->{$_}->{IdentProvider} = { method => $item_ident[0], arg => $item_ident[1] };
268     }
269    
270     # TODO: ChecksumProvider
271    
272     # exclude properties/subnodes
273     if (my $item_exclude = $self->{args}->{$_ . '_exclude'}) {
274     $self->{meta}->{$_}->{subnodes_exclude} = $item_exclude;
275     }
276    
277     # TypeProvider
278     if (my $item_type = $self->{args}->{$_ . '_type'}) {
279     my @item_type = split(':', $item_type);
280     $self->{meta}->{$_}->{TypeProvider} = { method => $item_type[0], arg => $item_type[1] };
281     }
282    
283     # Callbacks - writers (will be triggered _before_ writing to target)
284     if (my $item_writers = $self->{args}->{$_ . '_callbacks_write'}) {
285     my $descent = $_; # this is important since the following code inside the map wants to use its own context variables
286     map { $self->{meta}->{$descent}->{Callback}->{write}->{$_}++; } @$item_writers;
287     }
288    
289     # Callbacks - readers (will be triggered _after_ reading from source)
290     if (my $item_readers = $self->{args}->{$_ . '_callbacks_read'}) {
291     my $descent = $_;
292     map { $self->{meta}->{$descent}->{Callback}->{read}->{$_}++; } @$item_readers;
293     }
294    
295     # resolve storage objects
296     #$self->{$_} = $self->{container}->{storage}->{$self->{meta}->{$_}->{dbkey}};
297     # relink references to metainfo
298     $self->{meta}->{$_}->{storage} = $self->{container}->{storage}->{$self->{meta}->{$_}->{dbkey}};
299     #print "iiiiisprov: ", Dumper($self->{meta}->{$_}->{storage}), "\n";
300     }
301    
302 joko 1.7 #print Dumper($self->{meta});
303    
304 joko 1.1 $logger->info( __PACKAGE__ . "->syncNodes: source=$self->{meta}->{source}->{dbkey}/$self->{meta}->{source}->{node} $direction_arrow target=$self->{meta}->{target}->{dbkey}/$self->{meta}->{target}->{node}" );
305    
306     # build mapping
307 joko 1.2 # incoming: and Array of node map entries (Array or Hash) - e.g.
308     # [ 'source:item_name' => 'target:class_val' ]
309     # { source => 'event->startDateTime', target => 'begindate' }
310 joko 1.1 foreach (@{$self->{args}->{mapping}}) {
311 joko 1.2 if (ref $_ eq 'ARRAY') {
312     my @entry1 = split(':', $_->[0]);
313     my @entry2 = split(':', $_->[1]);
314     my $descent = [];
315     my $node = [];
316     $descent->[0] = $entry1[0];
317     $descent->[1] = $entry2[0];
318     $node->[0] = $entry1[1];
319     $node->[1] = $entry2[1];
320     push @{$self->{meta}->{$descent->[0]}->{childnodes}}, $node->[0];
321     push @{$self->{meta}->{$descent->[1]}->{childnodes}}, $node->[1];
322     } elsif (ref $_ eq 'HASH') {
323     foreach my $entry_key (keys %$_) {
324     my $entry_val = $_->{$entry_key};
325     push @{$self->{meta}->{$entry_key}->{childnodes}}, $entry_val;
326     }
327     }
328    
329 joko 1.1 }
330    
331 joko 1.7 #print Dumper($self->{meta});
332    
333 joko 1.1 # check partners/nodes: does partner exist / is node available?
334     foreach my $partner (keys %{$self->{meta}}) {
335 joko 1.8
336     # 1. check partners & storages
337     if (!$self->{meta}->{$partner}) {
338     $logger->critical( __PACKAGE__ . "->syncNodes: Could not find partner '$partner' in configuration metadata." );
339     return;
340     }
341    
342     my $dbkey = $self->{meta}->{$partner}->{dbkey};
343    
344     if (!$self->{meta}->{$partner}->{storage}) {
345     $logger->critical( __PACKAGE__ . "->syncNodes: Could not access storage of partner '$partner' (named '$dbkey'), looks like a configuration-error." );
346     return;
347     }
348    
349     # TODO:
350     # 2. check if partners (and nodes?) are actually available....
351     # eventually pre-check mode of access-attempt (read/write) here to provide an "early-croak" if possible
352    
353     # 3. check nodes
354     next if $self->{meta}->{$partner}->{storage}->{locator}->{type} eq 'DBI'; # HACK for DBD::CSV - re-enable for others
355     # get node-name
356 joko 1.1 my $node = $self->{meta}->{$partner}->{node};
357     if (!$self->{meta}->{$partner}->{storage}->existsChildNode($node)) {
358 joko 1.8 $logger->critical( __PACKAGE__ . "->syncNodes: Could not reach node \"$node\" at partner \"$partner\"." );
359 joko 1.1 return;
360     }
361 joko 1.8
362 joko 1.1 }
363    
364     # TODO:
365     # + if action == PUSH: start processing
366     # -+ if action == PULL: swap metadata and start processing
367     # - if action == FULL: start processing, then swap metadata and (re-)start processing
368    
369     #print Dumper($self->{args});
370    
371     # manipulate metainfo according to direction of synchronization
372     if (lc $self->{args}->{direction} eq 'push') {
373     # just do it ...
374     } elsif (lc $self->{args}->{direction} eq 'pull') {
375     #print "=======SWAP", "\n";
376     # swap
377     ($self->{meta}->{source}, $self->{meta}->{target}) =
378     ($self->{meta}->{target}, $self->{meta}->{source});
379     } elsif (lc $self->{args}->{direction} eq 'full') {
380     } else {
381     }
382    
383     # import flag means: prepare the source node to be syncable
384     # this is useful if there are e.g. no "ident" or "checksum" columns yet inside a DBI like (row-based) storage
385 joko 1.4 if ($self->{args}->{prepare}) {
386 joko 1.1 $self->_prepareNode_MetaProperties('source');
387     $self->_prepareNode_DummyIdent('source');
388     #return;
389     #$self->_erase_all($opts->{source_node});
390     }
391    
392 joko 1.2 # erase flag means: erase the target
393     #if ($opts->{erase}) {
394     if ($self->{args}->{erase}) {
395     # TODO: move this method to the scope of the synchronization core and wrap it around different handlers
396     #print "ERASE", "\n";
397     $self->_erase_all('target');
398     }
399    
400 joko 1.1 $self->_syncNodes();
401    
402     }
403    
404    
405     # TODO: abstract the hardwired use of "source" and "target" in here somehow - hmmmm....... /(="§/%???
406     sub _syncNodes {
407    
408     my $self = shift;
409    
410     my $tc = OneLineDumpHash->new( {} );
411     my $results;
412    
413     # set of objects is already in $self->{args}
414     # TODO: make independent of the terminology "object..."
415     $results = $self->{args}->{objectSet} if $self->{args}->{objectSet};
416    
417     # apply filter
418     if (my $filter = $self->{meta}->{source}->{filter}) {
419     #print Dumper($filter);
420     #exit;
421     $results ||= $self->_getNodeList('source', $filter);
422     }
423    
424 joko 1.5 # get reference to node list from convenient method provided by CORE-HANDLE
425 joko 1.1 #$results ||= $self->{source}->getListUnfiltered($self->{meta}->{source}->{node});
426     #$results ||= $self->{meta}->{source}->{storage}->getListUnfiltered($self->{meta}->{source}->{node});
427     $results ||= $self->_getNodeList('source');
428    
429     # checkpoint: do we actually have a list to iterate through?
430     if (!$results || !@{$results}) {
431     $logger->notice( __PACKAGE__ . "->syncNodes: No nodes to synchronize." );
432     return;
433     }
434    
435     # dereference
436     my @results = @{$results};
437    
438     # iterate through set
439     foreach my $source_node_real (@results) {
440    
441     $tc->{total}++;
442    
443     #print "======================== iter", "\n";
444    
445     # clone object (in case we have to modify it here)
446     # TODO:
447     # - is a "deep_copy" needed here if occouring modifications take place?
448     # - puuhhhh, i guess a deep_copy would destroy tangram mechanisms?
449     # - after all, just take care for now that this object doesn't get updated!
450     my $source_node = $source_node_real;
451    
452     # modify entry - handle new style callbacks (the readers)
453     #print Dumper($source_node);
454     #exit;
455    
456     my $descent = 'source';
457    
458     # handle callbacks right now while scanning them (asymmetric to the writers)
459     my $map_callbacks = {};
460     if (my $callbacks = $self->{meta}->{$descent}->{Callback}) {
461    
462     my $error = 0;
463    
464     foreach my $node (keys %{$callbacks->{read}}) {
465    
466     my $object = $source_node;
467     my $value; # = $source_node->{$node};
468    
469     # ------------ half-redundant: make $self->callCallback($object, $value, $opts)
470     my $perl_callback = $self->{meta}->{$descent}->{node} . '::' . $node . '_read';
471     my $evalstring = 'return ' . $perl_callback . '( { object => $object, property => $node, value => $value, storage => $self->{meta}->{$descent}->{storage} } );';
472     #print $evalstring, "\n"; exit;
473     my $cb_result = eval($evalstring);
474     if ($@) {
475     die $@;
476     $error = 1;
477     print $@, "\n";
478     }
479     # ------------ half-redundant: make $self->callCallback($object, $value, $opts)
480    
481     $source_node->{$node} = $cb_result;
482    
483     }
484    
485     }
486    
487     #print Dumper($source_node);
488    
489     # exclude defined fields (simply delete from object)
490     map { delete $source_node->{$_} } @{$self->{meta}->{source}->{subnodes_exclude}};
491    
492     # here we accumulate information about the status of the current node (payload/row/object/item/entry)
493     $self->{node} = {};
494     $self->{node}->{source}->{payload} = $source_node;
495    
496     #print "res - ident", "\n";
497    
498     # determine ident of entry
499     my $identOK = $self->_resolveNodeIdent('source');
500     #if (!$identOK && lc $self->{args}->{direction} ne 'import') {
501     if (!$identOK) {
502 joko 1.5 #print Dumper($self->{meta}->{source});
503     $logger->critical( __PACKAGE__ . "->syncNodes: No ident found in source node \"$self->{meta}->{source}->{node}\", try to \"prepare\" this node first?" );
504 joko 1.1 return;
505     }
506    
507     #print "statload", "\n";
508     #print "ident: ", $self->{node}->{source}->{ident}, "\n";
509 joko 1.5 #print Dumper($self->{node});
510 joko 1.1
511     my $statOK = $self->_statloadNode('target', $self->{node}->{source}->{ident});
512 joko 1.5
513     #print Dumper($self->{node});
514 joko 1.1
515     # mark node as new either if there's no ident or if stat/load failed
516     if (!$statOK) {
517     $self->{node}->{status}->{new} = 1;
518     print "n" if $self->{verbose};
519     }
520    
521     #print "checksum", "\n";
522    
523     # determine status of entry by synchronization method
524     if ( (lc $self->{args}->{method} eq 'checksum') ) {
525     #if ( $statOK && (lc $self->{args}->{method} eq 'checksum') ) {
526     #if ( !$self->{node}->{status}->{new} && (lc $self->{args}->{method} eq 'checksum') ) {
527    
528     # TODO:
529     # is this really worth a "critical"???
530     # no - it should just be a debug appendix i believe
531    
532     #print "readcs", "\n";
533    
534     # calculate checksum of source node
535     #$self->_calcChecksum('source');
536     if (!$self->_readChecksum('source')) {
537     $logger->critical( __PACKAGE__ . "->_readChecksum: Could not find \"source\" entry with ident=\"$self->{node}->{source}->{ident}\"" );
538     $tc->{skip}++;
539     print "s" if $self->{verbose};
540     next;
541     }
542    
543     # get checksum from synchronization target
544     $self->_readChecksum('target');
545     #if (!$self->_readChecksum('target')) {
546     # $logger->critical( __PACKAGE__ . "->_readChecksum: Could not find \"target\" entry with ident=\"$self->{node}->{source}->{ident}\"" );
547     # next;
548     #}
549    
550     # pre flight check: do we actually have a checksum provided?
551     #if (!$self->{node}->{source}->{checksum}) {
552     # print "Source checksum for entry with ident \"$self->{node}->{source}->{ident}\" could not be calculated, maybe it's missing?.", "\n";
553     # return;
554     #}
555    
556     # determine if entry is "new" or "dirty"
557     # after all, this seems to be the point where the hammer falls.....
558     print "c" if $self->{verbose};
559     $self->{node}->{status}->{new} = !$self->{node}->{target}->{checksum};
560     if (!$self->{node}->{status}->{new}) {
561     $self->{node}->{status}->{dirty} =
562     $self->{node}->{status}->{new} ||
563     (!$self->{node}->{source}->{checksum} || !$self->{node}->{target}->{checksum}) ||
564     ($self->{node}->{source}->{checksum} ne $self->{node}->{target}->{checksum}) ||
565     $self->{args}->{force};
566     }
567    
568     }
569    
570     # first reaction on entry-status: continue with next entry if the current is already "in sync"
571     if (!$self->{node}->{status}->{new} && !$self->{node}->{status}->{dirty}) {
572     $tc->{in_sync}++;
573     next;
574     }
575    
576     # build map to actually transfer the data from source to target
577     $self->_buildMap();
578    
579    
580     #print Dumper($self->{node}); exit;
581    
582     #print "attempt", "\n";
583    
584     # additional (new) checks for feature "write-protection"
585     if ($self->{meta}->{target}->{storage}->{isWriteProtected}) {
586     $tc->{attempt_transfer}++;
587     print "\n" if $self->{verbose};
588     $logger->notice( __PACKAGE__ . "->syncNodes: Target is write-protected. Will not insert or modify node. " .
589     "(Ident: $self->{node}->{source}->{ident} " . "Dump:\n" . Dumper($self->{node}->{source}->{payload}) . ")" );
590     print "\n" if $self->{verbose};
591     $tc->{skip}++;
592     next;
593     }
594    
595     # transfer contents of map to target
596     if ($self->{node}->{status}->{new}) {
597     $tc->{attempt_new}++;
598     $self->_doTransferToTarget('insert');
599     # asymmetry: refetch node from target to re-calculate new ident and checksum (TODO: is IdentAuthority of relevance here?)
600 joko 1.5 #print Dumper($self->{node});
601 joko 1.1 $self->_statloadNode('target', $self->{node}->{target}->{ident}, 1);
602     $self->_readChecksum('target');
603    
604     } elsif ($self->{node}->{status}->{dirty}) {
605     $tc->{attempt_modify}++;
606     # asymmetry: get ident before updating (TODO: is IdentAuthority of relevance here?)
607     $self->{node}->{target}->{ident} = $self->{node}->{map}->{$self->{meta}->{target}->{IdentProvider}->{arg}};
608     $self->_doTransferToTarget('update');
609     $self->_readChecksum('target');
610     }
611    
612     if ($self->{node}->{status}->{ok}) {
613     $tc->{ok}++;
614     print "t" if $self->{verbose};
615     }
616    
617     if ($self->{node}->{status}->{error}) {
618     $tc->{error}++;
619     push( @{$tc->{error_per_row}}, $self->{node}->{status}->{error} );
620     print "e" if $self->{verbose};
621     }
622    
623     # change ident in source (take from target), if transfer was ok and target is an IdentAuthority
624     # this is (for now) called a "retransmit" indicated by a "r"-character when verbosing
625     if ($self->{node}->{status}->{ok} && $self->{meta}->{target}->{storage}->{isIdentAuthority}) {
626 joko 1.5 print "r" if $self->{verbose};
627 joko 1.1 #print Dumper($self->{meta});
628     #print Dumper($self->{node});
629     #exit;
630     $self->_doModifySource_IdentChecksum($self->{node}->{target}->{ident});
631     }
632    
633     print ":" if $self->{verbose};
634    
635     }
636    
637     print "\n" if $self->{verbose};
638    
639     # build user-message from some stats
640 joko 1.3 my $msg = "statistics: $tc";
641 joko 1.1
642     if ($tc->{error_per_row}) {
643     $msg .= "\n";
644 joko 1.2 $msg .= "errors from \"error_per_row\":" . "\n";
645 joko 1.1 $msg .= Dumper($tc->{error_per_row});
646     }
647    
648     # todo!!!
649     #sysevent( { usermsg => $msg, level => $level }, $taskEvent );
650     $logger->info( __PACKAGE__ . "->syncNodes: $msg" );
651    
652     return $tc;
653    
654     }
655    
656    
657 jonen 1.9 # refactor this as some core-function to do a generic dump resolving data-encapsulations of e.g. Set::Object
658 joko 1.1 sub _dumpCompact {
659     my $self = shift;
660    
661     #my $vars = \@_;
662     my @data = ();
663    
664     my $count = 0;
665     foreach (@_) {
666     my $item = {};
667     foreach my $key (keys %$_) {
668     my $val = $_->{$key};
669 joko 1.5
670     #print Dumper($val);
671    
672 joko 1.1 if (ref $val eq 'Set::Object') {
673     #print "========================= SET", "\n";
674 joko 1.5 #print Dumper($val);
675 joko 1.1 #print Dumper($val->members());
676     #$val = $val->members();
677     #$vars->[$count]->{$key} = $val->members() if $val->can("members");
678     #$item->{$key} = $val->members() if $val->can("members");
679     $item->{$key} = $val->members();
680     #print Dumper($vars->[$count]->{$key});
681 joko 1.5
682 joko 1.1 } else {
683     $item->{$key} = $val;
684     }
685 joko 1.5
686 joko 1.1 }
687     push @data, $item;
688     $count++;
689     }
690    
691 joko 1.5 #print "Dump:", Dumper(@data), "\n";
692 joko 1.1
693     $Data::Dumper::Indent = 0;
694     my $result = Dumper(@data);
695     $Data::Dumper::Indent = 2;
696     return $result;
697 joko 1.5
698 joko 1.1 }
699    
700    
701     sub _calcChecksum {
702    
703     my $self = shift;
704     my $descent = shift;
705     my $specifier = shift;
706    
707     # calculate checksum for current object
708     my $ident = $self->{node}->{$descent}->{ident};
709    
710     # build dump of this node
711     my $payload = $self->{node}->{$descent}->{payload};
712     #my $dump = $ident . "\n" . $item->quickdump();
713     #my $dump = $ident . "\n" . Dumper($item);
714     my $dump = $ident . "\n" . $self->_dumpCompact($payload);
715    
716     # TODO: $logger->dump( ... );
717     #$logger->debug( __PACKAGE__ . ": " . $dump );
718     #$logger->dump( __PACKAGE__ . ": " . $dump );
719    
720     # calculate checksum from dump
721 joko 1.11 # note: the 32-bit integer hash from DBI seems
722     # to generate duplicates with small payloads already in ranges of hundreds of items/rows!!!
723     # try to avoid to use it or try to use it only for payloads greater than, hmmm, let's say 30 chars?
724     # (we had about 15 chars average per item (row))
725    
726 joko 1.1 # md5-based fingerprint, base64 encoded (from Digest::MD5)
727 joko 1.11 $self->{node}->{$descent}->{checksum} = md5_base64($dump) . '==';
728 joko 1.1 # 32-bit integer "hash" value (maybe faster?) (from DBI)
729 joko 1.11 #$self->{node}->{$descent}->{checksum} = DBI::hash($dump, 1);
730 joko 1.1
731     # signal good
732     return 1;
733    
734     }
735    
736    
737     sub _readChecksum {
738     my $self = shift;
739    
740     my $descent = shift;
741    
742     #print "getcheck:", "\n"; print Dumper($self->{node}->{$descent});
743    
744     if (!$self->{node}->{$descent}) {
745     # signal checksum bad
746     return;
747     }
748    
749     # get checksum for current entry
750     # TODO: don't have the checksum column/property hardcoded as "cs" here, make this configurable somehow
751    
752     if ($self->{meta}->{$descent}->{storage}->{isChecksumAuthority}) {
753     #$self->{node}->{$descent}->{checksum} = $entry->{cs};
754     #$self->{node}->{$descent}->{checksum} = $self->_calcChecksum($descent); # $entry->{cs};
755     #print "descent: $descent", "\n";
756     $self->_calcChecksum($descent);
757     #print "checksum: ", $self->{node}->{$descent}->{checksum}, "\n";
758     } else {
759    
760     #$self->{node}->{$descent}->{checksum} = $entry->{cs};
761     $self->{node}->{$descent}->{checksum} = $self->{node}->{$descent}->{payload}->{cs};
762     }
763    
764     # signal checksum good
765     return 1;
766    
767     }
768    
769    
770     sub _buildMap {
771    
772     my $self = shift;
773    
774     # field-structure for building sql
775     # mapping of sql-fieldnames to object-attributes
776     $self->{node}->{map} = {};
777    
778     # manually set ...
779     # ... object-id
780     $self->{node}->{map}->{$self->{meta}->{target}->{IdentProvider}->{arg}} = $self->{node}->{source}->{ident};
781     # ... checksum
782     $self->{node}->{map}->{cs} = $self->{node}->{source}->{checksum};
783    
784     #print "sqlmap: ", Dumper($self->{node}->{map}), "\n";
785    
786     # for transferring flat structures via simple (1:1) mapping
787     # TODO: diff per property / property value
788    
789     if ($self->{args}->{mapping}) {
790     # apply mapping from $self->{args}->{mapping} to $self->{node}->{map}
791     #foreach my $key (@{$self->{meta}->{source}->{childnodes}}) {
792     my @childnodes = @{$self->{meta}->{source}->{childnodes}};
793     for (my $mapidx = 0; $mapidx <= $#childnodes; $mapidx++) {
794     #my $map_right = $self->{args}->{mapping}->{$key};
795    
796 joko 1.2 $self->{node}->{source}->{propcache} = {};
797     $self->{node}->{target}->{propcache} = {};
798    
799 joko 1.1 # get property name
800     $self->{node}->{source}->{propcache}->{property} = $self->{meta}->{source}->{childnodes}->[$mapidx];
801     $self->{node}->{target}->{propcache}->{property} = $self->{meta}->{target}->{childnodes}->[$mapidx];
802     #print "map: $map_right", "\n";
803    
804     # get property value
805     my $value;
806    
807     # detect for callback - old style - (maybe the better???)
808     if (ref($self->{node}->{target}->{map}) eq 'CODE') {
809     #$value = &$map_right($objClone);
810     } else {
811     # plain (scalar?) value
812     #$value = $objClone->{$map_right};
813     $self->{node}->{source}->{propcache}->{value} = $self->{node}->{source}->{payload}->{$self->{node}->{source}->{propcache}->{property}};
814     }
815     #$self->{node}->{map}->{$key} = $value;
816 joko 1.2
817     # detect expression
818     # for transferring deeply nested structures described by expressions
819     #print "val: $self->{node}->{source}->{propcache}->{value}", "\n";
820     if ($self->{node}->{source}->{propcache}->{property} =~ s/^expr://) {
821    
822     # create an anonymous sub to act as callback target dispatcher
823     my $cb_dispatcher = sub {
824     #print "=============== CALLBACK DISPATCHER", "\n";
825     #print "ident: ", $self->{node}->{source}->{ident}, "\n";
826     #return $self->{node}->{source}->{ident};
827    
828     };
829    
830    
831     #print Dumper($self->{node});
832    
833     # build callback map for helper function
834     #my $cbmap = { $self->{meta}->{source}->{IdentProvider}->{arg} => $cb_dispatcher };
835     my $cbmap = {};
836     my $value = refexpr2perlref($self->{node}->{source}->{payload}, $self->{node}->{source}->{propcache}->{property}, $cbmap);
837     $self->{node}->{source}->{propcache}->{value} = $value;
838     }
839 joko 1.1
840     # encode values dependent on type of underlying storage here - expand cases...
841     my $storage_type = $self->{meta}->{target}->{storage}->{locator}->{type};
842     if ($storage_type eq 'DBI') {
843     # ...for sql
844     $self->{node}->{source}->{propcache}->{value} = quotesql($self->{node}->{source}->{propcache}->{value});
845 joko 1.2 }
846     elsif ($storage_type eq 'Tangram') {
847     # iso? utf8 already possible?
848    
849 joko 1.1 } elsif ($storage_type eq 'LDAP') {
850     # TODO: encode utf8 here?
851     }
852    
853     # store value to transfer map
854     $self->{node}->{map}->{$self->{node}->{target}->{propcache}->{property}} = $self->{node}->{source}->{propcache}->{value};
855    
856     }
857     }
858    
859    
860     # TODO: $logger->dump( ... );
861     #$logger->debug( "sqlmap:" . "\n" . Dumper($self->{node}->{map}) );
862     #print "sqlmap: ", Dumper($self->{node}->{map}), "\n";
863     #print "entrystatus: ", Dumper($self->{node}), "\n";
864    
865     }
866    
867     sub _resolveNodeIdent {
868     my $self = shift;
869     my $descent = shift;
870    
871     #print Dumper($self->{node}->{$descent});
872    
873     # get to the payload
874     #my $item = $specifier->{item};
875     my $payload = $self->{node}->{$descent}->{payload};
876    
877     # resolve method to get to the id of the given item
878     # we use global metadata and the given descent for this task
879     #my $ident = $self->{$descent}->id($item);
880     #my $ident = $self->{meta}->{$descent}->{storage}->id($item);
881    
882     my $ident;
883     my $provider_method = $self->{meta}->{$descent}->{IdentProvider}->{method};
884     my $provider_arg = $self->{meta}->{$descent}->{IdentProvider}->{arg};
885    
886     # resolve to ident
887     if ($provider_method eq 'property') {
888     $ident = $payload->{$provider_arg};
889    
890     } elsif ($provider_method eq 'storage_method') {
891     #$ident = $self->{meta}->{$descent}->{storage}->id($item);
892     $ident = $self->{meta}->{$descent}->{storage}->$provider_arg($payload);
893     }
894    
895     $self->{node}->{$descent}->{ident} = $ident;
896    
897     return 1 if $ident;
898    
899     }
900    
901    
902     sub _modifyNode {
903     my $self = shift;
904     my $descent = shift;
905     my $action = shift;
906     my $map = shift;
907     my $crit = shift;
908    
909     # map for new style callbacks
910     my $map_callbacks = {};
911    
912     # checks go first!
913    
914     # TODO: this should be reviewed first - before extending ;-)
915     # TODO: this should be extended:
916     # count this cases inside the caller to this sub and provide a better overall message
917     # if this counts still zero in the end:
918     # "No nodes have been touched for modify: Do you have column-headers in your csv file?"
919     if (not defined $self->{node}) {
920     #$logger->critical( __PACKAGE__ . "->_modifyNode failed: \"$descent\" node is empty." );
921     #return;
922     }
923    
924     # transfer callback nodes from value map to callback map - handle them afterwards! - (new style callbacks)
925     if (my $callbacks = $self->{meta}->{$descent}->{Callback}) {
926     foreach my $callback (keys %{$callbacks->{write}}) {
927     $map_callbacks->{write}->{$callback} = $map->{$callback};
928     delete $map->{$callback};
929     }
930     }
931    
932 joko 1.5
933     #print Dumper($self->{meta});
934 joko 1.1
935     # DBI speaks SQL
936     if ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'DBI') {
937    
938     #print Dumper($self->{node});
939     my $sql_main;
940     # translate map to sql
941     #print $action, "\n"; exit;
942     #print $self->{meta}->{$descent}->{node}, "\n"; exit;
943     #print "action:";
944     #print $action, "\n";
945     #$action = "anc";
946     #print "yai", "\n";
947 joko 1.7
948     #print Dumper($map);
949     #delete $map->{cs};
950    
951 joko 1.1 if (lc($action) eq 'insert') {
952     $sql_main = hash2Sql($self->{meta}->{$descent}->{node}, $map, 'SQL_INSERT');
953     } elsif (lc $action eq 'update') {
954     $crit ||= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'";
955     $sql_main = hash2Sql($self->{meta}->{$descent}->{node}, $map, 'SQL_UPDATE', $crit);
956     }
957    
958 joko 1.7 #$sql_main = "UPDATE currencies_csv SET oid='abcdef' WHERE text='Australian Dollar' AND key='AUD';";
959     #$sql_main = "UPDATE currencies_csv SET oid='huhu2' WHERE ekey='AUD'";
960    
961     #print "sql: ", $sql_main, "\n";
962     #exit;
963 joko 1.1
964     # transfer data
965     my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main);
966    
967 joko 1.7 #exit;
968    
969 joko 1.1 # handle errors
970     if ($sqlHandle->err) {
971     #if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; }
972     $self->{node}->{status}->{error} = {
973     statement => $sql_main,
974     state => $sqlHandle->state,
975     err => $sqlHandle->err,
976     errstr => $sqlHandle->errstr,
977     };
978     } else {
979     $self->{node}->{status}->{ok} = 1;
980     }
981    
982     # Tangram does it the oo-way (naturally)
983     } elsif ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'Tangram') {
984     my $sql_main;
985     my $object;
986    
987     # determine classname
988     my $classname = $self->{meta}->{$descent}->{node};
989    
990     # properties to exclude
991     my @exclude = @{$self->{meta}->{$descent}->{subnodes_exclude}};
992    
993    
994     if (my $identProvider = $self->{meta}->{$descent}->{IdentProvider}) {
995     push @exclude, $identProvider->{arg};
996     }
997    
998     # new feature:
999     # - check TypeProvider metadata property from other side
1000     # - use argument (arg) inside as a classname for object creation on this side
1001     #my $otherSide = $self->_otherSide($descent);
1002     if (my $typeProvider = $self->{meta}->{$descent}->{TypeProvider}) {
1003     #print Dumper($map);
1004     $classname = $map->{$typeProvider->{arg}};
1005     # remove nodes from map also (push nodes to "subnodes_exclude" list)
1006     push @exclude, $typeProvider->{arg};
1007     }
1008    
1009     # exclude banned properties (remove from map)
1010     #map { delete $self->{node}->{map}->{$_} } @{$self->{args}->{exclude}};
1011     map { delete $map->{$_} } @exclude;
1012    
1013     # list of properties
1014     my @props = keys %{$map};
1015    
1016     # transfer data
1017     if (lc $action eq 'insert') {
1018    
1019     # build array to initialize object
1020     #my @initarray = ();
1021     #map { push @initarray, $_, undef; } @props;
1022    
1023     # make the object persistent in four steps:
1024     # - raw create (perl / class tangram scope)
1025     # - engine insert (tangram scope) ... this establishes inheritance - don't try to fill in inherited properties before!
1026     # - raw fill-in from hash (perl scope)
1027     # - engine update (tangram scope) ... this updates all properties just filled in
1028    
1029     # create new object ...
1030     #my $object = $classname->new( @initarray );
1031     $object = $classname->new();
1032    
1033     # ... pass to orm ...
1034     $self->{meta}->{$descent}->{storage}->insert($object);
1035    
1036     # ... and initialize with empty (undef'd) properties.
1037     #print Dumper(@props);
1038     map { $object->{$_} = undef; } @props;
1039    
1040     # mix in values ...
1041     hash2object($object, $map);
1042    
1043     # ... and re-update@orm.
1044 joko 1.5 #print Dumper($object);
1045 joko 1.1 $self->{meta}->{$descent}->{storage}->update($object);
1046    
1047     # asymmetry: get ident after insert
1048     # TODO:
1049     # - just do this if it is an IdentAuthority
1050     # - use IdentProvider metadata here
1051 joko 1.5 #print Dumper($self->{meta}->{$descent});
1052     my $oid = $self->{meta}->{$descent}->{storage}->id($object);
1053     #print "oid: $oid", "\n";
1054     $self->{node}->{$descent}->{ident} = $oid;
1055 joko 1.1
1056    
1057     } elsif (lc $action eq 'update') {
1058    
1059     # get fresh object from orm first
1060     $object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident});
1061    
1062     #print Dumper($self->{node});
1063    
1064     # mix in values
1065     #print Dumper($object);
1066     hash2object($object, $map);
1067     #print Dumper($object);
1068     #exit;
1069     $self->{meta}->{$descent}->{storage}->update($object);
1070     }
1071    
1072     my $error = 0;
1073    
1074     # handle new style callbacks - this is a HACK - do this without an eval!
1075     #print Dumper($map);
1076     #print "cb: ", Dumper($self->{meta}->{$descent}->{Callback});
1077     #print Dumper($map_callbacks);
1078     foreach my $node (keys %{$map_callbacks->{write}}) {
1079     #print Dumper($node);
1080     my $perl_callback = $self->{meta}->{$descent}->{node} . '::' . $node . '_write';
1081     my $evalstring = $perl_callback . '( { object => $object, value => $map_callbacks->{write}->{$node}, storage => $self->{meta}->{$descent}->{storage} } );';
1082     #print $evalstring, "\n"; exit;
1083     eval($evalstring);
1084     if ($@) {
1085     $error = 1;
1086     print $@, "\n";
1087     }
1088    
1089     #print "after eval", "\n";
1090    
1091     if (!$error) {
1092     # re-update@orm
1093     $self->{meta}->{$descent}->{storage}->update($object);
1094     }
1095     }
1096    
1097     # handle errors
1098     if ($error) {
1099     #print "error", "\n";
1100     =pod
1101     my $sqlHandle;
1102     #if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; }
1103     $self->{node}->{status}->{error} = {
1104     statement => $sql_main,
1105     state => $sqlHandle->state,
1106     err => $sqlHandle->err,
1107     errstr => $sqlHandle->errstr,
1108     };
1109     =cut
1110     # rollback....
1111     #print "rollback", "\n";
1112     $self->{meta}->{$descent}->{storage}->erase($object);
1113     #print "after rollback", "\n";
1114     } else {
1115     $self->{node}->{status}->{ok} = 1;
1116     }
1117    
1118    
1119     }
1120    
1121     }
1122    
1123     # TODO:
1124     # this should be split up into...
1125     # - a "_statNode" (should just touch the node to check for existance)
1126     # - a "_loadNode" (should load node completely)
1127     # - maybe additionally a "loadNodeProperty" (may specify properties to load)
1128     # - introduce $self->{nodecache} for this purpose
1129     # TODO:
1130     # should we:
1131     # - not pass ident in here but resolve it via "$descent"?
1132     # - refactor this and stuff it with additional debug/error message
1133     # - this = the way the implicit load mechanism works
1134     sub _statloadNode {
1135    
1136     my $self = shift;
1137     my $descent = shift;
1138     my $ident = shift;
1139     my $force = shift;
1140    
1141     # fetch entry to retrieve checksum from
1142     # was:
1143     if (!$self->{node}->{$descent} || $force) {
1144     # is:
1145     #if (!$self->{node}->{$descent}->{item} || $force) {
1146    
1147     if (!$ident) {
1148     #print "\n", "Attempt to fetch entry implicitely by ident failed: no ident given! This may result in an insert if no write-protection is in the way.", "\n";
1149     return;
1150     }
1151 joko 1.5
1152     # patch for DBD::CSV
1153     if ($ident && $ident eq 'Null') {
1154     return;
1155     }
1156 joko 1.1
1157 joko 1.7 #print "yai!", "\n";
1158    
1159     my $query = {
1160 joko 1.1 node => $self->{meta}->{$descent}->{node},
1161     subnodes => [qw( cs )],
1162     criterias => [
1163     { key => $self->{meta}->{$descent}->{IdentProvider}->{arg},
1164     op => 'eq',
1165     val => $ident },
1166     ]
1167 joko 1.7 };
1168    
1169     #print Dumper($query);
1170    
1171     my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query);
1172 joko 1.1
1173     my $entry = $result->getNextEntry();
1174 joko 1.7
1175     #print Dumper($entry);
1176     #print "pers: " . $self->{meta}->{$descent}->{storage}->is_persistent($entry), "\n";
1177     #my $state = $self->{meta}->{$descent}->{storage}->_fetch_object_state($entry, { name => 'TransactionHop' } );
1178     #print Dumper($state);
1179    
1180 joko 1.1 my $status = $result->getStatus();
1181    
1182 joko 1.5 #print Dumper($status);
1183    
1184 joko 1.1 # TODO: enhance error handling (store inside tc)
1185     #if (!$row) {
1186     # print "\n", "row error", "\n";
1187     # next;
1188     #}
1189 joko 1.5
1190     # these checks run before actually loading payload- and meta-data to node-container
1191    
1192     # 1st level - hard error
1193     if ($status && $status->{err}) {
1194 joko 1.7 $logger->debug( __PACKAGE__ . "->_statloadNode (ident=\"$ident\") failed - hard error (that's ok): $status->{err}" );
1195 joko 1.5 return;
1196     }
1197    
1198     # 2nd level - logical (empty/notfound) error
1199     if (($status && $status->{empty}) || !$entry) {
1200     $logger->debug( __PACKAGE__ . "->_statloadNode (ident=\"$ident\") failed - logical error (that's ok)" );
1201     #print "no entry (logical)", "\n";
1202     return;
1203     }
1204    
1205     #print Dumper($entry);
1206    
1207 joko 1.1 # was:
1208     # $self->{node}->{$descent}->{ident} = $ident;
1209     # is:
1210 joko 1.5 # TODO: re-resolve ident from entry via metadata "IdentProvider" here - like elsewhere
1211 joko 1.1 $self->{node}->{$descent}->{ident} = $ident;
1212     $self->{node}->{$descent}->{payload} = $entry;
1213 joko 1.5
1214 joko 1.1 }
1215    
1216     return 1;
1217    
1218     }
1219    
1220     sub _doTransferToTarget {
1221     my $self = shift;
1222     my $action = shift;
1223     $self->_modifyNode('target', $action, $self->{node}->{map});
1224     }
1225    
1226     sub _doModifySource_IdentChecksum {
1227     my $self = shift;
1228     my $ident_new = shift;
1229     # this changes an old node to a new one including ident and checksum
1230     # TODO:
1231     # - eventually introduce an external resource to store this data to
1232     # - we won't have to "re"-modify the source node here
1233     my $map = {
1234     $self->{meta}->{source}->{IdentProvider}->{arg} => $ident_new,
1235     cs => $self->{node}->{target}->{checksum},
1236     };
1237 joko 1.5
1238     #print Dumper($map);
1239     #print Dumper($self->{node});
1240     #exit;
1241    
1242 joko 1.1 $self->_modifyNode('source', 'update', $map);
1243     }
1244    
1245    
1246     # this is a shortcut method
1247     # ... let's try to avoid _any_ redundant code in here (ok... - at the cost of method lookups...)
1248     sub _getNodeList {
1249     my $self = shift;
1250     my $descent = shift;
1251     my $filter = shift;
1252     return $self->{meta}->{$descent}->{storage}->getListFiltered($self->{meta}->{$descent}->{node}, $filter);
1253     }
1254    
1255    
1256     sub _prepareNode_MetaProperties {
1257     my $self = shift;
1258     my $descent = shift;
1259    
1260     $logger->info( __PACKAGE__ . "->_prepareNode_MetaProperties( descent $descent )" );
1261    
1262     # TODO: this should (better) be: "my $firstnode = $self->_getFirstNode($descent);"
1263     my $list = $self->_getNodeList($descent);
1264    
1265     # get first node
1266     my $firstnode = $list->[0];
1267    
1268     # check if node contains meta properties/nodes
1269     # TODO: "cs" is hardcoded here!
1270     my @required = ( $self->{meta}->{$descent}->{IdentProvider}->{arg}, 'cs' );
1271     my @found = keys %$firstnode;
1272     #my @diff = getDifference(\@found, \@required);
1273     my $diff = getDifference(\@required, \@found);
1274     #print Dumper(@found);
1275     #print Dumper(@required);
1276     #print Dumper(@diff);
1277     #if (!$#diff || $#diff == -1) {
1278     if (isEmpty($diff)) {
1279     $logger->warning( __PACKAGE__ . "->_prepareNode_MetaProperties: node is lacking meta properties - will try to alter..." );
1280     foreach (@required) {
1281     my $sql = "ALTER TABLE $self->{meta}->{$descent}->{node} ADD COLUMN $_";
1282     #print "sql: $sql", "\n";
1283     my $res = $self->{meta}->{$descent}->{storage}->sendCommand($sql);
1284     #print Dumper($res->getStatus());
1285     }
1286     }
1287    
1288     }
1289    
1290     sub _prepareNode_DummyIdent {
1291     my $self = shift;
1292     my $descent = shift;
1293    
1294     $logger->info( __PACKAGE__ . "->_prepareNode_DummyIdent( descent $descent )" );
1295    
1296     my $list = $self->_getNodeList($descent);
1297     #print Dumper($list);
1298     my $i = 0;
1299     my $ident_base = 5678983;
1300     my $ident_appendix = '0001';
1301     foreach my $node (@$list) {
1302     my $ident_dummy = $i + $ident_base;
1303     $ident_dummy .= $ident_appendix;
1304     my $map = {
1305     $self->{meta}->{$descent}->{IdentProvider}->{arg} => $ident_dummy,
1306     cs => undef,
1307     };
1308    
1309     # diff lists and ...
1310     my $diff = getDifference([keys %$node], [keys %$map]);
1311     next if $#{$diff} == -1;
1312    
1313     # ... build criteria including all columns
1314     my @crits;
1315     foreach my $property (@$diff) {
1316     next if !$property;
1317     my $value = $node->{$property};
1318     next if !$value;
1319     push @crits, "$property='" . quotesql($value) . "'";
1320     }
1321     my $crit = join ' AND ', @crits;
1322     print "p" if $self->{verbose};
1323 joko 1.5
1324     #print Dumper($map);
1325     #print Dumper($crit);
1326    
1327 joko 1.1 $self->_modifyNode($descent, 'update', $map, $crit);
1328     $i++;
1329     }
1330    
1331     print "\n" if $self->{verbose};
1332    
1333     if (!$i) {
1334     $logger->warning( __PACKAGE__ . "->_prepareNode_DummyIdent: no nodes touched" );
1335     }
1336    
1337     }
1338    
1339     # TODO: handle this in an abstract way (wipe out use of 'source' and/or 'target' inside core)
1340     sub _otherSide {
1341     my $self = shift;
1342 joko 1.2 my $descent = shift;
1343     return 'source' if $descent eq 'target';
1344     return 'target' if $descent eq 'source';
1345 joko 1.1 return '';
1346 joko 1.2 }
1347    
1348     sub _erase_all {
1349     my $self = shift;
1350     my $descent = shift;
1351     #my $node = shift;
1352     my $node = $self->{meta}->{$descent}->{node};
1353     $self->{meta}->{$descent}->{storage}->eraseAll($node);
1354 joko 1.1 }
1355    
1356    
1357     =pod
1358    
1359    
1360     =head1 DESCRIPTION
1361    
1362     Data::Transfer::Sync is a module providing a generic synchronization process
1363     across arbitrary/multiple storages based on a ident/checksum mechanism.
1364     It sits on top of Data::Storage.
1365    
1366    
1367     =head1 REQUIREMENTS
1368    
1369     For full functionality:
1370     Data::Storage
1371     Data::Transform
1372     Data::Compare
1373     ... and all their dependencies
1374    
1375    
1376     =head1 AUTHORS / COPYRIGHT
1377    
1378     The Data::Storage module is Copyright (c) 2002 Andreas Motl.
1379     All rights reserved.
1380    
1381     You may distribute it under the terms of either the GNU General Public
1382     License or the Artistic License, as specified in the Perl README file.
1383    
1384    
1385     =head1 SUPPORT / WARRANTY
1386    
1387     Data::Storage is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
1388    
1389    
1390    
1391     =head1 BUGS
1392    
1393     When in "import" mode for windows file - DBD::AutoCSV may hang.
1394     Hint: Maybe the source node contains an ident-, but no checksum-column?
1395    
1396    
1397     =head1 USER LEVEL ERRORS
1398    
1399     =head4 Mapping
1400    
1401     - - - - - - - - - - - - - - - - - - - - - - - - - -
1402     info: BizWorks::Process::Setup->syncResource( source_node Currency mode PULL erase 0 import 0 )critical: BizWorks::Process::Setup->startSync: Can't access mapping for node "Currency" - please check BizWorks::ResourceMapping.
1403     - - - - - - - - - - - - - - - - - - - - - - - - - -
1404     You have to create a sub for each node used in synchronization inside named Perl module. The name of this sub _must_ match
1405     the name of the node you want to sync. This sub holds mapping metadata to give the engine hints about how
1406     to access the otherwise generic nodes.
1407     - - - - - - - - - - - - - - - - - - - - - - - - - -
1408    
1409    
1410     =head4 DBD::AutoCSV's rulebase
1411    
1412     - - - - - - - - - - - - - - - - - - - - - - - - - -
1413     info: BizWorks::Process::Setup->syncResource( source_node Currency mode PULL erase 0 import 0 )
1414     info: Data::Transfer::Sync->syncNodes: source=L/Currency <- target=R/currencies.csv
1415    
1416     Execution ERROR: Error while scanning: Missing first row or scanrule not applied. at C:/home/amo/develop/netfrag.org/nfo/perl/libs/DBD/CSV.p
1417     m line 165, <GEN9> line 1.
1418     called from C:/home/amo/develop/netfrag.org/nfo/perl/libs/Data/Storage/Handler/DBI.pm at 123.
1419    
1420     DBI-Error: DBD::AutoCSV::st fetchrow_hashref failed: Attempt to fetch row from a Non-SELECT statement
1421     notice: Data::Transfer::Sync->syncNodes: No nodes to synchronize.
1422     - - - - - - - - - - - - - - - - - - - - - - - - - -
1423     DBD::AutoCSV contains a rulebase which is spooled down while attempting to guess the style of the csv file regarding
1424     parameters like newline (eol), column-seperation-character (sep_char), quoting character (quote_char).
1425     If this spool runs out of entries and no style could be resolved, DBD::CSV dies causing this "Execution ERROR" which
1426     results in a "DBI-Error" afterwards.
1427     - - - - - - - - - - - - - - - - - - - - - - - - - -
1428    
1429    
1430     =head4 Check structure of source node
1431    
1432     - - - - - - - - - - - - - - - - - - - - - - - - - -
1433     info: Data::Transfer::Sync->syncNodes: source=L/Currency <- target=R/currencies.csv
1434     critical: Data::Transfer::Sync->syncNodes: Can not synchronize: No ident found in source node, maybe try to "import" this node first.
1435     - - - - - - - - - - - - - - - - - - - - - - - - - -
1436     If lowlevel detection succeeds, but no other required informations are found, this message is issued.
1437     "Other informations" might be:
1438     - column-header-row completely missing
1439     - ident column is empty
1440     - - - - - - - - - - - - - - - - - - - - - - - - - -
1441    
1442    
1443     =head4 Modify structure of source node
1444    
1445     - - - - - - - - - - - - - - - - - - - - - - - - - -
1446     info: Data::Transfer::Sync->syncNodes: source=L/Currency <- target=R/currencies.csv
1447     info: Data::Transfer::Sync->_prepareNode_MetaProperties( descent source )
1448     warning: Data::Transfer::Sync->_prepareNode_MetaProperties: node is lacking meta properties - will try to alter...
1449     SQL ERROR: Command 'ALTER' not recognized or not supported!
1450    
1451     SQL ERROR: Command 'ALTER' not recognized or not supported!
1452     - - - - - - - - - - - - - - - - - - - - - - - - - -
1453     The Engine found a node which structure does not match the required. It tries to alter this automatically - only when doing "import" -
1454     but the DBD driver (in this case DBD::CSV) gets in the way croaking not to be able to do this.
1455     This could also appear if your database connection has insufficient rights to modify the database structure.
1456     DBD::CSV croaks because it doesn't implement the ALTER command, so please edit your columns manually.
1457     Hint: Add columns with the names of your "ident" and "checksum" property specifications.
1458     - - - - - - - - - - - - - - - - - - - - - - - - - -
1459    
1460    
1461     =head4 Load source node by ident
1462    
1463     - - - - - - - - - - - - - - - - - - - - - - - - - -
1464     info: Data::Transfer::Sync->_prepareNode_DummyIdent( descent source )
1465     pcritical: Data::Transfer::Sync->_modifyNode failed: "source" node is empty.
1466     - - - - - - - - - - - - - - - - - - - - - - - - - -
1467     The source node could not be loaded. Maybe the ident is missing. Please check manually.
1468     Hint: Like above, the ident and/or checksum columns may be missing....
1469     - - - - - - - - - - - - - - - - - - - - - - - - - -
1470    
1471    
1472     =head1 TODO
1473    
1474     - sub _resolveIdentProvider
1475     - wrap _doModifySource and _doTransferTarget around a core function which can change virtually any type of node
1476     - split this module up into Sync.pm, Sync/Core.pm, Sync/Compare.pm and Sync/Compare/Checksum.pm
1477     - introduce _compareNodes as a core method and wrap it around methods in Sync/Compare/Checksum.pm
1478     - introduce Sync/Compare/MyComparisonImplementation.pm
1479     - some generic deferring method - e.g. "$self->defer(action)" - to be able to accumulate a bunch of actions for later processing
1480     - this implies everything done is _really_ split up into generic actions - how else would we defer them???
1481     - example uses:
1482     - fetch whole checksum list from node
1483     - remember source ident retransmits
1484     - remember: this is convenient - and maybe / of course faster - but we'll loose "per-node-atomic" operations
1485     - feature: mechanism to implicit inject checksum property to nodes (alter table / modify schema)
1486     - expand statistics / keep track of:
1487     - touched/untouched nodes
1488     - full sync
1489     - just do a push and a pull for now but use stats for touched nodes in between to speed up things
1490     - introduce some new metadata flags for a synchronization partner which is (e.g.) of "source" or "target":
1491     - isNewNodePropagator
1492     - isWriteProtected
1493    
1494    
1495     =cut
1496    
1497     1;

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed