Transfer/Sync/Core.pm

##    $Id: Core.pm,v 1.2 2003/01/19 02:05:42 joko Exp $
##
##    Copyright (c) 2002  Andreas Motl <andreas.motl@ilo.de>
##
##    See COPYRIGHT section in pod text below for usage and distribution rights.
##
##    ----------------------------------------------------------------------------------------
##    $Log: Core.pm,v $
##    Revision 1.2  2003/01/19 02:05:42  joko
##    - removed pod-documentation: now in Data/Transfer/Sync.pod
##
##    Revision 1.1  2003/01/19 01:23:04  joko
##    + new from Data/Transfer/Sync.pm
##
##    Revision 1.11  2002/12/23 07:10:59  joko
##    + using MD5 for checksum generation again - the 32-bit integer hash from DBI seems to be too lazy
##
##    Revision 1.10  2002/12/19 01:07:16  joko
##    + fixed output done via $logger
##
##    Revision 1.9  2002/12/16 07:02:34  jonen
##    + added comment
##
##    Revision 1.8  2002/12/15 02:03:09  joko
##    + fixed logging-messages
##    + additional metadata-checks
##
##    Revision 1.7  2002/12/13 21:49:34  joko
##    + sub configure
##    + sub checkOptions
##
##    Revision 1.6  2002/12/06 04:49:10  jonen
##    + disabled output-puffer here
##
##    Revision 1.5  2002/12/05 08:06:05  joko
##    + bugfix with determining empty fields (Null) with DBD::CSV
##    + debugging
##    + updated comments
##
##    Revision 1.4  2002/12/03 15:54:07  joko
##    + {import}-flag is now {prepare}-flag
##
##    Revision 1.3  2002/12/01 22:26:59  joko
##    + minor cosmetics for logging
##
##    Revision 1.2  2002/12/01 04:43:25  joko
##    + mapping deatil entries may now be either an ARRAY or a HASH
##    + erase flag is used now (for export-operations)
##    + expressions to refer to values inside deep nested structures
##    - removed old mappingV2-code
##    + cosmetics
##    + sub _erase_all
##
##    Revision 1.1  2002/11/29 04:45:50  joko
##    + initial check in
##
##    Revision 1.1  2002/10/10 03:44:21  cvsjoko
##    + new
##    ----------------------------------------------------------------------------------------


package Data::Transfer::Sync::Core;

use strict;
use warnings;

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


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

use Data::Dumper;

use misc::HashExt;
use libp qw( md5_base64 );
use libdb qw( quotesql hash2Sql );
use Data::Transform::Deep qw( hash2object refexpr2perlref );
use Data::Compare::Struct qw( getDifference isEmpty );
use Data::Storage::Container;
use DesignPattern::Object;

# get logger instance
my $logger = Log::Dispatch::Config->instance;

$| = 1;

=pod
sub new {
  my $invocant = shift;
  my $class = ref($invocant) || $invocant;
  my $self = {};
  $logger->debug( __PACKAGE__ . "->new(@_)" );
  bless $self, $class;
  $self->configure(@_);
  return $self;
}
=cut


sub _init {
  my $self = shift;

  # build new container if necessary
  $self->{container} = Data::Storage::Container->new() if !$self->{container};
  
  # add storages to container (optional)
  foreach (keys %{$self->{storages}}) {
    $self->{container}->addStorage($_, $self->{storages}->{$_});
  }
  
  return 1;
  
}

sub _initV1 {
  my $self = shift;
  # tag storages with id-authority and checksum-provider information
  # TODO: better store tag inside metadata to hold bits together!
  map { $self->{container}->{storage}->{$_}->{isIdentAuthority} = 1 } @{$self->{id_authorities}};
  map { $self->{container}->{storage}->{$_}->{isChecksumAuthority} = 1; } @{$self->{checksum_authorities}};
  map { $self->{container}->{storage}->{$_}->{isWriteProtected} = 1; } @{$self->{write_protected}};
}


