Mungle/Code/Ref.pm

## ---------------------------------------------------------------------------
##  $Id: Ref.pm,v 1.5 2003/03/27 15:31:03 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: Ref.pm,v $
##  Revision 1.5  2003/03/27 15:31:03  joko
##  fixes to modules regarding new namespace(s) below Data::Mungle::*
##
##  Revision 1.4  2003/03/27 15:17:03  joko
##  namespace fixes for Data::Mungle::*
##
##  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
##
##  Revision 1.1  2003/01/22 17:59:22  root
##  + refactored from Mail::Audit::Dispatch
##
## ---------------------------------------------------------------------------


package Data::Mungle::Code::Ref;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( 
  &get_coderef
  &ref_slot
);


sub get_coderef {
  my $codepack = shift;
  my $method = shift;
  $codepack || return '[error]';
  $method ||= '';
  $method && ($codepack .= '::');
  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;
    # fix (2003-04-17): always do fill if value is *defined*!!!
    if (defined $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";
        my $evalstr = '$obj' . '->' . $objPerlRefString . ' = $values;';
        #print "eval: $evalstr", "\n";
        eval($evalstr);
        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__
1	root	1.1	## ---------------------------------------------------------------------------
2	joko	1.6	## $Id: Ref.pm,v 1.5 2003/03/27 15:31:03 joko Exp $
3	root	1.1	## ---------------------------------------------------------------------------
4	joko	1.2	## $Log: Ref.pm,v $
5	joko	1.6	## Revision 1.5 2003/03/27 15:31:03 joko
6			## fixes to modules regarding new namespace(s) below Data::Mungle::*
7			##
8	joko	1.5	## Revision 1.4 2003/03/27 15:17:03 joko
9			## namespace fixes for Data::Mungle::*
10			##
11	joko	1.4	## Revision 1.3 2003/02/20 19:33:28 joko
12	joko	1.5	## refactored code from Data.Transform.Deep
13	joko	1.4	## + sub ref_slot
14			## + sub expr2perl
15			##
16	joko	1.3	## Revision 1.2 2003/02/20 18:55:46 joko
17			## + minor cosmetic update
18			##
19	joko	1.2	## Revision 1.1 2003/01/22 17:59:22 root
20			## + refactored from Mail::Audit::Dispatch
21			##
22	root	1.1	## ---------------------------------------------------------------------------
23
24
25	joko	1.4	package Data::Mungle::Code::Ref;
26	root	1.1
27			use strict;
28			use warnings;
29
30			require Exporter;
31			our @ISA = qw( Exporter );
32			our @EXPORT_OK = qw(
33	joko	1.3	&get_coderef
34			&ref_slot
35	root	1.1	);
36
37
38			sub get_coderef {
39			my $codepack = shift;
40			my $method = shift;
41			$codepack \|\| return '[error]';
42			$method \|\|= '';
43			$method && ($codepack .= '::');
44			return eval '\&' . $codepack . $method . ';';
45			}
46	joko	1.3
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	joko	1.6	# fix (2003-04-17): always do fill if value is defined!!!
105			if (defined $values) {
106	joko	1.3	#if (ref $values eq 'HASH') {
107			if (ref $values eq 'Data::Map') {
108			$callbackMap = $values->getAttributes();
109			} else {
110			# apply $values as single value to referenced slot
111			#print "APPLY!", "\n";
112	joko	1.6	my $evalstr = '$obj' . '->' . $objPerlRefString . ' = $values;';
113			#print "eval: $evalstr", "\n";
114			eval($evalstr);
115	joko	1.3	die ($@) if $@;
116			}
117			}
118
119			# determine $values - if it's a hashref, use it as a "valueMap"
120			# "fallback" to callbackMap
121			# callbacks are applied this way:
122			# take the last element of the expression parts and check if this string exists as a key in the callback-map
123			if (!$value && $callbackMap) {
124			#print Dumper($callbackMap);
125
126			# prepare needle
127			my @parts = @$parts;
128			my $count = $#parts;
129			my $needle = $parts[$count];
130
131			# prepare haystack
132			my @haystack = keys %$callbackMap;
133			if (grep($needle, @haystack)) {
134			$value = $callbackMap->{$needle}->();
135			#print "value: ", $value, "\n";
136			}
137			}
138
139			} else {
140			# use expr as simple scalar key (attributename)
141			$value = $obj->{$expr};
142			}
143
144			return $value;
145
146			}
147
148
149			sub expr2perl {
150			my $expr = shift;
151			my $delimiter = shift;
152
153			$delimiter = quotemeta($delimiter);
154
155			# split expression by dereference operators first
156			my @parts_pure = split(/$delimiter/, $expr);
157
158			# wrap []'s around each part, if it consists of numeric characters only (=> numeric = array-index),
159			# use {}'s, if there are word-characters in it (=> alphanumeric = hash-key)
160			my @parts_capsule = @parts_pure;
161			map {
162			m/^\d+$/ && ($_ = "[$_]") \|\| ($_ = "{$_}");
163			} @parts_capsule;
164
165			# join parts with dereference operators together again and return built string
166			return (join('->', @parts_capsule), \@parts_pure);
167			}
168
169	root	1.1
170			1;
171	joko	1.2	__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26