Transfer/Sync/StorageInterface.pm

##    $Id: StorageInterface.pm,v 1.8 2003/04/09 07:27:02 joko Exp $
##
##    Copyright (c) 2002  Andreas Motl <andreas.motl@ilo.de>
##
##    See COPYRIGHT section in pod text below for usage and distribution rights.
##
##    ----------------------------------------------------------------------------------------
##    $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....
##
##    Revision 1.1  2003/01/19 01:23:04  joko
##    + new from Data/Transfer/Sync.pm
##
##    ----------------------------------------------------------------------------------------


package Data::Transfer::Sync::StorageInterface;

use strict;
use warnings;

use mixin::with qw( Data::Transfer::Sync );


# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -   main

use Data::Dumper;
use Hash::Merge qw( merge );
use shortcuts::database 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}->{accessorName}, $filter);
#print Dumper($list);
  return $list;
}

sub _resolveNodeIdent {
  my $self = shift;
  my $descent = shift;
  
  # 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};
    my $payload = $self->{node}->{$descent}->{payload};

  # resolve method to get to the id of the given item
  # we use global metadata and the given descent for this task
    #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};

    # 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') {
      $ident = $payload->{$provider_arg};

    } elsif (lc $provider_method eq 'storage_method') {
      #$ident = $self->{meta}->{$descent}->{storage}->id($item);
      $ident = $self->{meta}->{$descent}->{storage}->$provider_arg($payload);

    } elsif (lc $provider_method eq 'code') {
      $ident = 'ac';
      
    }
    
    $self->{node}->{$descent}->{ident} = $ident;
    
  return 1 if $ident;

}

