File Coverage

blib/lib/HTML/Mason/Component.pm
Criterion Covered Total %
statement 138 151 91.3
branch 46 64 71.8
condition n/a
subroutine 36 40 90.0
pod 20 30 66.6
total 240 285 84.2


line stmt bran cond sub pod time code
1             # Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
2             # This program is free software; you can redistribute it and/or modify it
3             # under the same terms as Perl itself.
4              
5             package HTML::Mason::Component;
6             $HTML::Mason::Component::VERSION = '1.60';
7 30     30   205 use strict;
  30         75  
  30         899  
8 30     30   160 use warnings;
  30         66  
  30         684  
9 30     30   148 use File::Spec;
  30         84  
  30         822  
10 30     30   182 use HTML::Mason::Exceptions( abbr => [qw(param_error)] );
  30         81  
  30         559  
11 30     30   213 use HTML::Mason::Tools qw(absolute_comp_path can_weaken);
  30         70  
  30         2293  
12 30     30   234 use Params::Validate qw(:all);
  30         72  
  30         9925  
13             Params::Validate::validation_options( on_fail => sub { param_error join '', @_ } );
14              
15 30     30   238 use HTML::Mason::Exceptions( abbr => ['error'] );
  30         102  
  30         247  
16             use HTML::Mason::MethodMaker
17 30         695 ( read_only => [ qw( code
18             comp_id
19             compiler_id
20             declared_args
21             inherit_path
22             inherit_start_path
23             has_filter
24             load_time
25             ) ],
26              
27             read_write => [ [ dynamic_subs_request => { isa => 'HTML::Mason::Request' } ],
28             [ mfu_count => { type => SCALAR } ],
29             [ filter => { type => CODEREF } ],
30             ]
31 30     30   230 );
  30         78  