# TODO: abstract the hardwired use of "source" and "target" in here somehow - hmmmm.......  /(="§/%???
sub _syncNodes {

  my $self = shift;
  
  my $tc = OneLineDumpHash->new( {} );
  my $results;
  
  # set of objects is already in $self->{args}
  # TODO: make independent of the terminology "object..."
  $results = $self->{args}->{objectSet} if $self->{args}->{objectSet};

  # apply filter
  if (my $filter = $self->{meta}->{source}->{filter}) {
    #print Dumper($filter);
    #exit;
    $results ||= $self->_getNodeList('source', $filter);
  }
  
  # get reference to node list from convenient method provided by CORE-HANDLE
  $results ||= $self->_getNodeList('source');

  # checkpoint: do we actually have a list to iterate through?
  if (!$results || !@{$results}) {
    $logger->notice( __PACKAGE__ . "->syncNodes: No nodes to synchronize." );
    return;
  }
  
  # dereference
  my @results = @{$results};

  # iterate through set
  foreach my $source_node_real (@results) {

    $tc->{total}++;

#print "========================  iter", "\n";

    # clone object (in case we have to modify it here)
    # TODO:
    #   - is a "deep_copy" needed here if occouring modifications take place?
    #   - puuhhhh, i guess a deep_copy would destroy tangram mechanisms?
    #   - after all, just take care for now that this object doesn't get updated!
    my $source_node = $source_node_real;

    # modify entry - handle new style callbacks (the readers)
#print Dumper($source_node);
#exit;

    my $descent = 'source';

    # handle callbacks right now while scanning them (asymmetric to the writers)
    my $map_callbacks = {};
    if (my $callbacks = $self->{meta}->{$descent}->{Callback}) {

      my $error = 0;

      foreach my $node (keys %{$callbacks->{read}}) {
        
        my $object = $source_node;
        my $value; # = $source_node->{$node};

        # ------------  half-redundant: make $self->callCallback($object, $value, $opts)
        #my $perl_callback = $self->{meta}->{$descent}->{node} . '::' . $node . '_read';
        my $perl_callback = $self->{meta}->{$descent}->{nodeType} . '::' . $node . '_read';
        my $evalstring = 'return ' . $perl_callback . '( { object => $object, property => $node, value => $value, storage => $self->{meta}->{$descent}->{storage} } );';
        #print $evalstring, "\n"; exit;
        my $cb_result = eval($evalstring);
        if ($@) {
          die $@;
          $error = 1;
          print $@, "\n";
        }
        # ------------  half-redundant: make $self->callCallback($object, $value, $opts)
        
        $source_node->{$node} = $cb_result;

      }

    }

#print Dumper($source_node);

    # exclude defined fields  (simply delete from object)
    map { delete $source_node->{$_} } @{$self->{meta}->{source}->{subnodes_exclude}};
    
    # here we accumulate information about the status of the current node (payload/row/object/item/entry)
    $self->{node} = {};
    $self->{node}->{source}->{payload} = $source_node;

#print "res - ident", "\n";

    # determine ident of entry
    my $identOK = $self->_resolveNodeIdent('source');
    #if (!$identOK && lc $self->{args}->{direction} ne 'import') {
    if (!$identOK) {
      #print Dumper($self->{meta}->{source});
      $logger->critical( __PACKAGE__ . "->syncNodes: No ident found in source node ( nodeName='$self->{meta}->{source}->{nodeName}', nodeType='$self->{meta}->{source}->{nodeType}') try to \"prepare\" this node first?" );
      return;
    }

    my $statOK = $self->_statloadNode('target', $self->{node}->{source}->{ident});

    # mark node as new either if there's no ident or if stat/load failed
    if (!$statOK) {
      $self->{node}->{status}->{new} = 1;
      print "n" if $self->{verbose};
    }

#print "checksum", "\n";
    
    # determine status of entry by synchronization method
    if ( (lc $self->{args}->{method} eq 'checksum') ) {
    #if ( $statOK && (lc $self->{args}->{method} eq 'checksum') ) {
    #if ( !$self->{node}->{status}->{new} && (lc $self->{args}->{method} eq 'checksum') ) {
      
      # TODO:
      # is this really worth a "critical"???
      # no - it should just be a debug appendix i believe

#print "readcs", "\n";
      
      # calculate checksum of source node
      #$self->_calcChecksum('source');
      if (!$self->_readChecksum('source')) {
        $logger->critical( __PACKAGE__ . "->_readChecksum: Could not find \"source\" entry with ident=\"$self->{node}->{source}->{ident}\"" );
        $tc->{skip}++;
        print "s" if $self->{verbose};
        next;
      }
      
      # get checksum from synchronization target
      $self->_readChecksum('target');
      #if (!$self->_readChecksum('target')) {
      #  $logger->critical( __PACKAGE__ . "->_readChecksum: Could not find \"target\" entry with ident=\"$self->{node}->{source}->{ident}\"" );
      #  next;
      #}
  
      # pre flight check: do we actually have a checksum provided?
      #if (!$self->{node}->{source}->{checksum}) {
      #  print "Source checksum for entry with ident \"$self->{node}->{source}->{ident}\" could not be calculated, maybe it's missing?.", "\n";
      #  return;
      #}
      
      # determine if entry is "new" or "dirty"
      # after all, this seems to be the point where the hammer falls.....
      print "c" if $self->{verbose};
      $self->{node}->{status}->{new} = !$self->{node}->{target}->{checksum};
      if (!$self->{node}->{status}->{new}) {
        $self->{node}->{status}->{dirty} = 
          $self->{node}->{status}->{new} || 
          (!$self->{node}->{source}->{checksum} || !$self->{node}->{target}->{checksum}) || 
          ($self->{node}->{source}->{checksum} ne $self->{node}->{target}->{checksum}) || 
          $self->{args}->{force};
      }

    }

    # first reaction on entry-status: continue with next entry if the current is already "in sync"
    if (!$self->{node}->{status}->{new} && !$self->{node}->{status}->{dirty}) {
      $tc->{in_sync}++;
      next;
    }

    # build map to actually transfer the data from source to target
    $self->_buildMap();


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

#print "attempt", "\n";

    # additional (new) checks for feature "write-protection"
    if ($self->{meta}->{target}->{storage}->{isWriteProtected}) {
      $tc->{attempt_transfer}++;
      print "\n" if $self->{verbose};
      $logger->notice( __PACKAGE__ . "->syncNodes: Target is write-protected. Will not insert or modify node. " .
          "(Ident: $self->{node}->{source}->{ident} " . "Dump:\n" . Dumper($self->{node}->{source}->{payload}) . ")" );
      print "\n" if $self->{verbose};
      $tc->{skip}++;
      next;
    }

    # transfer contents of map to target
    if ($self->{node}->{status}->{new}) {
      $tc->{attempt_new}++;
      $self->_doTransferToTarget('insert');
      # asymmetry: refetch node from target to re-calculate new ident and checksum (TODO: is IdentAuthority of relevance here?)
      #print Dumper($self->{node});
      $self->_statloadNode('target', $self->{node}->{target}->{ident}, 1);
      $self->_readChecksum('target');

    } elsif ($self->{node}->{status}->{dirty}) {
      $tc->{attempt_modify}++;
      # asymmetry: get ident before updating (TODO: is IdentAuthority of relevance here?)
      $self->{node}->{target}->{ident} = $self->{node}->{map}->{$self->{meta}->{target}->{IdentProvider}->{arg}};
      $self->_doTransferToTarget('update');
      $self->_readChecksum('target');
    }

    if ($self->{node}->{status}->{ok}) {
      $tc->{ok}++;
      print "t" if $self->{verbose};
    }
    
    if ($self->{node}->{status}->{error}) {
      $tc->{error}++;
      push( @{$tc->{error_per_row}}, $self->{node}->{status}->{error} );
      print "e" if $self->{verbose};
    }
    
    # change ident in source (take from target), if transfer was ok and target is an IdentAuthority
    # this is (for now) called a "retransmit" indicated by a "r"-character when verbosing
    if ($self->{node}->{status}->{ok} && $self->{meta}->{target}->{storage}->{isIdentAuthority}) {
      print "r" if $self->{verbose};
      #print Dumper($self->{meta});
      #print Dumper($self->{node});
      #exit;
      $self->_doModifySource_IdentChecksum($self->{node}->{target}->{ident});
    }

    print ":" if $self->{verbose};

  }

  print "\n" if $self->{verbose};
  
  # build user-message from some stats
    my $msg = "statistics: $tc";
    
    if ($tc->{error_per_row}) {
      $msg .= "\n";
      $msg .= "errors from \"error_per_row\":" . "\n";
      $msg .= Dumper($tc->{error_per_row});
    }
    
    # todo!!!
    #sysevent( { usermsg => $msg, level => $level }, $taskEvent );
    $logger->info( __PACKAGE__ . "->syncNodes: $msg" );

  return $tc;

}


