File Coverage

blib/lib/HTML/Mason/Compiler/ToObject.pm
Criterion Covered Total %
statement 246 246 100.0
branch 77 84 91.6
condition 7 12 58.3
subroutine 37 37 100.0
pod 1 3 33.3
total 368 382 96.3


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
3             # it under the same terms as Perl itself.
4              
5             package HTML::Mason::Compiler::ToObject;
6             $HTML::Mason::Compiler::ToObject::VERSION = '1.58';
7 30     30   1660 use strict;
  30         62  
  30         936  
8 30     30   152 use warnings;
  30         55  
  30         1026  
9              
10 30     30   169 use Params::Validate qw(BOOLEAN SCALAR validate);
  30         66  
  30         2187  
11 30     30   169 use HTML::Mason::Tools qw(taint_is_on);
  30         53  
  30         1260  
12              
13 30     30   9989 use HTML::Mason::Compiler;
  30         88  
  30         1041  
14 30     30   230 use base qw( HTML::Mason::Compiler );
  30         66  
  30         3265  
15              
16 30     30   200 use HTML::Mason::Exceptions( abbr => [qw(wrong_compiler_error system_error)] );
  30         69  
  30         192  
17              
18 30     30   182 use File::Path qw(mkpath rmtree);
  30         65  
  30         1875  
19 30     30   174 use File::Basename qw(dirname);
  30         65  
  30         5583  
20              
21             BEGIN
22             {
23 30     30   722 __PACKAGE__->valid_params
24             (
25             comp_class =>
26             { parse => 'string', type => SCALAR, default => 'HTML::Mason::Component',
27             descr => "The class into which component objects will be blessed" },
28              
29             subcomp_class =>
30             { parse => 'string', type => SCALAR, default => 'HTML::Mason::Component::Subcomponent',
31             descr => "The class into which subcomponent objects will be blessed" },
32              
33             in_package =>
34             { parse => 'string', type => SCALAR, default => 'HTML::Mason::Commands',
35             descr => "The package in which component execution will take place" },
36              
37             preamble =>
38             { parse => 'string', type => SCALAR, default => '',
39             descr => "A chunk of Perl code to add to the beginning of each compiled component" },
40              
41             postamble =>
42             { parse => 'string', type => SCALAR, default => '',
43             descr => "A chunk of Perl code to add to the end of each compiled component" },
44              
45             use_strict =>
46             { parse => 'boolean', type => SCALAR, default => 1,
47             descr => "Whether to turn on Perl's 'strict' pragma in components" },
48              
49             use_warnings =>
50             { parse => 'boolean', type => SCALAR, default => 0,
51             descr => "Whether to turn on Perl's 'warnings' pragma in components" },
52              
53             define_args_hash =>
54             { parse => 'string', type => SCALAR, default => 'auto',
55             regex => qr/^(?:always|auto|never)$/,
56             descr => "Whether or not to create the %ARGS hash" },
57              
58             named_component_subs =>
59             { parse => 'boolean', type => BOOLEAN, default => 0,
60             descr => "Whether to use named subroutines for component code" },
61             );
62             }
63              
64             use HTML::Mason::MethodMaker
65 30         197 ( read_only => [
66             qw( comp_class
67             define_args_hash
68             in_package
69             named_component_subs
70             postamble
71             preamble
72             subcomp_class
73             use_strict
74             use_warnings
75             )
76             ],
77 30     30   3202 );
  30         66  
