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.59';
7 30     30   2888 use strict;
  30         65  
  30         1151  
8 30     30   182 use warnings;
  30         61  
  30         1353  
9              
10 30     30   219 use Params::Validate qw(BOOLEAN SCALAR validate);
  30         69  
  30         3575  
11 30     30   210 use HTML::Mason::Tools qw(taint_is_on);
  30         62  
  30         2128  
12              
13 30     30   17709 use HTML::Mason::Compiler;
  30         83  
  30         1045  
14 30     30   213 use base qw( HTML::Mason::Compiler );
  30         62  
  30         3182  
15              
16 30     30   213 use HTML::Mason::Exceptions( abbr => [qw(wrong_compiler_error system_error)] );
  30         76  
  30         167  
17              
18 30     30   228 use File::Path qw(mkpath rmtree);
  30         91  
  30         2774  
19 30     30   225 use File::Basename qw(dirname);
  30         79  
  30         6858  
20              
21             BEGIN
22             {
23 30     30   929 __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         218 ( 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   6115 );
  30         64  
78              
79             sub compile
80             {
81 547     547 1 1036 my $self = shift;
82 547         2653 my %p = @_;
83              
84 547 100       2400 local $self->{comp_class} = delete $p{comp_class} if exists $p{comp_class};
85 547         2891 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 973 my $self = shift;
100              
101 518         13850 my %p = validate( @_, { file => { type => SCALAR },
102             source => { isa => 'HTML::Mason::ComponentSource' } },
103             );
104              
105 518         3245 my ($file, $source) = @p{qw(file source)};
106 518         1251 my @newfiles = ($file);
107              
108 518 100 66     8815 if (defined $file && !-f $file) {
109 504         22352 my ($dirname) = dirname($file);
110 504 100       8712 if (!-d $dirname) {
111 99 50       403 unlink($dirname) if (-e _);
112 99         19555 push @newfiles, mkpath($dirname, 0, 0775);
113 99 50       1968 system_error "Couldn't create directory $dirname: $!"
114             unless -d $dirname;
115             }
116 504 50       6786 rmtree($file) if (-d $file);
117             }
118              
119 518 100       2482 ($file) = $file =~ /^(.*)/s if taint_is_on; # Untaint blindly
120              
121 518 50       32579 open my $fh, "> $file"
122             or system_error "Couldn't create object file $file: $!";
123              
124 518         3660 $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       20825 close $fh
131             or system_error "Couldn't close object file $file: $!";
132            
133 502         4506 return \@newfiles;
134             }
135              
136             sub _output_chunk
137             {
138 2125     2125   3963 my ($self, $fh, $string) = (shift, shift, shift);
139 2125 100       3815 if ($fh)
140             {
141 2013 50       23830 print $fh (ref $_ ? $$_ : $_) foreach grep defined, @_;
142             }
143             else
144             {
145 112 50       574 $$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 1442 my ($self, %p) = @_;
155 530         995 my $c = $self->{current_compile};
156 530         1089 my $obj_text = '';
157              
158 530 100       825 local $c->{compiled_def} = $self->_compile_subcomponents if %{ $c->{def} };
  530         1444  
159 530 100       797 local $c->{compiled_method} = $self->_compile_methods if %{ $c->{method} };
  530         1269  
160              
161             # Some preamble stuff, including 'use strict', 'use vars', and <%once> block
162 530         1393 my $header = $self->_make_main_header;
163 530         1955 $self->_output_chunk($p{fh}, \$obj_text, $header);
164              
165 530         1919 my $params = $self->_component_params;
166              
167 530         1330 $params->{load_time} = time;
168              
169 530 100       835 $params->{subcomps} = '\%_def' if %{ $c->{def} };
  530         1413  
170 530 100       779 $params->{methods} = '\%_method' if %{ $c->{method} };
  530         1268  
171              
172 530 100       1272 if ( $self->_blocks('shared') )
173             {
174 11         21 my %subs;
175 11         22 while ( my ($name, $pref) = each %{ $c->{compiled_def} } )
  14         69  
176             {
177 3         7 my $key = "subcomponent_$name";
178 3         9 $subs{$key} = $pref->{code};
179 3         11 $pref->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic('$key',\@_)\n}";
180             }
181 11         25 while (my ($name, $pref) = each %{ $c->{compiled_method} } )
  15         65  
182             {
183 4         13 my $key = "method_$name";
184 4         13 $subs{$key} = $pref->{code};
185 4         14 $pref->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic( '$key', \@_ )\n}";
186             }
187 11         36 $subs{main} = $params->{code};
188 11         46 $params->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic( 'main', \@_ )\n}";
189              
190 11         28 my $named_subs = '';
191 11         31 my %named_subs = $self->_named_subs_hash;
192 11         44 while ( my ( $name, $body ) = each %named_subs )
193             {
194 2         24 $named_subs .= '*' . $name . " = sub {\n" . $body . "\n};\n\n";
195             }
196              
197             $params->{dynamic_subs_init} =
198 11         34 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         1253 my %named_subs = $self->_named_subs_hash;
210 519         1981 while ( my ( $name, $body ) = each %named_subs )
211             {
212 5         35 $self->_output_chunk( $p{fh}, \$obj_text,
213             "sub $name {\n" . $body . "\n}\n"
214             );
215             }
216             }
217              
218 530         1581 $self->_output_chunk($p{fh}, \$obj_text, $self->_subcomponents_footer);
219 530         1593 $self->_output_chunk($p{fh}, \$obj_text, $self->_methods_footer);
220              
221 530         1836 $self->_output_chunk($p{fh}, \$obj_text,
222             $self->_constructor( $self->comp_class,
223             $params ),
224             ';',
225             );
226              
227 530         6115 return \$obj_text;
228             }
229              
230             sub _named_subs_hash
231             {
232 530     530   856 my $self = shift;
233              
234 530 100       1183 return unless $self->named_component_subs;
235              
236 4         8 my %subs;
237 4         13 $subs{ $self->_sub_name } = $self->_body;
238              
239 4         10 while ( my ( $name, $params ) =
240 5         38 each %{ $self->{current_compile}{compiled_def} } )
241             {
242 1         5 $subs{ $self->_sub_name( 'def', $name ) } = $params->{body};
243             }
244              
245 4         10 while ( my ( $name, $params ) =
246 6         27 each %{ $self->{current_compile}{compiled_method} } )
247             {
248 2         6 $subs{ $self->_sub_name( 'method', $name ) } = $params->{body};
249             }
250              
251 4         20 return %subs;
252             }
253              
254             sub _sub_name
255             {
256 14     14   30 my $self = shift;
257              
258 14         45 return join '_', $self->_escape_sub_name_part( $self->{comp_path}, @_ );
259             }
260              
261             sub _escape_sub_name_part
262             {
263 14     14   24 my $self = shift;
264              
265 14         24 return map { my $part = $_;
  26         47  
266 26         97 $part =~ s/([^\w_])/'_' . sprintf( '%x', ord $1 )/ge;
  30         160  
267 26         118 $part; } @_;
268             }
269              
270             sub _compile_subcomponents
271             {
272 43     43   96 my $self = shift;
273              
274 43         125 return $self->_compile_subcomponents_or_methods('def');
275             }
276              
277             sub _compile_methods
278             {
279 36     36   76 my $self = shift;
280              
281 36         151 return $self->_compile_subcomponents_or_methods('method');
282             }
283              
284             sub _compile_subcomponents_or_methods
285             {
286 79     79   149 my $self = shift;
287 79         245 my $type = shift;
288              
289 79         151 my %compiled;
290 79         125 foreach ( keys %{ $self->{current_compile}{$type} } )
  79         359  
291             {
292 110         317 local $self->{current_compile} = $self->{current_compile}{$type}{$_};
293 110         369 local $self->{current_compile}->{in_named_block} = {type => $type, name => $_};
294 110         307 $compiled{$_} = $self->_component_params;
295             }
296              
297 79         397 return \%compiled;
298             }
299              
300             sub _make_main_header
301             {
302 530     530   871 my $self = shift;
303              
304 530         1342 my $pkg = $self->in_package;
305              
306 530 100       1776 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   827 my $self = shift;
318              
319 530         1205 return $self->_subcomponent_or_method_footer('def');
320             }
321              
322             sub _methods_footer
323             {
324 530     530   863 my $self = shift;
325              
326 530         1023 return $self->_subcomponent_or_method_footer('method');
327             }
328              
329             sub _subcomponent_or_method_footer
330             {
331 1060     1060   1441 my $self = shift;
332 1060         1568 my $c = $self->{current_compile};
333 1060         1653 my $type = shift;
334              
335 1060 100       1713 return '' unless %{ $c->{$type} };
  1060         3922  
336              
337             return join('',
338             "my %_$type =\n(\n",
339             map( {("'$_' => " ,
340             $self->_constructor( $self->{subcomp_class},
341 110         375 $c->{"compiled_$type"}{$_} ) ,
342 79         233 ",\n")} keys %{ $c->{"compiled_$type"} } ) ,
  79         349  
343             "\n);\n"
344             );
345             }
346              
347             sub _constructor
348             {
349 640     640   1364 my ($self, $class, $params) = @_;
350              
351             return ("${class}->new(\n",
352 1376         5746 map( {("'$_' => ", $params->{$_}, ",\n")}
353 640         2227 sort grep { $_ ne 'body' } keys %$params ),
  1383         3839  
354             "\n)\n",
355             );
356             }
357              
358             sub _component_params
359             {
360 640     640   1160 my $self = shift;
361              
362 640         987 my %params;
363              
364 640 100       1653 if ( $self->named_component_subs )
365             {
366             $params{code} =
367             '\\&' .
368             $self->_sub_name
369 14         40 ( grep { defined }
370 7         24 @{ $self->{current_compile}{in_named_block} }
371 7         11 { 'type', 'name' } );
372 7         25 $params{body} = $self->_body;
373             }
374             else
375             {
376 633         1477 $params{code} = join '', "sub {\n", $self->_body, "}";
377             }
378              
379             $params{flags} = join '', "{\n", $self->_flags, "\n}"
380 640 100       1458 if keys %{ $self->{current_compile}{flags} };
  640         2190  
381              
382             $params{attr} = join '', "{\n", $self->_attr, "\n}"
383 640 100       996 if keys %{ $self->{current_compile}{attr} };
  640         2056  
384              
385             $params{declared_args} = join '', "{\n", $self->_declared_args, "\n}"
386 640 100       976 if @{ $self->{current_compile}{args} };
  640         1669  
387              
388 640 100       1513 $params{has_filter} = 1 if $self->_blocks('filter');
389              
390 640         1748 return \%params;
391             }
392              
393             sub _body
394             {
395 644     644   996 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         1536 $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   1021 my $self = shift;
423              
424 655 100       1326 return if $self->in_package eq 'HTML::Mason::Commands';
425              
426 7         20 return 'local $' . $self->in_package . '::m = $HTML::Mason::Commands::m;' . "\n";
427             }
428              
429             sub _set_buffer
430             {
431 683     683   1187 my $self = shift;
432              
433 683 100       1578 if ($self->enable_autoflush) {
434 674         2079 return '';
435             } else {
436 9         29 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   1018 my $self = shift;
446              
447 644         2755 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         1536 my $define_args_hash = $self->_define_args_hash;
455              
456 644 100       1117 unless ( @{ $self->{current_compile}{args} } )
  644         1737  
457             {
458 596 100       2102 return unless $define_args_hash;
459              
460 18         103 return ( "my \%ARGS;\n",
461             "{ local \$^W; \%ARGS = \@_ unless (\@_ % 2); }\n"
462             );
463             }
464              
465 48         238 $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       192 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         129 $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         127 ( map { $_->{name} }
490 84         210 grep { ! defined $_->{default} }
491 48         156 @{ $self->{current_compile}{args} }
  48         132  
492             );
493              
494 48 100       150 if (@required)
495             {
496             # just to be sure
497 31         93 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         87 foreach ( @{ $self->{current_compile}{args} } )
  48         140  
510             {
511 84         195 my $var_name = "$_->{type}$_->{name}";
512 84         150 push @decl, $var_name;
513              
514 84         216 my $arg_in_array = "\$_[ \$pos{'$_->{name}'} ]";
515              
516 84         121 my $coerce;
517 84 100       218 if ( $coercion_funcs{ $_->{type} } )
518             {
519 9         28 $coerce = $coercion_funcs{ $_->{type} } . "( $arg_in_array, '$var_name')";
520             }
521             else
522             {
523 75         117 $coerce = $arg_in_array;
524             }
525              
526 84 100 33     605 if ( defined $_->{line} && defined $_->{file} && $self->use_source_line_numbers )
      66        
527             {
528 78         218 my $file = $self->_escape_filename( $_->{file} );
529 78         315 push @assign, qq{#line $_->{line} "$file"\n};
530             }
531              
532 84 100       211 if ( defined $_->{default} )
533             {
534 42         82 my $default_val = $_->{default};
535             # allow for comments after default declaration
536 42 100 66     251 $default_val .= "\n" if defined $_->{default} && $_->{default} =~ /\#/;
537              
538 42         205 push @assign, <<"EOF";
539             $var_name = exists \$pos{'$_->{name}'} ? $coerce : $default_val;
540             EOF
541             }
542             else
543             {
544 42         158 push @assign,
545             " $var_name = $coerce;\n";
546             }
547             }
548              
549 48         155 my $decl = 'my ( ';
550 48         146 $decl .= join ', ', @decl;
551 48         129 $decl .= " );\n";
552              
553             # closing brace closes opening of @pos
554 48         307 return $init, @args_hash, $decl, $pos, @req_check, @assign, "}\n";
555             }
556              
557             sub _define_args_hash
558             {
559 644     644   935 my $self = shift;
560              
561 644 100       1435 return 1 if $self->define_args_hash eq 'always';
562 643 100       1588 return 0 if $self->define_args_hash eq 'never';
563              
564 641         1468 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         1668  
571             )
572             {
573 2048 100       5499 return 1 if /ARGS/;
574             }
575             }
576              
577             sub _filter
578             {
579 644     644   1052 my $self = shift;
580              
581 644         927 my @filter;
582 644 100       1388 @filter = $self->_blocks('filter')
583             or return;
584              
585 29         157 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   40 my $self = shift;
598              
599 19         62 return $self->_flags_or_attr('flags');
600             }
601              
602             sub _attr
603             {
604 20     20   32 my $self = shift;
605              
606 20         46 return $self->_flags_or_attr('attr');
607             }
608              
609             sub _flags_or_attr
610             {
611 39     39   60 my $self = shift;
612 39         103 my $type = shift;
613              
614 62         282 return join "\n,", ( map { "$_ => $self->{current_compile}{$type}{$_}" }
615 39         71 keys %{ $self->{current_compile}{$type} } );
  39         119  
616             }
617              
618             sub _declared_args
619             {
620 48     48   114 my $self = shift;
621              
622 48         84 my @args;
623              
624 48         88 foreach my $arg ( sort {"$a->{type}$a->{name}" cmp "$b->{type}$b->{name}" }
  49         203  
625 48         287 @{ $self->{current_compile}{args} } )
626             {
627 84 100       316 my $def = defined $arg->{default} ? "$arg->{default}" : 'undef';
628 84         247 $def =~ s,([\\']),\\$1,g;
629 84 100       231 $def = "'$def'" unless $def eq 'undef';
630              
631 84         371 push @args, " '$arg->{type}$arg->{name}' => { default => $def }";
632             }
633              
634 48         295 return join ",\n", @args;
635             }
636              
637             1;
638              
639             __END__