# refactor this as some core-function to do a generic dump resolving data-encapsulations of e.g. Set::Object
sub _dumpCompact {
  my $self = shift;

  #my $vars = \@_;
  my @data = ();

  my $count = 0;
  foreach (@_) {
    my $item = {};
    foreach my $key (keys %$_) {
      my $val = $_->{$key};

#print Dumper($val);

      if (ref $val eq 'Set::Object') {
        #print "========================= SET", "\n";
#print Dumper($val);
        #print Dumper($val->members());
        #$val = $val->members();
        #$vars->[$count]->{$key} = $val->members() if $val->can("members");
        #$item->{$key} = $val->members() if $val->can("members");
        $item->{$key} = $val->members();
        #print Dumper($vars->[$count]->{$key});

      } else {
        $item->{$key} = $val;
      }

    }
    push @data, $item;
    $count++;
  }

#print "Dump:", Dumper(@data), "\n";

  $Data::Dumper::Indent = 0;
  my $result = Dumper(@data);
  $Data::Dumper::Indent = 2;
  return $result;
  
}


sub _calcChecksum {

  my $self = shift;
  my $descent = shift;
  my $specifier = shift;

  # calculate checksum for current object
    my $ident = $self->{node}->{$descent}->{ident};
  
  # build dump of this node
    my $payload = $self->{node}->{$descent}->{payload};
    #my $dump = $ident . "\n" . $item->quickdump();
    #my $dump = $ident . "\n" . Dumper($item);
    my $dump = $ident . "\n" . $self->_dumpCompact($payload);
  
  # TODO: $logger->dump( ... );
    #$logger->debug( __PACKAGE__ . ": " . $dump );
    #$logger->dump( __PACKAGE__ . ": " . $dump );
  
  # calculate checksum from dump
    # note: the 32-bit integer hash from DBI seems 
    # to generate duplicates with small payloads already in ranges of hundreds of items/rows!!!
    # try to avoid to use it or try to use it only for payloads greater than, hmmm, let's say 30 chars?
    # (we had about 15 chars average per item (row))

    # md5-based fingerprint, base64 encoded (from Digest::MD5)
      $self->{node}->{$descent}->{checksum} = md5_base64($dump) . '==';
    # 32-bit integer "hash" value (maybe faster?) (from DBI)
      #$self->{node}->{$descent}->{checksum} = DBI::hash($dump, 1);

  # signal good
  return 1;

}


sub _readChecksum {
  my $self = shift;

  my $descent = shift;

  #print "getcheck:", "\n"; print Dumper($self->{node}->{$descent});
  
  if (!$self->{node}->{$descent}) {
    # signal checksum bad
    return;
  }

  # get checksum for current entry
  # TODO: don't have the checksum column/property hardcoded as "cs" here, make this configurable somehow

  if ($self->{meta}->{$descent}->{storage}->{isChecksumAuthority}) {
    #$self->{node}->{$descent}->{checksum} = $entry->{cs};
    #$self->{node}->{$descent}->{checksum} = $self->_calcChecksum($descent); # $entry->{cs};
    #print "descent: $descent", "\n";
    $self->_calcChecksum($descent);
    #print "checksum: ", $self->{node}->{$descent}->{checksum}, "\n";
  } else {

    #$self->{node}->{$descent}->{checksum} = $entry->{cs};
    $self->{node}->{$descent}->{checksum} = $self->{node}->{$descent}->{payload}->{cs};
  }

  # signal checksum good
  return 1;

}


sub _buildMap {

 my $self = shift;

  # field-structure for building sql
  # mapping of sql-fieldnames to object-attributes
    $self->{node}->{map} = {};

    # manually set ...
      # ... object-id
      $self->{node}->{map}->{$self->{meta}->{target}->{IdentProvider}->{arg}} = $self->{node}->{source}->{ident};
      # ... checksum
      $self->{node}->{map}->{cs} = $self->{node}->{source}->{checksum};

#print "sqlmap: ", Dumper($self->{node}->{map}), "\n";

    # for transferring flat structures via simple (1:1) mapping
    # TODO: diff per property / property value

    if ($self->{args}->{mapping}) {
      # apply mapping from $self->{args}->{mapping} to $self->{node}->{map}
      #foreach my $key (@{$self->{meta}->{source}->{childnodes}}) {
      my @childnodes = @{$self->{meta}->{source}->{childnodes}};
      for (my $mapidx = 0; $mapidx <= $#childnodes; $mapidx++) {
        #my $map_right = $self->{args}->{mapping}->{$key};
        
        $self->{node}->{source}->{propcache} = {};
        $self->{node}->{target}->{propcache} = {};
        
        # get property name
        $self->{node}->{source}->{propcache}->{property} = $self->{meta}->{source}->{childnodes}->[$mapidx];
        $self->{node}->{target}->{propcache}->{property} = $self->{meta}->{target}->{childnodes}->[$mapidx];
        #print "map: $map_right", "\n";

        # get property value
        my $value;
        
        # detect for callback - old style - (maybe the better???)
        if (ref($self->{node}->{target}->{map}) eq 'CODE') {
          #$value = &$map_right($objClone);
        } else {
          # plain (scalar?) value
          #$value = $objClone->{$map_right};
          $self->{node}->{source}->{propcache}->{value} = $self->{node}->{source}->{payload}->{$self->{node}->{source}->{propcache}->{property}};
        }
        #$self->{node}->{map}->{$key} = $value;
        
        # detect expression
        # for transferring deeply nested structures described by expressions
        #print "val: $self->{node}->{source}->{propcache}->{value}", "\n";
        if ($self->{node}->{source}->{propcache}->{property} =~ s/^expr://) {
          
          # create an anonymous sub to act as callback target dispatcher
            my $cb_dispatcher = sub {
              #print "===============  CALLBACK DISPATCHER", "\n";
              #print "ident: ", $self->{node}->{source}->{ident}, "\n";
              #return $self->{node}->{source}->{ident};
              
            };
          

#print Dumper($self->{node});
          
          # build callback map for helper function
          #my $cbmap = { $self->{meta}->{source}->{IdentProvider}->{arg} => $cb_dispatcher };
          my $cbmap = {};
          my $value = refexpr2perlref($self->{node}->{source}->{payload}, $self->{node}->{source}->{propcache}->{property}, $cbmap);
          $self->{node}->{source}->{propcache}->{value} = $value;
        }

        # encode values dependent on type of underlying storage here - expand cases...
        my $storage_type = $self->{meta}->{target}->{storage}->{locator}->{type};
        if ($storage_type eq 'DBI') {
          # ...for sql
          $self->{node}->{source}->{propcache}->{value} = quotesql($self->{node}->{source}->{propcache}->{value});
        }
         elsif ($storage_type eq 'Tangram') {
          # iso? utf8 already possible?
        
        } elsif ($storage_type eq 'LDAP') {
          # TODO: encode utf8 here?
        }

        # store value to transfer map
        $self->{node}->{map}->{$self->{node}->{target}->{propcache}->{property}} = $self->{node}->{source}->{propcache}->{value};

      }
    }

    
  # TODO: $logger->dump( ... );
  #$logger->debug( "sqlmap:" . "\n" . Dumper($self->{node}->{map}) );
#print "sqlmap: ", Dumper($self->{node}->{map}), "\n";
#print "entrystatus: ", Dumper($self->{node}), "\n";

}


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};
    }
  }
  
  
  #print Dumper($self->{meta});

  # DBI speaks SQL
  if ($self->{meta}->{$descent}->{storage}->{locator}->{type} eq 'DBI') {

#print Dumper($self->{node});
    my $sql_main;
    # translate map to sql
    #print $action, "\n"; exit;
    #print $self->{meta}->{$descent}->{node}, "\n"; exit;
    #print "action:";
    #print $action, "\n";
#$action = "anc";
#print "yai", "\n";

#print Dumper($map);
#delete $map->{cs};

    if (lc($action) eq 'insert') {
      $sql_main = hash2Sql($self->{meta}->{$descent}->{node}, $map, 'SQL_INSERT');
    } elsif (lc $action eq 'update') {
      $crit ||= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'";
      $sql_main = hash2Sql($self->{meta}->{$descent}->{node}, $map, 'SQL_UPDATE', $crit);
    }

#$sql_main = "UPDATE currencies_csv SET oid='abcdef' WHERE text='Australian Dollar' AND key='AUD';";
#$sql_main = "UPDATE currencies_csv SET oid='huhu2' WHERE ekey='AUD'";

#print "sql: ", $sql_main, "\n";
#exit;

    # transfer data
    my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main);

