--- nfo/perl/libs/Data/Transfer/Sync/StorageInterface.pm 2003/01/20 16:58:46 1.1 +++ nfo/perl/libs/Data/Transfer/Sync/StorageInterface.pm 2003/04/09 07:27:02 1.8 @@ -1,4 +1,4 @@ -## $Id: StorageInterface.pm,v 1.1 2003/01/20 16:58:46 joko Exp $ +## $Id: StorageInterface.pm,v 1.8 2003/04/09 07:27:02 joko Exp $ ## ## Copyright (c) 2002 Andreas Motl ## @@ -6,6 +6,30 @@ ## ## ---------------------------------------------------------------------------------------- ## $Log: StorageInterface.pm,v $ +## Revision 1.8 2003/04/09 07:27:02 joko +## minor update (just cosmetics) +## +## Revision 1.7 2003/03/27 15:31:16 joko +## fixes to modules regarding new namespace(s) below Data::Mungle::* +## +## Revision 1.6 2003/02/21 01:47:53 joko +## renamed core function +## +## Revision 1.5 2003/02/20 20:24:33 joko +## + additional pre-flight checks +## +## Revision 1.4 2003/02/14 14:14:38 joko +## + new code refactored here +## +## Revision 1.3 2003/02/11 07:54:55 joko +## + modified module usage +## + debugging trials +## +## Revision 1.2 2003/02/09 05:05:58 joko +## + major structure changes +## - refactored code to sister modules +## + refactored code to this place +## ## Revision 1.1 2003/01/20 16:58:46 joko ## + initial check-in: here they are.... ## @@ -25,21 +49,25 @@ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - main -# get logger instance -my $logger = Log::Dispatch::Config->instance; - use Data::Dumper; +use Hash::Merge qw( merge ); +use shortcuts::db qw( hash2sql ); +use Data::Mungle::Transform::Deep qw( merge_to ); +# get logger instance +my $logger = Log::Dispatch::Config->instance; + # this is a shortcut method # ... let's try to avoid _any_ redundant code in here (ok... - at the cost of method lookups...) sub _getNodeList { my $self = shift; my $descent = shift; my $filter = shift; + $logger->debug( __PACKAGE__ . "->_getNodeList( descent=$descent, accessorName=$self->{meta}->{$descent}->{accessorName} )" ); #$results ||= $self->{source}->getListUnfiltered($self->{meta}->{source}->{node}); #$results ||= $self->{meta}->{source}->{storage}->getListUnfiltered($self->{meta}->{source}->{node}); - my $list = $self->{meta}->{$descent}->{storage}->getListFiltered($self->{meta}->{$descent}->{nodeName}, $filter); + my $list = $self->{meta}->{$descent}->{storage}->getListFiltered($self->{meta}->{$descent}->{accessorName}, $filter); #print Dumper($list); return $list; } @@ -48,7 +76,12 @@ my $self = shift; my $descent = shift; - #print Dumper($self->{node}->{$descent}); + # trace + #print Dumper($self->{node}->{$descent}); + #print Dumper($self); + #exit; + + $logger->debug( __PACKAGE__ . "->_resolveNodeIdent( descent=$descent, accessorName=$self->{meta}->{$descent}->{accessorName} )" ); # get to the payload #my $item = $specifier->{item}; @@ -59,12 +92,18 @@ #my $ident = $self->{$descent}->id($item); #my $ident = $self->{meta}->{$descent}->{storage}->id($item); + # trace + #print Dumper($self->{meta}->{$descent}); + #exit; + my $ident; my $provider_method = $self->{meta}->{$descent}->{IdentProvider}->{method}; my $provider_arg = $self->{meta}->{$descent}->{IdentProvider}->{arg}; - #print "provider_method: $provider_method", "\n"; - #print "provider_arg: $provider_arg", "\n"; + # trace + #print "provider_method: $provider_method", "\n"; + #print "provider_arg: $provider_arg", "\n"; + #print Dumper($payload); # resolve to ident if (lc $provider_method eq 'property') { @@ -103,6 +142,19 @@ my $ident = shift; my $force = shift; +=pod + #print "isa: ", UNIVERSAL::isa($self->{meta}->{$descent}->{storage}), "\n"; + + # this seems to be the first time we access this side, + # so just check (again) for a valid storage handle + if (! ref $self->{meta}->{$descent}->{storage}) { + $logger->critical( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident ): Storage handle undefined!" ); + return; + } +=cut + + #$logger->debug( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident )" ); + # fetch entry to retrieve checksum from # was: if (!$self->{node}->{$descent} || $force) { @@ -119,10 +171,10 @@ return; } -#print "yai!", "\n"; + #print Dumper($self->{meta}); my $query = { - node => $self->{meta}->{$descent}->{nodeName}, + node => $self->{meta}->{$descent}->{accessorName}, subnodes => [qw( cs )], criterias => [ { key => $self->{meta}->{$descent}->{IdentProvider}->{arg}, @@ -131,18 +183,18 @@ ] }; -print Dumper($query); - - my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query); - - my $entry = $result->getNextEntry(); + # send query and fetch first entry from result + my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query); + my $entry = $result->getNextEntry(); + + # trace + #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); -#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(); + # be informed about the status of the query + my $status = $result->getStatus(); #print Dumper($status); @@ -183,4 +235,349 @@ } +sub _touchNodeSet { + my $self = shift; + + $logger->debug( __PACKAGE__ . "->touchNodeSet" ); + + # check descents/nodes: does descent exist / is node available? + foreach my $descent (keys %{$self->{meta}}) { + + # 1. check metadata of descent(s) + if (!$self->{meta}->{$descent}) { + $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not find descent '$descent' in configuration metadata." ); + next; + } + + # 2. check storage handle(s) + my $dbkey = $self->{meta}->{$descent}->{dbKey}; + if (!$self->{meta}->{$descent}->{storage}) { + $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not access storage ( descent='$descent', dbKey='$dbkey' ) - configuration-error?" ); + next; + } + + # 2.b check storage handle type + my $dbType = $self->{meta}->{$descent}->{storage}->{locator}->{type}; + if (!$dbType) { + $logger->critical( __PACKAGE__ . "->touchNodeSet: Storage ( descent='$descent', dbKey='$dbkey' ) has no 'dbType' - configuration-error?" ); + next; + } + + # 3. check if descents (and nodes?) are actually available.... + # TODO: + # eventually pre-check mode of access-attempt (read/write) here to provide an "early-croak" if possible + + # trace + # print Dumper($self->{meta}->{$descent}->{storage}->{locator}); + + + my $nodeName = $self->{meta}->{$descent}->{nodeName}; + my $accessorType = $self->{meta}->{$descent}->{accessorType}; + my $accessorName = $self->{meta}->{$descent}->{accessorName}; + + + # 4. check nodeset + + # debug message containing database type and used/determined accessor name + $logger->debug( __PACKAGE__ . "->touchNodeSet: Accessing dbType=$dbType, accessorName=$accessorName" ); + + # if target node(s) do(es) not exist, check if we should create it automagically + if ($dbType ne 'DBI' && !$self->{meta}->{$descent}->{storage}->existsChildNode($accessorName)) { + + if ($descent eq 'target' && $self->{options}->{target}->{autocreateFolders}) { + if (!$self->{meta}->{$descent}->{storage}->createChildNode($accessorName)) { + $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not create node '$self->{meta}->{$descent}->{nodeName}\@$self->{meta}->{$descent}->{dbKey}' [$self->{meta}->{$descent}->{nodeType}]." ); + next; + } + } else { + $logger->critical( __PACKAGE__ . "->touchNodeSet: Could not reach node \"$nodeName\" (accessorName=$accessorName, accessorType=$accessorType) at descent \"$descent\"" ); + next; + } + } + + } + + # trace + #print Dumper($self->{meta}); + #exit; + + + return 1; + +} + + + +sub _modifyNode { + my $self = shift; + my $descent = shift; + my $action = shift; + my $map = shift; + my $crit = shift; + + # map for new style callbacks + my $map_callbacks = {}; + + # checks go first! + + # TODO: this should be reviewed first - before extending ;-) + # TODO: this should be extended: + # count this cases inside the caller to this sub and provide a better overall message + # if this counts still zero in the end: + # "No nodes have been touched for modify: Do you have column-headers in your csv file?" + if (not defined $self->{node}) { + #$logger->critical( __PACKAGE__ . "->_modifyNode failed: \"$descent\" node is empty." ); + #return; + } + + # transfer callback nodes from value map to callback map - handle them afterwards! - (new style callbacks) + if (my $callbacks = $self->{meta}->{$descent}->{Callback}) { + foreach my $callback (keys %{$callbacks->{write}}) { + $map_callbacks->{write}->{$callback} = $map->{$callback}; + delete $map->{$callback}; + } + } + + + # trace + #print Dumper($self->{meta}); + + + # -------------------------------------------------------------------------- + # DBI speaks SQL + if ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'DBI') { + + # trace + #print Dumper($map); + #delete $map->{cs}; + + # transfer data + # TODO: wrap this around '$storageHandle->sendQuery(...)'!? + my $sql_main; + if (lc($action) eq 'insert') { + $sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_INSERT'); + } elsif (lc $action eq 'update') { + $crit ||= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'"; + $sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_UPDATE', $crit); + } + my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main); + + # handle errors + if ($sqlHandle->err) { + #if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; } + $self->{node}->{status}->{error} = { + statement => $sql_main, + state => $sqlHandle->state, + err => $sqlHandle->err, + errstr => $sqlHandle->errstr, + }; + } else { + $self->{node}->{status}->{ok} = 1; + } + + + # -------------------------------------------------------------------------- + # Tangram does it the oo-way (naturally) + } elsif ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'Tangram') { + my $sql_main; + my $object; + + # determine classname + my $classname = $self->{meta}->{$descent}->{nodeType}; + + # attributes/properties to exclude + # push declared ones from metadata + my @exclude = @{$self->{meta}->{$descent}->{subnodes_exclude}}; + # push the attributes associated with the identifier + if (my $identProvider = $self->{meta}->{$descent}->{IdentProvider}) { + push @exclude, $identProvider->{arg}; + } + + # trace + #print Dumper($self->{meta}); + #exit; + + # new feature: + # - check TypeProvider metadata property from other side + # - use argument (arg) inside as a classname for object creation on this side + #my $otherSide = $self->_otherSide($descent); + if (my $typeProvider = $self->{meta}->{$descent}->{TypeProvider}) { + #print Dumper($map); + $classname = $map->{$typeProvider->{arg}}; + # remove nodes from map also (push nodes to "subnodes_exclude" list) + push @exclude, $typeProvider->{arg}; + } + + # exclude banned properties (remove from map) + #map { delete $self->{node}->{map}->{$_} } @{$self->{args}->{exclude}}; + map { delete $map->{$_} } @exclude; + + # list of properties + my @props = keys %{$map}; + + # transfer data + if (lc $action eq 'insert') { + + # make the object persistent in four steps: + # - raw create (perl / class tangram scope) + # - orm insert (tangram scope) ... this establishes inheritance - don't try to fill in inherited properties before! + # is this a Tangram bug? + # - raw fill-in from hash (perl scope) + # - orm update (tangram scope) ... this updates all properties just filled in + + + # ========================== + # TODO: REVIEW HERE!!! + # can't we achieve this more elegant? + # o use DesignPattern::Object??? + # o use Hash::Merge!!! (take care about the cloning behaviour) + + # check if object exists (is classname a valid perl package/module?) + + # we can just check if the classname is valid here + if (!$classname) { + $logger->critical( __PACKAGE__ . "->_modifyNode: classname is undefined" ); + # FIXME: stop syncing here? + return; + } + + # try to match against the classes known by Class::Tangram + # FIXME: do "/i" on win32 only! + my $classname_find = quotemeta($classname); + if (!grep(m/$classname_find/i, Class::Tangram::known_classes())) { + $logger->critical( __PACKAGE__ . "->_modifyNode: Classname '$classname' is not known by Class::Tangram" ); + # FIXME: stop syncing here? + return; + } + + # create new object ... + # V1 + # build array to initialize object + #my @initarray = (); + #map { push @initarray, $_, undef; } @props; + #my $object = $classname->new( @initarray ); + # V2 + $object = $classname->new(); + # V3 + # $object = DesignPattern::Object->new($data); + + # ... pass to orm first ... + $self->{meta}->{$descent}->{storage}->insert($object); + + # ... and initialize with empty (undef'd) properties afterwards. + map { $object->{$_} = undef; } @props; + + # trace + #print "\n"; + #print Dumper($map); + #print Dumper($object); + #exit; + + # mix in (merge) values ... + # TODO: use Hash::Merge here? benchmark! + # no! we'd need a Object::Merge here! it's *...2object* + merge_to($object, $map); + + # trace + #print Dumper($object); + #exit; + + # TODO: REVIEW HERE!!! + # ========================== + + # ... and re-update@orm. + $self->{meta}->{$descent}->{storage}->update($object); + + # asymmetry: get ident after insert + # TODO: + # - just do this if it is an IdentAuthority + # - use IdentProvider metadata here +#print Dumper($self->{meta}->{$descent}); + my $oid = $self->{meta}->{$descent}->{storage}->id($object); +#print "oid: $oid", "\n"; + $self->{node}->{$descent}->{ident} = $oid; + + + } elsif (lc $action eq 'update') { + + # Get fresh object from orm first. + # TODO: Review, is a 'sendQuery' required in this place? + # By now: NO! It's more expensive and we can just expect existing objects for update operations. + # If it doesn't exist either, we assume the engine will fail on issuing the 'update' operation later... + $object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident}); + + # mix in values + merge_to($object, $map); + + # update orm + $self->{meta}->{$descent}->{storage}->update($object); + + } + + my $error = 0; + + # handle new style callbacks - this is a HACK - do this without an eval! + #print Dumper($map); + #print "cb: ", Dumper($self->{meta}->{$descent}->{Callback}); + #print Dumper($map_callbacks); + foreach my $node (keys %{$map_callbacks->{write}}) { + #print Dumper($node); + + # ------------ half-redundant: make $self->callCallback($object, $value, $opts) + my $perl_callback = $self->{meta}->{$descent}->{nodeType} . '::' . $node . '_write'; + my $evalstring = $perl_callback . '( { object => $object, value => $map_callbacks->{write}->{$node}, storage => $self->{meta}->{$descent}->{storage} } );'; + #print $evalstring, "\n"; exit; + eval($evalstring); + if ($@) { + $error = 1; + $logger->error( __PACKAGE__ . "->_modifyNode: $@" ); + next; + } + # ------------ half-redundant: make $self->callCallback($object, $value, $opts) + + #print "after eval", "\n"; + + if (!$error) { + # re-update@orm + $self->{meta}->{$descent}->{storage}->update($object); + } + } + + # handle errors + if ($error) { + #print "error", "\n"; +=pod + my $sqlHandle; + #if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; } + $self->{node}->{status}->{error} = { + statement => $sql_main, + state => $sqlHandle->state, + err => $sqlHandle->err, + errstr => $sqlHandle->errstr, + }; +=cut + # rollback.... + #print "rollback", "\n"; + $self->{meta}->{$descent}->{storage}->erase($object); + #print "after rollback", "\n"; + } else { + $self->{node}->{status}->{ok} = 1; + } + + } + +} + +sub _erase_all { + my $self = shift; + my $descent = shift; + #my $node = shift; + #print Dumper($self->{meta}->{$descent}); + #my $node = $self->{meta}->{$descent}->{nodeName}; + my $node = $self->{meta}->{$descent}->{accessorName}; + $logger->debug( __PACKAGE__ . "->_erase_all( node $node )" ); + $self->{meta}->{$descent}->{storage}->eraseAll($node); +} + 1; +__END__