32              
33             # for reference later
34             #
35             # __PACKAGE__->valid_params
36             # (
37             # attr => {type => HASHREF, default => {}, public => 0},
38             # code => {type => CODEREF, public => 0, public => 0},
39             # load_time => {type => SCALAR, optional => 1, public => 0},
40             # declared_args => {type => HASHREF, default => {}, public => 0},
41             # dynamic_subs_init => {type => CODEREF, default => sub {}, public => 0},
42             # flags => {type => HASHREF, default => {}, public => 0},
43             # comp_id => {type => SCALAR, optional => 1, public => 0},
44             # methods => {type => HASHREF, default => {}, public => 0},
45             # mfu_count => {type => SCALAR, default => 0, public => 0},
46             # parser_version => {type => SCALAR, optional => 1, public => 0}, # allows older components to be instantied
47             # compiler_id => {type => SCALAR, optional => 1, public => 0},
48             # subcomps => {type => HASHREF, default => {}, public => 0},
49             # );
50             #
51              
52             my %defaults = ( attr => {},
53             declared_args => {},
54             dynamic_subs_init => sub {},
55             flags => {},
56             methods => {},
57             mfu_count => 0,
58             subcomps => {},
59             );
60             sub new
61             {
62 739     739 0 2012 my $class = shift;
63 739         6089 my $self = bless { %defaults, @_ }, $class;
64              
65             # Initialize subcomponent and method properties: owner, name, and
66             # is_method flag.
67 739         1762 while (my ($name,$c) = each(%{$self->{subcomps}})) {
  795         3605  
68 56         354 $c->assign_subcomponent_properties($self,$name,0);
69 56 50       336 Scalar::Util::weaken($c->{owner}) if can_weaken;
70             }
71 739         1263 while (my ($name,$c) = each(%{$self->{methods}})) {
  803         2189  
72 64         258 $c->assign_subcomponent_properties($self,$name,1);
73 64 50       165 Scalar::Util::weaken($c->{owner}) if can_weaken;
74             }
75              
76 739         10588 return $self;
77             }
78              
79             my $comp_count = 0;
80             sub assign_runtime_properties {
81 739     739 0 1565 my ($self, $interp, $source) = @_;
82 739         2445 $self->interp($interp);
83 739 100       1895 $self->{comp_id} = defined $source->comp_id ? $source->comp_id : "[anon ". ++$comp_count . "]";
84              
85 739         1714 $self->{path} = $source->comp_path;
86              
87 739         2434 $self->_determine_inheritance;
88              
89 739         1354 foreach my $c (values(%{$self->{subcomps}}), values(%{$self->{methods}})) {
  739         1673  
  739         1825  
90 120         447 $c->assign_runtime_properties($interp, $source);
91             }
92              
93             # Cache of uncanonicalized call paths appearing in the
94             # component. Used in $m->fetch_comp.
95             #
96 739 100       1873 if ($interp->use_internal_component_caches) {
97 17         69 $self->{fetch_comp_cache} = {};
98             }
99             }
100              
101             sub flush_internal_caches
102             {
103 11     11 0 25 my ($self) = @_;
104              
105 11         35 $self->{fetch_comp_cache} = {};
106 11         35 delete($self->{parent_cache});
107             }
108              
109             sub _determine_inheritance {
110 739     739   1188 my $self = shift;
111              
112 739         1436 my $interp = $self->interp;
113              
114             # Assign inheritance properties
115 739 100       2562 if (exists($self->{flags}->{inherit})) {
    100          
116 21 100       88 if (defined($self->{flags}->{inherit})) {
117 2         9 $self->{inherit_path} = absolute_comp_path($self->{flags}->{inherit}, $self->dir_path);
118             }
119             } elsif ( $interp->use_autohandlers ) {
120 717 100       1956 if ($self->name eq $interp->autohandler_name) {
121 15 50       71 unless ($self->dir_path eq '/') {
122 15         42 ($self->{inherit_start_path}) = $self->dir_path =~ m,^(.*/)?.*,s
123             }
124             } else {
125 702         1665 $self->{inherit_start_path} = $self->dir_path;
126             }
127             }
128             }
129              
130             sub run {
131 1195     1195 0 1949 my $self = shift;
132              
133 1195         2057 $self->{mfu_count}++;
134              
135 1195         4373 $self->{code}->(@_);
136             }
137              
138             sub dynamic_subs_init {
139 13     13 0 33 my $self = shift;
140              
141             error "cannot call a method or subcomponent from a <%shared> block"
142 13 100       60 if $self->{in_dynamic_subs_init};
143              
144 11         37 local $self->{in_dynamic_subs_init} = 1;
145              
146 11         47 $self->{dynamic_subs_hash} = $self->{dynamic_subs_init}->();
147             error "could not process <%shared> section (does it contain a return()?)"
148 8 50       53 unless ref($self->{dynamic_subs_hash}) eq 'HASH';
149             }
150              
151             sub run_dynamic_sub {
152 17     17 0 48 my ($self, $key, @args) = @_;
153              
154             error "call_dynamic: assert error - could not find code for key $key in component " . $self->title
155 17 50       51 unless exists $self->{dynamic_subs_hash}->{$key};
156              
157 17         58 return $self->{dynamic_subs_hash}->{$key}->(@args);
158             }
159              
160             # Legacy, left in for pre-0.8 obj files
161       0 0   sub assign_subcomponent_properties {}
162              
163             #
164             # By default components are not persistent.
165             #
166 0     0 0 0 sub persistent { 0 }
167              
168             #
169             # Only true in Subcomponent subclass.
170             #
171 425     425 1 1241 sub is_subcomp { 0 }
172              
173 5     5 1 20 sub is_method { 0 }
174              
175             #
176             # Only true in FileBased subclass.
177             #
178 3     3 1 10 sub is_file_based { 0 }
179              
180             #
181             # Basic defaults for component designators: title, path, name, dir_path
182             #
183 1     1 1 5 sub title { return $_[0]->{comp_id} }
184 14     14 1 58 sub name { return $_[0]->{comp_id} }
185 1     1 1 4 sub path { return undef }
186 15     15 1 38 sub dir_path { return undef }
187              
188             #
189             # Get all subcomps or particular subcomp by name
190             #
191             sub subcomps {
192 477     477 1 976 my ($self,$key) = @_;
193 477 100       1045 if (defined($key)) {
194 469         1614 return $self->{subcomps}->{$key};
195             } else {
196 8         30 return $self->{subcomps};
197             }
198             }
199              
200             #
201             # Get all methods or particular method by name
202             #
203             sub methods {
204 4     4 1 9 my ($self,$key) = @_;
205 4 100       9 if (defined($key)) {
206 3         16 return $self->{methods}->{$key};
207             } else {
208 1         4 return $self->{methods};
209             }
210             }
211              
212             #
213             # Get all attributes
214             #
215 1     1 1 3 sub attributes { $_[0]->{attr} }
216              
217             #
218             # Get attribute by name
219             #
220             sub attr {
221 49     49 1 100 my ($self,$name) = @_;
222 49         64 my $value;
223 49 50       109 if ($self->_locate_inherited('attr',$name,\$value)) {
224 49         185 return $value;
225             } else {
226 0         0 error "no attribute '$name' for component " . $self->title;
227             }
228             }
229              
230             sub attr_if_exists {
231 2     2 1 5 my ($self,$name) = @_;
232 2         5 my $value;
233 2 100       7 if ($self->_locate_inherited('attr',$name,\$value)) {
234 1         10 return $value;
235             } else {
236 1         8 return undef;
237             }
238             }
239              
240             #
241             # Determine if particular attribute exists
242             #
243             sub attr_exists {
244 43     43 1 85 my ($self,$name) = @_;
245 43         80 return $self->_locate_inherited('attr',$name);
246             }
247              
248             #
249             # Call method by name
250             #
251             sub call_method {
252 5     5 1 14 my ($self,$name,@args) = @_;
253 5         7 my $method;
254 5 50       22 if ($self->_locate_inherited('methods',$name,\$method)) {
255 5         21 HTML::Mason::Request->instance->comp({base_comp=>$self},$method,@args);
256             } else {
257 0         0 error "no method '$name' for component " . $self->title;
258             }
259             }
260              
261             #
262             # Like call method, but return component output.
263             #
264             sub scall_method {
265 1     1 1 10 my ($self,$name,@args) = @_;
266 1         3 my $method;
267 1 50       4 if ($self->_locate_inherited('methods',$name,\$method)) {
268 1         6 HTML::Mason::Request->instance->scomp({base_comp=>$self},$method,@args);
269             } else {
270 0         0 error "no method '$name' for component " . $self->title;
271             }
272             }
273              
274             #
275             # Determine if particular method exists
276             #
277             sub method_exists {
278 42     42 1 79 my ($self,$name) = @_;
279 42         72 return $self->_locate_inherited('methods',$name);
280             }
281              
282             #
283             # Locate a component slot element following inheritance path
284             #
285             sub _locate_inherited {
286 215     215   449 my ($self,$field,$key,$ref) = @_;
287 215         293 my $count = 0;
288 215         487 for (my $comp = $self; $comp; $comp = $comp->parent) {
289 285 100       639 if (exists($comp->{$field}->{$key})) {
290 199 100       438 $$ref = $comp->{$field}->{$key} if $ref;
291 199         544 return 1;
292             }
293 86 50       232 error "inheritance chain length > 32 (infinite inheritance loop?)"
294             if ++$count > 32;
295             }
296 16         57 return 0;
297             }
298              
299             #
300             # Get particular flag by name
301             #
302             sub flag {
303 0     0 1 0 my ($self,$name) = @_;
304 0         0 my %flag_defaults =
305             (
306             );
307 0 0       0 if (exists($self->{flags}->{$name})) {
    0          
308 0         0 return $self->{flags}->{$name};
309             } elsif (exists($flag_defaults{$name})) {
310 0         0 return $flag_defaults{$name};
311             } else {
312 0         0 error "invalid flag: $name";
313             }
314             }
315              
316             #
317             # Return parent component according to inherit flag.
318             #
319             sub parent {
320 566     566 1 1063 my ($self) = @_;
321              
322             # Return cached value for parent, if any (may be undef)
323             #
324 566 50       1417 return $self->{parent_cache} if exists($self->{parent_cache});
325              
326 566         1183 my $interp = $self->interp;
327 566         852 my $parent;
328 566 100       1560 if ($self->inherit_path) {
    100          
329 24 50       51 $parent = $interp->load($self->inherit_path)
330             or error(sprintf("cannot find inherit path '%s' for component '%s'",
331             $self->inherit_path, $self->title));
332             } elsif ($self->inherit_start_path) {
333 511         1135 $parent = $interp->find_comp_upwards($self->inherit_start_path, $interp->autohandler_name);
334             }
335              
336             # Can only cache parent value if interp->{use_internal_component_caches} is on -
337             # see definition in Interp::_initialize.
338             #
339 566 100       1908 if ($interp->use_internal_component_caches) {
340 7         23 $self->{parent_cache} = $parent;
341             }
342              
343 566         2141 return $parent;
344             }
345              
346             sub interp {
347 2047     2047 0 3092 my $self = shift;
348              
349 2047 100       5403 if (@_) {
    50          
350 739         11176 validate_pos( @_, { isa => 'HTML::Mason::Interp' } );
351              
352 739         2644 $self->{interp} = $_[0];
353              
354 739 50       2111 Scalar::Util::weaken( $self->{interp} ) if can_weaken;
355             } elsif ( ! defined $self->{interp} ) {
356 0         0 die "The Interp object that this object contains has gone out of scope.\n";
357             }
358              
359 2047         3912 return $self->{interp};
360             }
361              
362             #
363             # Accessors for various files associated with component
364             #
365             sub object_file {
366 3     3 1 7 my $self = shift;
367 3         12 return $self->interp->object_file($self);
368             }
369              
370             # For backwards compatibility with 1.0x
371             sub create_time {
372 0     0 1 0 my $self = shift;
373 0         0 return $self->load_time(@_);
374             }
375              
376             # Create logger on demand - generally called from $m->log
377             sub logger {
378 2     2 0 3 my ($self) = @_;
379              
380 2 50       13 if (!$self->{logger}) {
381 2         7 my $log_category = "HTML::Mason::Component" . $self->path();
382 2         8 $log_category =~ s/\//::/g;
383 2         17 $self->{logger} = Log::Any->get_logger(category => $log_category);
384             }
385 2         392 return $self->{logger};
386             }
387              
388             1;
389              
390             __END__