78              
79             sub compile
80             {
81 547     547 1 1066 my $self = shift;
82 547         2664 my %p = @_;
83              
84 547 100       2459 local $self->{comp_class} = delete $p{comp_class} if exists $p{comp_class};
85 547         2858 return $self->SUPER::compile( %p );
86             }
87              
88             #
89             # compile_to_file( source => ..., file => ... )
90             # Save object text in an object file.
91             #
92             # We attempt to handle several cases in which a file already exists
93             # and we wish to create a directory, or vice versa. However, not
94             # every case is handled; to be complete, mkpath would have to unlink
95             # any existing file in its way.
96             #
97             sub compile_to_file
98             {
99 518     518 0 1066 my $self = shift;
100              
101 518         12818 my %p = validate( @_, { file => { type => SCALAR },
102             source => { isa => 'HTML::Mason::ComponentSource' } },
103             );
104              
105 518         3282 my ($file, $source) = @p{qw(file source)};
106 518         1257 my @newfiles = ($file);
107              
108 518 100 66     5556 if (defined $file && !-f $file) {
109 504         24119 my ($dirname) = dirname($file);
110 504 100       5710 if (!-d $dirname) {
111 99 50       309 unlink($dirname) if (-e _);
112 99         16338 push @newfiles, mkpath($dirname, 0, 0775);
113 99 50       1203 system_error "Couldn't create directory $dirname: $!"
114             unless -d $dirname;
115             }
116 504 50       3282 rmtree($file) if (-d $file);
117             }
118              
119 518 100       2208 ($file) = $file =~ /^(.*)/s if taint_is_on; # Untaint blindly
120              
121 518 50       28248 open my $fh, "> $file"
122             or system_error "Couldn't create object file $file: $!";
123              
124 518         3068 $self->compile( comp_source => $source->comp_source_ref,
125             name => $source->friendly_name,
126             comp_class => $source->comp_class,
127             comp_path => $source->comp_path,
128             fh => $fh );
129              
130 502 50       19774 close $fh
131             or system_error "Couldn't close object file $file: $!";
132            
133 502         3394 return \@newfiles;
134             }
135              
136             sub _output_chunk
137             {
138 2125     2125   4011 my ($self, $fh, $string) = (shift, shift, shift);
139 2125 100       3850 if ($fh)
140             {
141 2013 50       14694 print $fh (ref $_ ? $$_ : $_) foreach grep defined, @_;
142             }
143             else
144             {
145 112 50       479 $$string .= (ref $_ ? $$_ : $_) foreach @_;
146             }
147             }
148              
149             # There are some really spooky relationships between the variables &
150             # data members in the compiled_component() routine.
151              
152             sub compiled_component
153             {
154 530     530 0 1507 my ($self, %p) = @_;
155 530         1138 my $c = $self->{current_compile};
156 530         1052 my $obj_text = '';
157              
158 530 100       862 local $c->{compiled_def} = $self->_compile_subcomponents if %{ $c->{def} };
  530         1620  
159 530 100       899 local $c->{compiled_method} = $self->_compile_methods if %{ $c->{method} };
  530         1537  
160              
161             # Some preamble stuff, including 'use strict', 'use vars', and <%once> block
162 530         1596 my $header = $self->_make_main_header;
163 530         2444 $self->_output_chunk($p{fh}, \$obj_text, $header);
164              
165 530         1773 my $params = $self->_component_params;
166              
167 530         1384 $params->{load_time} = time;
168              
169 530 100       843 $params->{subcomps} = '\%_def' if %{ $c->{def} };
  530         1406  
170 530 100       812 $params->{methods} = '\%_method' if %{ $c->{method} };
  530         1332  
171              
172 530 100       1301 if ( $self->_blocks('shared') )
173             {
174 11         20 my %subs;
175 11         20 while ( my ($name, $pref) = each %{ $c->{compiled_def} } )
  14         68  
176             {
177 3         9 my $key = "subcomponent_$name";
178 3         8 $subs{$key} = $pref->{code};
179 3         9 $pref->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic('$key',\@_)\n}";
180             }
181 11         25 while (my ($name, $pref) = each %{ $c->{compiled_method} } )
  15         56  
182             {
183 4         10 my $key = "method_$name";
184 4         13 $subs{$key} = $pref->{code};
185 4         13 $pref->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic( '$key', \@_ )\n}";
186             }
187 11         32 $subs{main} = $params->{code};
188 11         24 $params->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic( 'main', \@_ )\n}";
189              
190 11         22 my $named_subs = '';
191 11         37 my %named_subs = $self->_named_subs_hash;
192 11         46 while ( my ( $name, $body ) = each %named_subs )
193             {
194 2         26 $named_subs .= '*' . $name . " = sub {\n" . $body . "\n};\n\n";
195             }
196              
197             $params->{dynamic_subs_init} =
198 11         30 join '', ( "sub {\n",
199             $self->_set_request,
200             $self->_blocks('shared'),
201             $named_subs,
202             "return {\n",
203             map( "'$_' => $subs{$_},\n", sort keys %subs ),
204             "\n}\n}"
205             );
206             }
207             else
208             {
209 519         1458 my %named_subs = $self->_named_subs_hash;
210 519         2095 while ( my ( $name, $body ) = each %named_subs )
211             {
212 5         27 $self->_output_chunk( $p{fh}, \$obj_text,
213             "sub $name {\n" . $body . "\n}\n"
214             );
215             }
216             }
217              
218 530         1810 $self->_output_chunk($p{fh}, \$obj_text, $self->_subcomponents_footer);
219 530         1717 $self->_output_chunk($p{fh}, \$obj_text, $self->_methods_footer);
220              
221 530         2004 $self->_output_chunk($p{fh}, \$obj_text,
222             $self->_constructor( $self->comp_class,
223             $params ),
224             ';',
225             );
226              
227 530         5941 return \$obj_text;
228             }
229              
230             sub _named_subs_hash
231             {
232 530     530   895 my $self = shift;
233              
234 530 100       1262 return unless $self->named_component_subs;
235              
236 4         6 my %subs;
237 4         9 $subs{ $self->_sub_name } = $self->_body;
238              
239 4         8 while ( my ( $name, $params ) =
240 5         25 each %{ $self->{current_compile}{compiled_def} } )
241             {
242 1         4 $subs{ $self->_sub_name( 'def', $name ) } = $params->{body};
243             }
244              
245 4         7 while ( my ( $name, $params ) =
246 6         25 each %{ $self->{current_compile}{compiled_method} } )
247             {
248 2         6 $subs{ $self->_sub_name( 'method', $name ) } = $params->{body};
249             }
250              
251 4         18 return %subs;
252             }
253              
254             sub _sub_name
255             {
256 14     14   21 my $self = shift;
257              
258 14         38 return join '_', $self->_escape_sub_name_part( $self->{comp_path}, @_ );
259             }
260              
261             sub _escape_sub_name_part
262             {
263 14     14   20 my $self = shift;
264              
265 14         22 return map { my $part = $_;
  26         40  
266 26         76 $part =~ s/([^\w_])/'_' . sprintf( '%x', ord $1 )/ge;
  30         130  
267 26         103 $part; } @_;
268             }
269              
270             sub _compile_subcomponents
271             {
272 43     43   102 my $self = shift;
273              
274 43         159 return $self->_compile_subcomponents_or_methods('def');
275             }
276              
277             sub _compile_methods
278             {
279 36     36   65 my $self = shift;
280              
281 36         92 return $self->_compile_subcomponents_or_methods('method');
282             }
283              
284             sub _compile_subcomponents_or_methods
285             {
286 79     79   143 my $self = shift;
287 79         176 my $type = shift;
288              
289 79         126 my %compiled;
290 79         131 foreach ( keys %{ $self->{current_compile}{$type} } )
  79         339  
291             {
292 110         295 local $self->{current_compile} = $self->{current_compile}{$type}{$_};
293 110         376 local $self->{current_compile}->{in_named_block} = {type => $type, name => $_};
294 110         318 $compiled{$_} = $self->_component_params;
295             }
296              
297 79         296 return \%compiled;
298             }
299              
300             sub _make_main_header
301             {
302 530     530   882 my $self = shift;
303              
304 530         1613 my $pkg = $self->in_package;
305              
306 530 100       2110 return join '', ( "package $pkg;\n",
    100          
307             $self->use_strict ? "use strict;\n" : "no strict;\n",
308             $self->use_warnings ? "use warnings;\n" : "",
309             sprintf( "use vars qw(\%s);\n",
310             join ' ', '$m', $self->allow_globals ),
311             $self->_blocks('once'),
312             );
313             }
314              
315             sub _subcomponents_footer
316             {
317 530     530   857 my $self = shift;
318              
319 530         1457 return $self->_subcomponent_or_method_footer('def');
320             }
321              
322             sub _methods_footer
323             {
324 530     530   896 my $self = shift;
325              
326 530         1145 return $self->_subcomponent_or_method_footer('method');
327             }
328              
329             sub _subcomponent_or_method_footer
330             {
331 1060     1060   1458 my $self = shift;
332 1060         1682 my $c = $self->{current_compile};
333 1060         1594 my $type = shift;
334              
335 1060 100       1388 return '' unless %{ $c->{$type} };
  1060         3943  
336              
337             return join('',
338             "my %_$type =\n(\n",
339             map( {("'$_' => " ,
340             $self->_constructor( $self->{subcomp_class},
341 110         382 $c->{"compiled_$type"}{$_} ) ,
342 79         213 ",\n")} keys %{ $c->{"compiled_$type"} } ) ,
  79         311  
343             "\n);\n"
344             );
345             }
346              
347             sub _constructor
348             {
349 640     640   1443 my ($self, $class, $params) = @_;
350              
351             return ("${class}->new(\n",
352 1376         5414 map( {("'$_' => ", $params->{$_}, ",\n")}
353 640         2405 sort grep { $_ ne 'body' } keys %$params ),
  1383         4230  
354             "\n)\n",
355             );
356             }
357              
358             sub _component_params
359             {
360 640     640   1111 my $self = shift;
361              
362 640         973 my %params;
363              
364 640 100       1653 if ( $self->named_component_subs )
365             {
366             $params{code} =
367             '\\&' .
368             $self->_sub_name
369 14         38 ( grep { defined }
370 7         21 @{ $self->{current_compile}{in_named_block} }
371 7         15 { 'type', 'name' } );
372 7         18 $params{body} = $self->_body;
373             }
374             else
375             {
376 633         1736 $params{code} = join '', "sub {\n", $self->_body, "}";
377             }
378              
379             $params{flags} = join '', "{\n", $self->_flags, "\n}"
380 640 100       1269 if keys %{ $self->{current_compile}{flags} };
  640         2266  
381              
382             $params{attr} = join '', "{\n", $self->_attr, "\n}"
383 640 100       1069 if keys %{ $self->{current_compile}{attr} };
  640         1806  
384              
385             $params{declared_args} = join '', "{\n", $self->_declared_args, "\n}"
386 640 100       1011 if @{ $self->{current_compile}{args} };
  640         1643  
387              
388 640 100       1653 $params{has_filter} = 1 if $self->_blocks('filter');
389              
390 640         1664 return \%params;
391             }
392              
393             sub _body
394             {
395 644     644   1034 my $self = shift;
396              
397             return join '', ( $self->preamble,
398             $self->_set_request,
399             $self->_set_buffer,
400             $self->_arg_declarations,
401             $self->_filter,
402             "\$m->debug_hook( \$m->current_comp->path ) if ( HTML::Mason::Compiler::IN_PERL_DB() );\n\n",
403             $self->_blocks('init'),
404              
405             # do not add a block around this, it introduces
406             # a separate scope and might break cleanup
407             # blocks (or all sort of other things!)
408             $self->{current_compile}{body},
409              
410 644         1636 $self->_blocks('cleanup'),
411             $self->postamble,
412              
413             # semi before return will help catch syntax
414             # errors in component body - don't return values
415             # explicitly
416             ";return;\n",
417             );
418             }
419              
420             sub _set_request
421             {
422 655     655   1088 my $self = shift;
423              
424 655 100       1406 return if $self->in_package eq 'HTML::Mason::Commands';
425              
426 7         15 return 'local $' . $self->in_package . '::m = $HTML::Mason::Commands::m;' . "\n";
427             }
428              
429             sub _set_buffer
430             {
431 683     683   1153 my $self = shift;
432              
433 683 100       1583 if ($self->enable_autoflush) {
434 674         2211 return '';
435             } else {
436 9         24 return 'my $_outbuf = $m->{top_stack}->[HTML::Mason::Request::STACK_BUFFER];' . "\n";
437             }
438             }
439              
440             my %coercion_funcs = ( '@' => 'HTML::Mason::Tools::coerce_to_array',
441             '%' => 'HTML::Mason::Tools::coerce_to_hash',
442             );
443             sub _arg_declarations
444             {
445 644     644   1156 my $self = shift;
446              
447 644         2825 my $init;
448             my @args_hash;
449 644         0 my $pos;
450 644         0 my @req_check;
451 644         0 my @decl;
452 644         0 my @assign;
453              
454 644         1541 my $define_args_hash = $self->_define_args_hash;
455              
456 644 100       1153 unless ( @{ $self->{current_compile}{args} } )
  644         1736  
457             {
458 596 100       2218 return unless $define_args_hash;
459              
460 18         92 return ( "my \%ARGS;\n",
461             "{ local \$^W; \%ARGS = \@_ unless (\@_ % 2); }\n"
462             );
463             }
464              
465 48         140 $init = <<'EOF';
466             HTML::Mason::Exception::Params->throw
467             ( error =>
468             "Odd number of parameters passed to component expecting name/value pairs"
469             ) if @_ % 2;
470             EOF
471              
472 48 100       139 if ( $define_args_hash )
473             {
474 2         6 @args_hash = "my \%ARGS = \@_;\n";
475             }
476              
477             # opening brace will be closed later. we want this in a separate
478             # block so that the rest of the component can't see %pos
479 48         97 $pos = <<'EOF';
480             {
481             my %pos;
482             for ( my $x = 0; $x < @_; $x += 2 )
483             {
484             $pos{ $_[$x] } = $x + 1;
485             }
486             EOF
487              
488             my @required =
489 42         158 ( map { $_->{name} }
490 84         197 grep { ! defined $_->{default} }
491 48         86 @{ $self->{current_compile}{args} }
  48         126  
492             );
493              
494 48 100       157 if (@required)
495             {
496             # just to be sure
497 31         74 local $" = ' ';
498 31         158 @req_check = <<"EOF";
499              
500             foreach my \$arg ( qw( @required ) )
501             {
502             HTML::Mason::Exception::Params->throw
503             ( error => "no value sent for required parameter '\$arg'" )
504             unless exists \$pos{\$arg};
505             }
506             EOF
507             }
508              
509 48         89 foreach ( @{ $self->{current_compile}{args} } )
  48         139  
510             {
511 84         216 my $var_name = "$_->{type}$_->{name}";
512 84         159 push @decl, $var_name;
513              
514 84         222 my $arg_in_array = "\$_[ \$pos{'$_->{name}'} ]";
515              
516 84         118 my $coerce;
517 84 100       202 if ( $coercion_funcs{ $_->{type} } )
518             {
519 9         27 $coerce = $coercion_funcs{ $_->{type} } . "( $arg_in_array, '$var_name')";
520             }
521             else
522             {
523 75         134 $coerce = $arg_in_array;
524             }
525              
526 84 100 33     483 if ( defined $_->{line} && defined $_->{file} && $self->use_source_line_numbers )
      66        
527             {
528 78         205 my $file = $self->_escape_filename( $_->{file} );
529 78         299 push @assign, qq{#line $_->{line} "$file"\n};
530             }
531              
532 84 100       201 if ( defined $_->{default} )
533             {
534 42         84 my $default_val = $_->{default};
535             # allow for comments after default declaration
536 42 100 66     200 $default_val .= "\n" if defined $_->{default} && $_->{default} =~ /\#/;
537              
538 42         166 push @assign, <<"EOF";
539             $var_name = exists \$pos{'$_->{name}'} ? $coerce : $default_val;
540             EOF
541             }
542             else
543             {
544 42         142 push @assign,
545             " $var_name = $coerce;\n";
546             }
547             }
548              
549 48         108 my $decl = 'my ( ';
550 48         129 $decl .= join ', ', @decl;
551 48         79 $decl .= " );\n";
552              
553             # closing brace closes opening of @pos
554 48         298 return $init, @args_hash, $decl, $pos, @req_check, @assign, "}\n";
555             }
556              
557             sub _define_args_hash
558             {
559 644     644   1053 my $self = shift;
560              
561 644 100       1523 return 1 if $self->define_args_hash eq 'always';
562 643 100       1557 return 0 if $self->define_args_hash eq 'never';
563              
564 641         1489 foreach ( $self->preamble,
565             $self->_blocks('filter'),
566             $self->_blocks('init'),
567             $self->{current_compile}{body},
568             $self->_blocks('cleanup'),
569             $self->postamble,
570 84         199 grep { defined } map { $_->{default} } @{ $self->{current_compile}{args} }
  84         201  
  641         1909  
571             )
572             {
573 2048 100       5384 return 1 if /ARGS/;
574             }
575             }
576              
577             sub _filter
578             {
579 644     644   1070 my $self = shift;
580              
581 644         1162 my @filter;
582 644 100       1523 @filter = $self->_blocks('filter')
583             or return;
584              
585 29         158 return ( join '',
586             "\$m->current_comp->filter( sub { local \$_ = shift;\n",
587             ( join ";\n", @filter ),
588             ";\n",
589             "return \$_;\n",
590             "} );\n",
591             );
592              
593             }
594              
595             sub _flags
596             {
597 19     19   34 my $self = shift;
598              
599 19         55 return $self->_flags_or_attr('flags');
600             }
601              
602             sub _attr
603             {
604 20     20   37 my $self = shift;
605              
606 20         54 return $self->_flags_or_attr('attr');
607             }
608              
609             sub _flags_or_attr
610             {
611 39     39   60 my $self = shift;
612 39         78 my $type = shift;
613              
614 62         264 return join "\n,", ( map { "$_ => $self->{current_compile}{$type}{$_}" }
615 39         58 keys %{ $self->{current_compile}{$type} } );
  39         109  
616             }
617              
618             sub _declared_args
619             {
620 48     48   96 my $self = shift;
621              
622 48         82 my @args;
623              
624 48         89 foreach my $arg ( sort {"$a->{type}$a->{name}" cmp "$b->{type}$b->{name}" }
  49         167  
625 48         260 @{ $self->{current_compile}{args} } )
626             {
627 84 100       242 my $def = defined $arg->{default} ? "$arg->{default}" : 'undef';
628 84         213 $def =~ s,([\\']),\\$1,g;
629 84 100       255 $def = "'$def'" unless $def eq 'undef';
630              
631 84         323 push @args, " '$arg->{type}$arg->{name}' => { default => $def }";
632             }
633              
634 48         214 return join ",\n", @args;
635             }
636              
637             1;
638              
639             __END__