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