#exit;

    # 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}->{node};
    
    # properties to exclude
    my @exclude = @{$self->{meta}->{$descent}->{subnodes_exclude}};


    if (my $identProvider = $self->{meta}->{$descent}->{IdentProvider}) {
      push @exclude, $identProvider->{arg};
    }

    # 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') {

      # build array to initialize object
      #my @initarray = ();
      #map { push @initarray, $_, undef; } @props;

      # make the object persistent in four steps:
      #   - raw create (perl / class tangram scope)
      #   - engine insert (tangram scope)   ... this establishes inheritance - don't try to fill in inherited properties before!
      #   - raw fill-in from hash (perl scope)
      #   - engine update (tangram scope)  ... this updates all properties just filled in
      
      # create new object ... 
      #my $object = $classname->new( @initarray );
      $object = $classname->new();
      
      # ... pass to orm ...
      $self->{meta}->{$descent}->{storage}->insert($object);

      # ... and initialize with empty (undef'd) properties.
      #print Dumper(@props);
      map { $object->{$_} = undef; } @props;

      # mix in values ...
      hash2object($object, $map);

      # ... and re-update@orm.
#print Dumper($object);
      $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
      $object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident});

#print Dumper($self->{node});
      
      # mix in values
      #print Dumper($object);
      hash2object($object, $map);
      #print Dumper($object);
      #exit;
      $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);
      my $perl_callback = $self->{meta}->{$descent}->{node} . '::' . $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;
        print $@, "\n";
      }
      
      #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 _doTransferToTarget {
  my $self = shift;
  my $action = shift;
  $self->_modifyNode('target', $action, $self->{node}->{map});
}