# TODO:
# this should be split up into...
#   - a "_statNode" (should just touch the node to check for existance)
#   - a "_loadNode" (should load node completely)
#   - maybe additionally a "loadNodeProperty" (may specify properties to load)
#   - introduce $self->{nodecache} for this purpose
# TODO:
#   should we:
#     - not pass ident in here but resolve it via "$descent"?
#     - refactor this and stuff it with additional debug/error message
#       - this = the way the implicit load mechanism works
sub _statloadNode {

  my $self = shift;
  my $descent = shift;
  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) {
  # is:
  #if (!$self->{node}->{$descent}->{item} || $force) {
    
    if (!$ident) {
      #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";
      return;
    }
    
    # patch for DBD::CSV
    if ($ident && $ident eq 'Null') {
      return;
    }

    #print Dumper($self->{meta});

    my $query = { 
      node => $self->{meta}->{$descent}->{accessorName}, 
      subnodes => [qw( cs )], 
      criterias => [ 
        { key => $self->{meta}->{$descent}->{IdentProvider}->{arg}, 
           op => 'eq', 
           val => $ident },
      ]
    };

    # 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);

    # be informed about the status of the query
      my $status = $result->getStatus();

#print Dumper($status);
    
    # TODO: enhance error handling (store inside tc)
    #if (!$row) {
    #  print "\n", "row error", "\n";
    #  next;
    #}

    # these checks run before actually loading payload- and meta-data to node-container
    
      # 1st level - hard error
      if ($status && $status->{err}) {
        $logger->debug( __PACKAGE__ . "->_statloadNode (ident=\"$ident\") failed - hard error (that's ok): $status->{err}" );
        return;
      }
  
      # 2nd level - logical (empty/notfound) error
      if (($status && $status->{empty}) || !$entry) {
        $logger->debug( __PACKAGE__ . "->_statloadNode (ident=\"$ident\") failed - logical error (that's ok)" );
        #print "no entry (logical)", "\n";
        return;
      }

#print Dumper($entry);

    # was:
    # $self->{node}->{$descent}->{ident} = $ident;  
    # is:
    # TODO: re-resolve ident from entry via metadata "IdentProvider" here - like elsewhere
    $self->{node}->{$descent}->{ident} = $ident;
    $self->{node}->{$descent}->{payload} = $entry;

  }
  
  return 1;
  
}


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__
1	joko	1.9	## $Id: StorageInterface.pm,v 1.8 2003/04/09 07:27:02 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: StorageInterface.pm,v $
9	joko	1.9	## Revision 1.8 2003/04/09 07:27:02 joko
10			## minor update (just cosmetics)
11			##
12	joko	1.8	## Revision 1.7 2003/03/27 15:31:16 joko
13			## fixes to modules regarding new namespace(s) below Data::Mungle::*
14			##
15	joko	1.7	## Revision 1.6 2003/02/21 01:47:53 joko
16			## renamed core function
17			##
18	joko	1.6	## Revision 1.5 2003/02/20 20:24:33 joko
19			## + additional pre-flight checks
20			##
21	joko	1.5	## Revision 1.4 2003/02/14 14:14:38 joko
22			## + new code refactored here
23			##
24	joko	1.4	## Revision 1.3 2003/02/11 07:54:55 joko
25			## + modified module usage
26			## + debugging trials
27			##
28	joko	1.3	## Revision 1.2 2003/02/09 05:05:58 joko
29			## + major structure changes
30			## - refactored code to sister modules
31			## + refactored code to this place
32			##
33	joko	1.2	## Revision 1.1 2003/01/20 16:58:46 joko
34			## + initial check-in: here they are....
35			##
36	joko	1.1	## Revision 1.1 2003/01/19 01:23:04 joko
37			## + new from Data/Transfer/Sync.pm
38			##
39			## ----------------------------------------------------------------------------------------
40
41
42			package Data::Transfer::Sync::StorageInterface;
43
44			use strict;
45			use warnings;
46
47			use mixin::with qw( Data::Transfer::Sync );
48
49
50			# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - main
51
52	joko	1.2	use Data::Dumper;
53			use Hash::Merge qw( merge );
54	joko	1.9	use shortcuts::database qw( hash2sql );
55	joko	1.7	use Data::Mungle::Transform::Deep qw( merge_to );
56	joko	1.2
57
58	joko	1.1	# get logger instance
59			my $logger = Log::Dispatch::Config->instance;
60
61			# this is a shortcut method
62			# ... let's try to avoid _any_ redundant code in here (ok... - at the cost of method lookups...)
63			sub _getNodeList {
64			my $self = shift;
65			my $descent = shift;
66			my $filter = shift;
67	joko	1.2	$logger->debug( __PACKAGE__ . "->_getNodeList( descent=$descent, accessorName=$self->{meta}->{$descent}->{accessorName} )" );
68	joko	1.1	#$results \|\|= $self->{source}->getListUnfiltered($self->{meta}->{source}->{node});
69			#$results \|\|= $self->{meta}->{source}->{storage}->getListUnfiltered($self->{meta}->{source}->{node});
70	joko	1.2	my $list = $self->{meta}->{$descent}->{storage}->getListFiltered($self->{meta}->{$descent}->{accessorName}, $filter);
71	joko	1.1	#print Dumper($list);
72			return $list;
73			}
74
75			sub _resolveNodeIdent {
76			my $self = shift;
77			my $descent = shift;
78
79	joko	1.3	# trace
80			#print Dumper($self->{node}->{$descent});
81			#print Dumper($self);
82			#exit;
83
84	joko	1.2	$logger->debug( __PACKAGE__ . "->_resolveNodeIdent( descent=$descent, accessorName=$self->{meta}->{$descent}->{accessorName} )" );
85	joko	1.1
86			# get to the payload
87			#my $item = $specifier->{item};
88			my $payload = $self->{node}->{$descent}->{payload};
89
90			# resolve method to get to the id of the given item
91			# we use global metadata and the given descent for this task
92			#my $ident = $self->{$descent}->id($item);
93			#my $ident = $self->{meta}->{$descent}->{storage}->id($item);
94
95	joko	1.3	# trace
96			#print Dumper($self->{meta}->{$descent});
97			#exit;
98
99	joko	1.1	my $ident;
100			my $provider_method = $self->{meta}->{$descent}->{IdentProvider}->{method};
101			my $provider_arg = $self->{meta}->{$descent}->{IdentProvider}->{arg};
102
103	joko	1.2	# trace
104			#print "provider_method: $provider_method", "\n";
105			#print "provider_arg: $provider_arg", "\n";
106			#print Dumper($payload);
107	joko	1.1
108			# resolve to ident
109			if (lc $provider_method eq 'property') {
110			$ident = $payload->{$provider_arg};
111
112			} elsif (lc $provider_method eq 'storage_method') {
113			#$ident = $self->{meta}->{$descent}->{storage}->id($item);
114			$ident = $self->{meta}->{$descent}->{storage}->$provider_arg($payload);
115
116			} elsif (lc $provider_method eq 'code') {
117			$ident = 'ac';
118
119			}
120
121			$self->{node}->{$descent}->{ident} = $ident;
122
123			return 1 if $ident;
124
125			}
126
127			# TODO:
128			# this should be split up into...
129			# - a "_statNode" (should just touch the node to check for existance)
130			# - a "_loadNode" (should load node completely)
131			# - maybe additionally a "loadNodeProperty" (may specify properties to load)
132			# - introduce $self->{nodecache} for this purpose
133			# TODO:
134			# should we:
135			# - not pass ident in here but resolve it via "$descent"?
136			# - refactor this and stuff it with additional debug/error message
137			# - this = the way the implicit load mechanism works
138			sub _statloadNode {
139
140			my $self = shift;
141			my $descent = shift;
142			my $ident = shift;
143			my $force = shift;
144
145	joko	1.5	=pod
146			#print "isa: ", UNIVERSAL::isa($self->{meta}->{$descent}->{storage}), "\n";
147
148			# this seems to be the first time we access this side,
149			# so just check (again) for a valid storage handle
150			if (! ref $self->{meta}->{$descent}->{storage}) {
151			$logger->critical( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident ): Storage handle undefined!" );
152			return;
153			}
154			=cut
155
156	joko	1.3	#$logger->debug( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident )" );
157	joko	1.2
158	joko	1.1	# fetch entry to retrieve checksum from
159			# was:
160			if (!$self->{node}->{$descent} \|\| $force) {
161			# is:
162			#if (!$self->{node}->{$descent}->{item} \|\| $force) {
163
164			if (!$ident) {
165			#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";
166			return;
167			}
168
169			# patch for DBD::CSV
170			if ($ident && $ident eq 'Null') {
171			return;
172			}
173
174	joko	1.2	#print Dumper($self->{meta});
175	joko	1.1
176			my $query = {
177	joko	1.2	node => $self->{meta}->{$descent}->{accessorName},
178	joko	1.1	subnodes => [qw( cs )],
179			criterias => [
180			{ key => $self->{meta}->{$descent}->{IdentProvider}->{arg},
181			op => 'eq',
182			val => $ident },
183			]
184			};
185
186	joko	1.2	# send query and fetch first entry from result
187			my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query);
188			my $entry = $result->getNextEntry();
189
190			# trace
191			#print Dumper($entry);
192			#print "pers: " . $self->{meta}->{$descent}->{storage}->is_persistent($entry), "\n";
193			#my $state = $self->{meta}->{$descent}->{storage}->_fetch_object_state($entry, { name => 'TransactionHop' } );
194			#print Dumper($state);
195	joko	1.1
196	joko	1.2	# be informed about the status of the query
197			my $status = $result->getStatus();
198	joko	1.1
199			#print Dumper($status);
200
201			# TODO: enhance error handling (store inside tc)
202			#if (!$row) {
203			# print "\n", "row error", "\n";
204			# next;
205			#}
206
207			# these checks run before actually loading payload- and meta-data to node-container
208
209			# 1st level - hard error
210			if ($status && $status->{err}) {
211			$logger->debug( __PACKAGE__ . "->_statloadNode (ident=\"$ident\") failed - hard error (that's ok): $status->{err}" );
212			return;
213			}
214
215			# 2nd level - logical (empty/notfound) error
216			if (($status && $status->{empty}) \|\| !$entry) {
217			$logger->debug( __PACKAGE__ . "->_statloadNode (ident=\"$ident\") failed - logical error (that's ok)" );
218			#print "no entry (logical)", "\n";
219			return;
220			}
221
222			#print Dumper($entry);
223
224			# was:
225			# $self->{node}->{$descent}->{ident} = $ident;
226			# is:
227			# TODO: re-resolve ident from entry via metadata "IdentProvider" here - like elsewhere
228			$self->{node}->{$descent}->{ident} = $ident;
229			$self->{node}->{$descent}->{payload} = $entry;
230
231			}
232
233			return 1;
234
235	joko	1.2	}
236
237
238			sub _touchNodeSet {
239			my $self = shift;
240
241			$logger->debug( __PACKAGE__ . "->touchNodeSet" );
242
243			# check descents/nodes: does descent exist / is node available?
244			foreach my $descent (keys %{$self->{meta}}) {
245
246			# 1. check metadata of descent(s)
247			if (!$self->{meta}->{$descent}) {
248			$logger->critical( __PACKAGE__ . "->touchNodeSet: Could not find descent '$descent' in configuration metadata." );
249			next;
250			}
251
252			# 2. check storage handle(s)
253			my $dbkey = $self->{meta}->{$descent}->{dbKey};
254			if (!$self->{meta}->{$descent}->{storage}) {
255			$logger->critical( __PACKAGE__ . "->touchNodeSet: Could not access storage ( descent='$descent', dbKey='$dbkey' ) - configuration-error?" );
256			next;
257			}
258
259	joko	1.5	# 2.b check storage handle type
260			my $dbType = $self->{meta}->{$descent}->{storage}->{locator}->{type};
261			if (!$dbType) {
262			$logger->critical( __PACKAGE__ . "->touchNodeSet: Storage ( descent='$descent', dbKey='$dbkey' ) has no 'dbType' - configuration-error?" );
263			next;
264			}
265
266	joko	1.2	# 3. check if descents (and nodes?) are actually available....
267			# TODO:
268			# eventually pre-check mode of access-attempt (read/write) here to provide an "early-croak" if possible
269
270			# trace
271			# print Dumper($self->{meta}->{$descent}->{storage}->{locator});
272
273
274			my $nodeName = $self->{meta}->{$descent}->{nodeName};
275			my $accessorType = $self->{meta}->{$descent}->{accessorType};
276			my $accessorName = $self->{meta}->{$descent}->{accessorName};
277
278
279			# 4. check nodeset
280
281			# debug message containing database type and used/determined accessor name
282			$logger->debug( __PACKAGE__ . "->touchNodeSet: Accessing dbType=$dbType, accessorName=$accessorName" );
283
284			# if target node(s) do(es) not exist, check if we should create it automagically
285			if ($dbType ne 'DBI' && !$self->{meta}->{$descent}->{storage}->existsChildNode($accessorName)) {
286
287			if ($descent eq 'target' && $self->{options}->{target}->{autocreateFolders}) {
288			if (!$self->{meta}->{$descent}->{storage}->createChildNode($accessorName)) {
289			$logger->critical( __PACKAGE__ . "->touchNodeSet: Could not create node '$self->{meta}->{$descent}->{nodeName}\@$self->{meta}->{$descent}->{dbKey}' [$self->{meta}->{$descent}->{nodeType}]." );
290			next;
291			}
292			} else {
293			$logger->critical( __PACKAGE__ . "->touchNodeSet: Could not reach node \"$nodeName\" (accessorName=$accessorName, accessorType=$accessorType) at descent \"$descent\"" );
294			next;
295			}
296			}
297
298			}
299
300			# trace
301			#print Dumper($self->{meta});
302			#exit;
303
304
305			return 1;
306
307			}
308
309
310
311			sub _modifyNode {
312			my $self = shift;
313			my $descent = shift;
314			my $action = shift;
315			my $map = shift;
316			my $crit = shift;
317
318			# map for new style callbacks
319			my $map_callbacks = {};
320
321			# checks go first!
322
323			# TODO: this should be reviewed first - before extending ;-)
324			# TODO: this should be extended:
325			# count this cases inside the caller to this sub and provide a better overall message
326			# if this counts still zero in the end:
327			# "No nodes have been touched for modify: Do you have column-headers in your csv file?"
328			if (not defined $self->{node}) {
329			#$logger->critical( __PACKAGE__ . "->_modifyNode failed: \"$descent\" node is empty." );
330			#return;
331			}
332
333			# transfer callback nodes from value map to callback map - handle them afterwards! - (new style callbacks)
334			if (my $callbacks = $self->{meta}->{$descent}->{Callback}) {
335			foreach my $callback (keys %{$callbacks->{write}}) {
336			$map_callbacks->{write}->{$callback} = $map->{$callback};
337			delete $map->{$callback};
338			}
339			}
340
341
342			# trace
343			#print Dumper($self->{meta});
344
345
346			# --------------------------------------------------------------------------
347			# DBI speaks SQL
348			if ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'DBI') {
349
350			# trace
351			#print Dumper($map);
352			#delete $map->{cs};
353
354			# transfer data
355			# TODO: wrap this around '$storageHandle->sendQuery(...)'!?
356			my $sql_main;
357			if (lc($action) eq 'insert') {
358	joko	1.8	$sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_INSERT');
359	joko	1.2	} elsif (lc $action eq 'update') {
360			$crit \|\|= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'";
361	joko	1.8	$sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_UPDATE', $crit);
362	joko	1.2	}
363			my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main);
364
365			# handle errors
366			if ($sqlHandle->err) {
367			#if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; }
368			$self->{node}->{status}->{error} = {
369			statement => $sql_main,
370			state => $sqlHandle->state,
371			err => $sqlHandle->err,
372			errstr => $sqlHandle->errstr,
373			};
374			} else {
375			$self->{node}->{status}->{ok} = 1;
376			}
377
378
379			# --------------------------------------------------------------------------
380			# Tangram does it the oo-way (naturally)
381			} elsif ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'Tangram') {
382			my $sql_main;
383			my $object;
384
385			# determine classname
386			my $classname = $self->{meta}->{$descent}->{nodeType};
387
388			# attributes/properties to exclude
389			# push declared ones from metadata
390			my @exclude = @{$self->{meta}->{$descent}->{subnodes_exclude}};
391			# push the attributes associated with the identifier
392			if (my $identProvider = $self->{meta}->{$descent}->{IdentProvider}) {
393			push @exclude, $identProvider->{arg};
394			}
395
396			# trace
397			#print Dumper($self->{meta});
398			#exit;
399
400			# new feature:
401			# - check TypeProvider metadata property from other side
402			# - use argument (arg) inside as a classname for object creation on this side
403			#my $otherSide = $self->_otherSide($descent);
404			if (my $typeProvider = $self->{meta}->{$descent}->{TypeProvider}) {
405			#print Dumper($map);
406			$classname = $map->{$typeProvider->{arg}};
407			# remove nodes from map also (push nodes to "subnodes_exclude" list)
408			push @exclude, $typeProvider->{arg};
409			}
410
411			# exclude banned properties (remove from map)
412			#map { delete $self->{node}->{map}->{$_} } @{$self->{args}->{exclude}};
413			map { delete $map->{$_} } @exclude;
414
415			# list of properties
416			my @props = keys %{$map};
417
418			# transfer data
419			if (lc $action eq 'insert') {
420
421			# make the object persistent in four steps:
422			# - raw create (perl / class tangram scope)
423			# - orm insert (tangram scope) ... this establishes inheritance - don't try to fill in inherited properties before!
424			# is this a Tangram bug?
425			# - raw fill-in from hash (perl scope)
426			# - orm update (tangram scope) ... this updates all properties just filled in
427
428
429			# ==========================
430			# TODO: REVIEW HERE!!!
431			# can't we achieve this more elegant?
432			# o use DesignPattern::Object???
433			# o use Hash::Merge!!! (take care about the cloning behaviour)
434
435			# check if object exists (is classname a valid perl package/module?)
436
437			# we can just check if the classname is valid here
438			if (!$classname) {
439			$logger->critical( __PACKAGE__ . "->_modifyNode: classname is undefined" );
440			# FIXME: stop syncing here?
441			return;
442			}
443
444			# try to match against the classes known by Class::Tangram
445			# FIXME: do "/i" on win32 only!
446			my $classname_find = quotemeta($classname);
447			if (!grep(m/$classname_find/i, Class::Tangram::known_classes())) {
448			$logger->critical( __PACKAGE__ . "->_modifyNode: Classname '$classname' is not known by Class::Tangram" );
449			# FIXME: stop syncing here?
450			return;
451			}
452
453			# create new object ...
454			# V1
455			# build array to initialize object
456			#my @initarray = ();
457			#map { push @initarray, $_, undef; } @props;
458			#my $object = $classname->new( @initarray );
459			# V2
460			$object = $classname->new();
461			# V3
462			# $object = DesignPattern::Object->new($data);
463
464			# ... pass to orm first ...
465			$self->{meta}->{$descent}->{storage}->insert($object);
466
467			# ... and initialize with empty (undef'd) properties afterwards.
468			map { $object->{$_} = undef; } @props;
469
470			# trace
471			#print "\n";
472			#print Dumper($map);
473			#print Dumper($object);
474			#exit;
475
476			# mix in (merge) values ...
477			# TODO: use Hash::Merge here? benchmark!
478			# no! we'd need a Object::Merge here! it's ...2object
479	joko	1.6	merge_to($object, $map);
480	joko	1.2
481			# trace
482			#print Dumper($object);
483			#exit;
484
485			# TODO: REVIEW HERE!!!
486			# ==========================
487
488			# ... and re-update@orm.
489			$self->{meta}->{$descent}->{storage}->update($object);
490
491			# asymmetry: get ident after insert
492			# TODO:
493			# - just do this if it is an IdentAuthority
494			# - use IdentProvider metadata here
495			#print Dumper($self->{meta}->{$descent});
496			my $oid = $self->{meta}->{$descent}->{storage}->id($object);
497			#print "oid: $oid", "\n";
498			$self->{node}->{$descent}->{ident} = $oid;
499
500
501			} elsif (lc $action eq 'update') {
502
503	joko	1.8	# Get fresh object from orm first.
504			# TODO: Review, is a 'sendQuery' required in this place?
505			# By now: NO! It's more expensive and we can just expect existing objects for update operations.
506			# If it doesn't exist either, we assume the engine will fail on issuing the 'update' operation later...
507	joko	1.2	$object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident});
508
509			# mix in values
510	joko	1.8	merge_to($object, $map);
511	joko	1.2
512			# update orm
513	joko	1.8	$self->{meta}->{$descent}->{storage}->update($object);
514	joko	1.2
515			}
516
517			my $error = 0;
518
519			# handle new style callbacks - this is a HACK - do this without an eval!
520			#print Dumper($map);
521			#print "cb: ", Dumper($self->{meta}->{$descent}->{Callback});
522			#print Dumper($map_callbacks);
523			foreach my $node (keys %{$map_callbacks->{write}}) {
524			#print Dumper($node);
525	joko	1.4
526			# ------------ half-redundant: make $self->callCallback($object, $value, $opts)
527			my $perl_callback = $self->{meta}->{$descent}->{nodeType} . '::' . $node . '_write';
528	joko	1.2	my $evalstring = $perl_callback . '( { object => $object, value => $map_callbacks->{write}->{$node}, storage => $self->{meta}->{$descent}->{storage} } );';
529			#print $evalstring, "\n"; exit;
530			eval($evalstring);
531			if ($@) {
532			$error = 1;
533	joko	1.4	$logger->error( __PACKAGE__ . "->_modifyNode: $@" );
534			next;
535	joko	1.2	}
536	joko	1.4	# ------------ half-redundant: make $self->callCallback($object, $value, $opts)
537	joko	1.2
538			#print "after eval", "\n";
539
540			if (!$error) {
541			# re-update@orm
542			$self->{meta}->{$descent}->{storage}->update($object);
543			}
544			}
545
546			# handle errors
547			if ($error) {
548			#print "error", "\n";
549			=pod
550			my $sqlHandle;
551			#if ($self->{args}->{debug}) { print "sql-error with statement: $sql_main", "\n"; }
552			$self->{node}->{status}->{error} = {
553			statement => $sql_main,
554			state => $sqlHandle->state,
555			err => $sqlHandle->err,
556			errstr => $sqlHandle->errstr,
557			};
558			=cut
559			# rollback....
560			#print "rollback", "\n";
561			$self->{meta}->{$descent}->{storage}->erase($object);
562			#print "after rollback", "\n";
563			} else {
564			$self->{node}->{status}->{ok} = 1;
565			}
566
567			}
568
569	joko	1.1	}
570
571	joko	1.4	sub _erase_all {
572			my $self = shift;
573			my $descent = shift;
574			#my $node = shift;
575			#print Dumper($self->{meta}->{$descent});
576			#my $node = $self->{meta}->{$descent}->{nodeName};
577			my $node = $self->{meta}->{$descent}->{accessorName};
578			$logger->debug( __PACKAGE__ . "->_erase_all( node $node )" );
579			$self->{meta}->{$descent}->{storage}->eraseAll($node);
580			}
581	joko	1.1
582			1;
583	joko	1.4	__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26