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