sub _doModifySource_IdentChecksum {
  my $self = shift;
  my $ident_new = shift;
  # this changes an old node to a new one including ident and checksum
  # TODO:
  #   - eventually introduce an external resource to store this data to
  #   - we won't have to "re"-modify the source node here
  my $map = {
    $self->{meta}->{source}->{IdentProvider}->{arg} => $ident_new,
    cs => $self->{node}->{target}->{checksum},
  };

#print Dumper($map);
#print Dumper($self->{node});
#exit;

  $self->_modifyNode('source', 'update', $map);
}


sub _prepareNode_MetaProperties {
  my $self = shift;
  my $descent = shift;

  $logger->info( __PACKAGE__ . "->_prepareNode_MetaProperties( descent $descent )" );
  
  # TODO: this should (better) be: "my $firstnode = $self->_getFirstNode($descent);"
  my $list = $self->_getNodeList($descent);
  
  # get first node
  my $firstnode = $list->[0];
  
  # check if node contains meta properties/nodes
  # TODO: "cs" is hardcoded here!
  my @required = ( $self->{meta}->{$descent}->{IdentProvider}->{arg}, 'cs' );
  my @found = keys %$firstnode;
  #my @diff = getDifference(\@found, \@required);
  my $diff = getDifference(\@required, \@found);
  #print Dumper(@found);
  #print Dumper(@required);
  #print Dumper(@diff);
  #if (!$#diff || $#diff == -1) {
  if (isEmpty($diff)) {
    $logger->warning( __PACKAGE__ . "->_prepareNode_MetaProperties: node is lacking meta properties - will try to alter..." );
    foreach (@required) {
      my $sql = "ALTER TABLE $self->{meta}->{$descent}->{node} ADD COLUMN $_";
      #print "sql: $sql", "\n";
      my $res = $self->{meta}->{$descent}->{storage}->sendCommand($sql);
      #print Dumper($res->getStatus());
    }
  }

}

