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