--- nfo/perl/libs/Data/Mungle/Code/Ref.pm	2003/02/20 18:55:46	1.2
+++ nfo/perl/libs/Data/Mungle/Code/Ref.pm	2003/02/20 19:33:28	1.3
@@ -1,7 +1,12 @@
 ## ---------------------------------------------------------------------------
-##  $Id: Ref.pm,v 1.2 2003/02/20 18:55:46 joko Exp $
+##  $Id: Ref.pm,v 1.3 2003/02/20 19:33:28 joko Exp $
 ## ---------------------------------------------------------------------------
 ##  $Log: Ref.pm,v $
+##  Revision 1.3  2003/02/20 19:33:28  joko
+##  refactored code from Data::Transform::Deep
+##  + sub ref_slot
+##  + sub expr2perl
+##
 ##  Revision 1.2  2003/02/20 18:55:46  joko
 ##  + minor cosmetic update
 ##
@@ -19,7 +24,8 @@
 require Exporter;
 our @ISA = qw( Exporter );
 our @EXPORT_OK = qw( 
-  get_coderef
+  &get_coderef
+  &ref_slot
 );
 
 
@@ -32,5 +38,125 @@
   return eval '\&' . $codepack . $method . ';';
 }
 
+
+# this function seems to do similar stuff like these below (refexpr2perlref & co.)
+# TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ?   ;-)
+sub _ref_slot_bylist {
+  my $var = shift;
+  my $indexstack_ref = shift;
+  my @indexstack = @{$indexstack_ref};
+  my $joiner = '->';
+  my @evlist;
+  foreach (@indexstack) {
+    my $elem;
+    if ($_ =~ m/\d+/) { $elem = "[$_]"; }
+    if ($_ =~ m/\D+/) { $elem = "{$_}"; }
+    push @evlist, $elem;
+    }
+  my $evstring = join($joiner, @evlist);
+  $evstring = 'return $var->' . $evstring . ';';
+  #print "ev: $evstring\n";
+  return eval($evstring);
+}
+
+
+sub ref_slot {
+
+  my $obj = shift;
+  my $expr = shift;
+  my $values = shift;
+  my $delimiter = shift;
+
+  $delimiter ||= '->';
+
+  my $value;
+  # detect for callback (code-reference)
+  if (ref($expr) eq 'CODE') {
+    $value = &$expr($obj);
+
+  } elsif (ref($expr) eq 'ARRAY') {
+    return _ref_slot_bylist($obj, $expr);
+
+  } elsif ($expr =~ m/$delimiter/) {
+    # use expr as complex object reference declaration (obj->subObj->subSubObj->0->attribute)
+    (my $objPerlRefString, my $parts) = expr2perl($expr, $delimiter);
+    
+    # trace
+      #print "expr: $expr", "\n";
+      #print "objPerlRefString: $objPerlRefString", "\n";
+    
+    my $evstr = '$obj' . '->' . $objPerlRefString;
+    
+    # trace
+      #print "eval: $evstr", "\n";
+    
+    $value = eval($evstr);
+    die ($@) if $@;
+    
+    # if value isn't set, try to set it
+    my $callbackMap;
+    if ($values) {
+      #if (ref $values eq 'HASH') {
+      if (ref $values eq 'Data::Map') {
+        $callbackMap = $values->getAttributes();
+      } else {
+        # apply $values as single value to referenced slot
+        #print "APPLY!", "\n";
+        eval('$obj' . '->' . $objPerlRefString . ' = $values;');
+        die ($@) if $@;
+      }
+    }
+    
+    # determine $values - if it's a hashref, use it as a "valueMap"
+    # "fallback" to callbackMap
+    # callbacks are applied this way:
+    #   take the last element of the expression parts and check if this string exists as a key in the callback-map
+    if (!$value && $callbackMap) {
+      #print Dumper($callbackMap);
+      
+      # prepare needle
+      my @parts = @$parts;
+      my $count = $#parts;
+      my $needle = $parts[$count];
+
+      # prepare haystack
+      my @haystack = keys %$callbackMap;
+      if (grep($needle, @haystack)) {
+        $value = $callbackMap->{$needle}->();
+        #print "value: ", $value, "\n";
+      }
+    }
+
+  } else {
+    # use expr as simple scalar key (attributename)
+    $value = $obj->{$expr};
+  }
+          
+  return $value;
+  
+}
+
+
+sub expr2perl {
+  my $expr = shift;
+  my $delimiter = shift;
+
+  $delimiter = quotemeta($delimiter);
+
+  # split expression by dereference operators first
+  my @parts_pure = split(/$delimiter/, $expr);
+
+  # wrap []'s around each part, if it consists of numeric characters only (=> numeric = array-index),
+  # use {}'s, if there are word-characters in it (=> alphanumeric = hash-key)
+  my @parts_capsule = @parts_pure;
+  map {
+    m/^\d+$/ && ($_ = "[$_]") || ($_ = "{$_}");
+  } @parts_capsule;
+
+  # join parts with dereference operators together again and return built string
+  return (join('->', @parts_capsule), \@parts_pure);
+}
+
+
 1;
 __END__