sub _prepareNode_DummyIdent {
  my $self = shift;
  my $descent = shift;

  $logger->info( __PACKAGE__ . "->_prepareNode_DummyIdent( descent $descent )" );

  my $list = $self->_getNodeList($descent);
  #print Dumper($list);
  my $i = 0;
  my $ident_base = 5678983;
  my $ident_appendix = '0001';
  foreach my $node (@$list) {
    my $ident_dummy = $i + $ident_base;
    $ident_dummy .= $ident_appendix;
    my $map = {
      $self->{meta}->{$descent}->{IdentProvider}->{arg} => $ident_dummy,
      cs => undef,
    };
    
    # diff lists and ...
    my $diff = getDifference([keys %$node], [keys %$map]);
    next if $#{$diff} == -1;
    
    # ... build criteria including all columns
    my @crits;
    foreach my $property (@$diff) {
      next if !$property;
      my $value = $node->{$property};
      next if !$value;
      push @crits, "$property='" . quotesql($value) . "'";
    }
    my $crit = join ' AND ', @crits;
    print "p" if $self->{verbose};

#print Dumper($map);
#print Dumper($crit);

    $self->_modifyNode($descent, 'update', $map, $crit);
    $i++;
  }

  print "\n" if $self->{verbose};
  
  if (!$i) {
    $logger->warning( __PACKAGE__ . "->_prepareNode_DummyIdent: no nodes touched" );
  }
  
}

# TODO: handle this in an abstract way (wipe out use of 'source' and/or 'target' inside core)
sub _otherSide {
  my $self = shift;
  my $descent = shift;
  return 'source' if $descent eq 'target';
  return 'target' if $descent eq 'source';
  return '';
}

sub _erase_all {
  my $self = shift;
  my $descent = shift;
  #my $node = shift;
  my $node = $self->{meta}->{$descent}->{node};
  $self->{meta}->{$descent}->{storage}->eraseAll($node);
}

1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26