File Coverage

blib/lib/Object/InsideOut/lvalue.pm
Criterion Covered Total %
statement 42 46 91.3
branch 20 26 76.9
condition 2 3 66.6
subroutine 4 4 100.0
pod n/a
total 68 79 86.0


line stmt bran cond sub pod time code
1             package Object::InsideOut; {
2              
3 1     1   9 use strict;
  1         2  
  1         34  
4 1     1   7 use warnings;
  1         3  
  1         27  
5 1     1   5 no warnings 'redefine';
  1         2  
  1         891  
6              
7             # Create an :lvalue accessor method
8             sub create_lvalue_accessor
9             {
10             if ($] < 5.008) {
11             my ($pkg, $set) = @_;
12             OIO::Code->die(
13             'message' => "Can't create 'lvalue' accessor method '$set' for package '$pkg'",
14             'Info' => q/'lvalue' accessors require Perl 5.8.0 or later/);
15             }
16              
17             eval { require Want; };
18             if ($@) {
19             my ($pkg, $set) = @_;
20             OIO::Code->die(
21             'message' => "Can't create 'lvalue' accessor method '$set' for package '$pkg'",
22             'Info' => q/Failure loading 'Want' module/,
23             'Error' => $@);
24             } elsif ($Want::VERSION < 0.12) {
25             my ($pkg, $set) = @_;
26             OIO::Code->die(
27             'message' => "Can't create 'lvalue' accessor method '$set' for package '$pkg'",
28             'Info' => q/Requires 'Want' v0.12 or later/);
29             }
30              
31             *Object::InsideOut::create_lvalue_accessor = sub
32             {
33 14     14   29 my $caller = caller();
34 14 50       30 if ($caller ne 'Object::InsideOut') {
35 0         0 OIO::Method->die('message' => "Can't call private subroutine 'Object::InsideOut::create_lvalue_accessor' from class '$caller'");
36             }
37              
38 14         41 my ($pkg, $set, $field_ref, $get, $type, $is_ref, $subtype,
39             $name, $return, $private, $restricted, $weak, $pre) = @_;
40              
41             # Field string
42 14 50       34 my $fld_str = (ref($field_ref) eq 'HASH') ? "\$field->\{\${\$_[0]}}" : "\$field->\[\${\$_[0]}]";
43              
44             # 'Want object' string
45 14         21 my $obj_str = q/(Want::wantref() eq 'OBJECT')/;
46              
47             # Begin with subroutine declaration in the appropriate package
48 14         44 my $code = "*${pkg}::$set = sub :lvalue {\n"
49             . preamble_code($pkg, $set, $private, $restricted)
50             . " my \$rv = !Want::want_lvalue(0);\n";
51              
52             # Add GET portion for combination accessor
53 14 100 66     51 if ($get && ($get eq $set)) {
54 11         25 $code .= " Want::rreturn($fld_str) if (\$rv && (\@_ == 1));\n";
55             }
56              
57             # If set only, then must have at least one arg
58             else {
59 3         9 $code .= <<"_CHECK_ARGS_";
60             my \$wobj = $obj_str;
61             if ((\@_ < 2) && (\$rv || \$wobj)) {
62             OIO::Args->die(
63             'message' => q/Missing arg(s) to '$pkg->$set'/,
64             'location' => [ caller() ]);
65             }
66             _CHECK_ARGS_
67 3         6 $obj_str = '$wobj';
68             }
69              
70             # Add field locking code if sharing
71 14 50       35 if (is_sharing($pkg)) {
72 0         0 $code .= " lock(\$field);\n"
73             }
74              
75             # Return value for 'OLD'
76 14 100       31 if ($return eq 'OLD') {
77 4         8 $code .= " my \$ret;\n";
78             }
79              
80             # Get args if assignment
81 14         25 $code .= <<"_SET_";
82             my \$assign;
83             if (my \@args = Want::wantassign(1)) {
84             \@_ = (\$_[0], \@args);
85             \$assign = 1;
86             }
87             if (\@_ > 1) {
88             _SET_
89              
90             # Add preprocessing code block
91 14 50       25 if ($pre) {
92 0         0 $code .= <<"_PRE_";
93             {
94             my \@errs;
95             local \$SIG{'__WARN__'} = sub { push(\@errs, \@_); };
96             eval {
97             my \$self = shift;
98             \@_ = (\$self, \$preproc->(\$self, \$field, \@_));
99             };
100             if (\$@ || \@errs) {
101             my (\$err) = split(/ at /, \$@ || join(" | ", \@errs));
102             OIO::Code->die(
103             'message' => q/Problem with preprocessing routine for '$pkg->$set'/,
104             'Error' => \$err);
105             }
106             }
107             _PRE_
108             }
109              
110             # Add data type checking
111 14         34 my ($type_code, $arg_str) = type_code($pkg, $set, $weak,
112             $type, $is_ref, $subtype);
113 14         27 $code .= $type_code;
114              
115             # Grab 'OLD' value
116 14 100       29 if ($return eq 'OLD') {
117 4         9 $code .= " \$ret = $fld_str;\n";
118             }
119              
120             # Add actual 'set' code
121 14 50       30 $code .= (is_sharing($pkg))
122             ? " $fld_str = Object::InsideOut::Util::make_shared($arg_str);\n"
123             : " $fld_str = $arg_str;\n";
124 14 50       28 if ($weak) {
125 0         0 $code .= " Scalar::Util::weaken($fld_str);\n";
126             }
127              
128             # Add code for return value
129 14         21 $code .= " Want::lnoreturn if \$assign;\n";
130 14 100       29 if ($return eq 'SELF') {
    100          
131 4         7 $code .= " Want::rreturn(\$_[0]) if \$rv;\n";
132             } elsif ($return eq 'OLD') {
133 4         6 $code .= " Want::rreturn(\$ret) if \$rv;\n";
134             } else {
135 6         14 $code .= " Want::rreturn($fld_str) if \$rv;\n";
136             }
137 14         20 $code .= " }\n";
138              
139 14 100       30 if ($return eq 'SELF') {
    100          
140 4         8 $code .= " (\@_ < 2) ? $fld_str : \$_[0];\n";
141             } elsif ($return eq 'OLD') {
142 4         9 $code .= " (\@_ < 2) ? $fld_str : (($obj_str && !Scalar::Util::blessed(\$ret)) ? \$_[0] : \$ret);\n";
143             } else {
144 6         15 $code .= " ((\@_ > 1) && $obj_str && !Scalar::Util::blessed($fld_str)) ? \$_[0] : $fld_str;\n";
145             }
146 14         23 $code .= "};\n";
147              
148             # Done
149 14         56 return ($code);
150             };
151              
152             # Do the original call
153             goto &create_lvalue_accessor;
154             }
155              
156             } # End of package's lexical scope
157              
158              
159             # Ensure correct versioning
160             ($Object::InsideOut::VERSION eq '4.05')
161             or die("Version mismatch\n");
162              
163             # EOF