File Coverage

blib/lib/Object/InsideOut/Dynamic.pm
Criterion Covered Total %
statement 70 96 72.9
branch 22 44 50.0
condition 1 6 16.6
subroutine 6 7 85.7
pod n/a
total 99 153 64.7


line stmt bran cond sub pod time code
1             package Object::InsideOut; {
2              
3 4     4   36 use strict;
  4         33  
  4         140  
4 4     4   23 use warnings;
  4         9  
  4         117  
5 4     4   20 no warnings 'redefine';
  4         8  
  4         2942  
6              
7             sub create_field
8             {
9             my ($GBL, $call, @args) = @_;
10             push(@{$$GBL{'export'}}, 'create_field');
11             if ($call eq 'create_field') {
12             $$GBL{'init'} = 1;
13             }
14              
15             # Dynamically create a new object field
16             *Object::InsideOut::create_field = sub
17             {
18             # Handle being called as a method or subroutine
19 4 100   4   15 if ($_[0] eq 'Object::InsideOut') {
20 1         2 shift;
21             }
22              
23 4         11 my ($class, $field, @attrs) = @_;
24              
25             # Verify valid class
26 4 50       27 if (! $class->isa('Object::InsideOut')) {
27 0         0 OIO::Args->die(
28             'message' => 'Not an Object::InsideOut class',
29             'Arg' => $class);
30             }
31              
32             # Check for valid field
33 4 50       30 if ($field !~ /^\s*[@%]\s*[a-zA-Z_]\w*\s*$/) {
34 0         0 OIO::Args->die(
35             'message' => 'Not an array or hash declaration',
36             'Arg' => $field);
37             }
38              
39             # Convert attributes to single string
40 4         10 my $attr;
41 4 50       14 if (@attrs) {
42 4         52 s/^\s*(.*?)\s*$/$1/ foreach @attrs;
43 4         14 $attr = join(',', @attrs);
44 4         12 $attr =~ s/[\r\n]/ /sg;
45 4         13 $attr =~ s/,\s*,/,/g;
46 4         16 $attr =~ s/\s*,\s*:/ :/g;
47 4 100       16 if ($attr !~ /^\s*:/) {
48 1         3 $attr = ":Field($attr)";
49             }
50             } else {
51 0         0 $attr = ':Field';
52             }
53              
54             # Create the declaration
55 4         8 my @errs;
56 4     0   25 local $SIG{'__WARN__'} = sub { push(@errs, @_); };
  0         0  
57              
58 4         16 my $code = "package $class; my $field $attr;";
59 4         270 eval $code;
60 4 50       473 if (my $e = Exception::Class::Base->caught()) {
61 0         0 die($e);
62             }
63 4 50 33     61 if ($@ || @errs) {
64 0   0     0 my ($err) = split(/ at /, $@ || join(" | ", @errs));
65 0         0 OIO::Code->die(
66             'message' => 'Failure creating field',
67             'Error' => $err,
68             'Code' => $code);
69             }
70              
71             # Invalidate object initialization activity cache
72 4         9 delete($$GBL{'cache'});
73              
74             # Process the declaration
75 4         12 process_fields();
76             };
77              
78              
79             # Runtime hierarchy building
80             *Object::InsideOut::add_class = sub
81             {
82 1     1   3 my $class = shift;
83 1 50       3 if (ref($class)) {
84 0         0 OIO::Method->die('message' => q/'add_class' called as an object method/);
85             }
86 1 50       2 if ($class eq 'Object::InsideOut') {
87 0         0 OIO::Method->die('message' => q/'add_class' called on non-class 'Object::InsideOut'/);
88             }
89 1 50       7 if (! $class->isa('Object::InsideOut')) {
90 0         0 OIO::Method->die('message' => "'add_class' called on non-Object::InsideOut class '$class'");
91             }
92              
93 1         3 my $pkg = shift;
94 1 50       2 if (! $pkg) {
95 0         0 OIO::Args->die(
96             'message' => 'Missing argument',
97             'Usage' => "$class\->add_class(\$class)");
98             }
99              
100             # Already in the hierarchy - ignore
101 1 50       3 return if ($class->isa($pkg));
102              
103 4     4   33 no strict 'refs';
  4         8  
  4         2369  
104              
105             # If no package symbols, then load it
106 1 50       2 if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) {
  11         23  
  1         7  
107 0         0 eval "require $pkg";
108 0 0       0 if ($@) {
109 0         0 OIO::Code->die(
110             'message' => "Failure loading package '$pkg'",
111             'Error' => $@);
112             }
113             # Empty packages make no sense
114 0 0       0 if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) {
  0         0  
  0         0  
115 0         0 OIO::Code->die('message' => "Package '$pkg' is empty");
116             }
117             }
118              
119             # Import the package, if needed
120 1 50       4 if (@_) {
121 0         0 eval { $pkg->import(@_); };
  0         0  
122 0 0       0 if ($@) {
123 0         0 OIO::Code->die(
124             'message' => "Failure running 'import' on package '$pkg'",
125             'Error' => $@);
126             }
127             }
128              
129 1         2 my $tree_bu = $$GBL{'tree'}{'bu'};
130 1         2 my $tree_td = $$GBL{'tree'}{'td'};
131              
132             # Foreign class added
133 1 50       3 if (! exists($$tree_bu{$pkg})) {
134             # Get inheritance 'classes' hash
135 0 0       0 if (! exists($$GBL{'heritage'}{$class})) {
136 0         0 create_heritage($class);
137             }
138             # Add package to inherited classes
139 0         0 $$GBL{'heritage'}{$class}{'cl'}{$pkg} = undef;
140 0         0 return;
141             }
142              
143             # Add to class trees
144 1         2 foreach my $cl (keys(%{$tree_bu})) {
  1         3  
145 3 100       5 next if (! grep { $_ eq $class } @{$$tree_bu{$cl}});
  4         13  
  3         8  
146              
147             # Splice in the added class's tree
148 2         4 my @tree;
149 2         2 foreach (@{$$tree_bu{$cl}}) {
  2         5  
150 3         5 push(@tree, $_);
151 3 100       7 if ($_ eq $class) {
152 2         2 my %seen;
153 2         4 @seen{@{$$tree_bu{$cl}}} = undef;
  2         5  
154 2         3 foreach (@{$$tree_bu{$pkg}}) {
  2         5  
155 2 50       8 push(@tree, $_) if (! exists($seen{$_}));
156             }
157             }
158             }
159              
160             # Add to @ISA array
161 2         3 push(@{$cl.'::ISA'}, $pkg);
  2         26  
162              
163             # Save revised trees
164 2         7 $$tree_bu{$cl} = \@tree;
165 2         5 @{$$tree_td{$cl}} = reverse(@tree);
  2         6  
166             }
167 1         5 $$GBL{'asi'}{$pkg}{$class} = undef;
168             };
169              
170             # Invalidate object initialization activity cache
171             delete($$GBL{'cache'});
172              
173             # Do the original call
174             @_ = @args;
175             goto &$call;
176             }
177              
178             } # End of package's lexical scope
179              
180              
181             # Ensure correct versioning
182             ($Object::InsideOut::VERSION eq '4.05')
183             or die("Version mismatch\n");
184              
185             # EOF