/[cvs]/nfo/perl/libs/Data/Mungle/Code/Ref.pm
ViewVC logotype

Diff of /nfo/perl/libs/Data/Mungle/Code/Ref.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by joko, Thu Feb 20 18:55:46 2003 UTC revision 1.3 by joko, Thu Feb 20 19:33:28 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ---------------------------------------------------------------------------  ## ---------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.3  2003/02/20 19:33:28  joko
6    ##  refactored code from Data::Transform::Deep
7    ##  + sub ref_slot
8    ##  + sub expr2perl
9    ##
10  ##  Revision 1.2  2003/02/20 18:55:46  joko  ##  Revision 1.2  2003/02/20 18:55:46  joko
11  ##  + minor cosmetic update  ##  + minor cosmetic update
12  ##  ##
# Line 19  use warnings; Line 24  use warnings;
24  require Exporter;  require Exporter;
25  our @ISA = qw( Exporter );  our @ISA = qw( Exporter );
26  our @EXPORT_OK = qw(  our @EXPORT_OK = qw(
27    get_coderef    &get_coderef
28      &ref_slot
29  );  );
30    
31    
# Line 32  sub get_coderef { Line 38  sub get_coderef {
38    return eval '\&' . $codepack . $method . ';';    return eval '\&' . $codepack . $method . ';';
39  }  }
40    
41    
42    # this function seems to do similar stuff like these below (refexpr2perlref & co.)
43    # TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ?   ;-)
44    sub _ref_slot_bylist {
45      my $var = shift;
46      my $indexstack_ref = shift;
47      my @indexstack = @{$indexstack_ref};
48      my $joiner = '->';
49      my @evlist;
50      foreach (@indexstack) {
51        my $elem;
52        if ($_ =~ m/\d+/) { $elem = "[$_]"; }
53        if ($_ =~ m/\D+/) { $elem = "{$_}"; }
54        push @evlist, $elem;
55        }
56      my $evstring = join($joiner, @evlist);
57      $evstring = 'return $var->' . $evstring . ';';
58      #print "ev: $evstring\n";
59      return eval($evstring);
60    }
61    
62    
63    sub ref_slot {
64    
65      my $obj = shift;
66      my $expr = shift;
67      my $values = shift;
68      my $delimiter = shift;
69    
70      $delimiter ||= '->';
71    
72      my $value;
73      # detect for callback (code-reference)
74      if (ref($expr) eq 'CODE') {
75        $value = &$expr($obj);
76    
77      } elsif (ref($expr) eq 'ARRAY') {
78        return _ref_slot_bylist($obj, $expr);
79    
80      } elsif ($expr =~ m/$delimiter/) {
81        # use expr as complex object reference declaration (obj->subObj->subSubObj->0->attribute)
82        (my $objPerlRefString, my $parts) = expr2perl($expr, $delimiter);
83        
84        # trace
85          #print "expr: $expr", "\n";
86          #print "objPerlRefString: $objPerlRefString", "\n";
87        
88        my $evstr = '$obj' . '->' . $objPerlRefString;
89        
90        # trace
91          #print "eval: $evstr", "\n";
92        
93        $value = eval($evstr);
94        die ($@) if $@;
95        
96        # if value isn't set, try to set it
97        my $callbackMap;
98        if ($values) {
99          #if (ref $values eq 'HASH') {
100          if (ref $values eq 'Data::Map') {
101            $callbackMap = $values->getAttributes();
102          } else {
103            # apply $values as single value to referenced slot
104            #print "APPLY!", "\n";
105            eval('$obj' . '->' . $objPerlRefString . ' = $values;');
106            die ($@) if $@;
107          }
108        }
109        
110        # determine $values - if it's a hashref, use it as a "valueMap"
111        # "fallback" to callbackMap
112        # callbacks are applied this way:
113        #   take the last element of the expression parts and check if this string exists as a key in the callback-map
114        if (!$value && $callbackMap) {
115          #print Dumper($callbackMap);
116          
117          # prepare needle
118          my @parts = @$parts;
119          my $count = $#parts;
120          my $needle = $parts[$count];
121    
122          # prepare haystack
123          my @haystack = keys %$callbackMap;
124          if (grep($needle, @haystack)) {
125            $value = $callbackMap->{$needle}->();
126            #print "value: ", $value, "\n";
127          }
128        }
129    
130      } else {
131        # use expr as simple scalar key (attributename)
132        $value = $obj->{$expr};
133      }
134              
135      return $value;
136      
137    }
138    
139    
140    sub expr2perl {
141      my $expr = shift;
142      my $delimiter = shift;
143    
144      $delimiter = quotemeta($delimiter);
145    
146      # split expression by dereference operators first
147      my @parts_pure = split(/$delimiter/, $expr);
148    
149      # wrap []'s around each part, if it consists of numeric characters only (=> numeric = array-index),
150      # use {}'s, if there are word-characters in it (=> alphanumeric = hash-key)
151      my @parts_capsule = @parts_pure;
152      map {
153        m/^\d+$/ && ($_ = "[$_]") || ($_ = "{$_}");
154      } @parts_capsule;
155    
156      # join parts with dereference operators together again and return built string
157      return (join('->', @parts_capsule), \@parts_pure);
158    }
159    
160    
161  1;  1;
162  __END__  __END__
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed