File Coverage

blib/lib/Catalyst/View/ByCode/Renderer.pm
Criterion Covered Total %
statement 226 302 74.8
branch 49 96 51.0
condition 28 70 40.0
subroutine 38 51 74.5
pod 0 19 0.0
total 341 538 63.3


line stmt bran cond sub pod time code
1             package Catalyst::View::ByCode::Renderer;
2             $Catalyst::View::ByCode::Renderer::VERSION = '0.26';
3 3     3   58894 use strict;
  3         7  
  3         85  
4 3     3   17 use warnings;
  3         3  
  3         85  
5 3     3   13 use base qw(Exporter);
  3         8  
  3         205  
6              
7 3     3   1414 use Devel::Declare();
  3         23433  
  3         74  
8 3     3   1426 use Catalyst::View::ByCode::Declare;
  3         9  
  3         104  
9 3     3   18 use Scalar::Util 'blessed';
  3         4  
  3         180  
10 3     3   1725 use HTML::Tagset;
  3         3080  
  3         1049  
11             # use HTML::Entities; ### TODO: think about -- but pollutes our namespaces
12              
13             our @EXPORT_OK = qw(clear_markup init_markup get_markup);
14              
15             our @EXPORT = qw(template block block_content
16             load
17             yield
18             params
19             attr
20             class id on
21             stash c _
22             doctype boilerplate
23             nbsp
24             );
25             our %EXPORT_TAGS = (
26             markup => [ qw(clear_markup init_markup get_markup) ],
27             default => [ @EXPORT ],
28             );
29              
30             our @IS_KNOWN = (
31             # HTML5 tags not defined in HTML::Tagset
32             qw( article aside audio
33             bdi bdo
34             canvas
35             data datalist details dialog
36             figcaption figure footer
37             header
38             keygen
39             main mark markup menu menuitem meter
40             nav
41             output
42             progress
43             rd rp rt ruby
44             section source summary
45             time track
46             video ),
47             grep { m{\A \w}xms }
48             keys(%HTML::Tagset::isKnown)
49             );
50              
51             our %EMPTY_ELEMENT = (
52             (
53             map { ($_=>1) }
54             qw(source) ### FIXME: more needed!!!
55             ),
56             %HTML::Tagset::emptyElement
57             );
58              
59             #
60             # define variables -- get local() ized at certain positions
61             #
62             our @m; # whole content: initialized with &init_markup()
63             our @top = ( \@m ); # contains open tags
64             our $stash; # current stash
65             our $c; # current context
66             our $view; # ByCode View instance
67             our $block_content; # code for executing &content()
68              
69             #
70             # some constants
71             #
72             our $NEED_ESCAPE = qr{[\"<>&\x{0000}-\x{001f}\x{007f}-\x{ffff}]};
73              
74             #
75             # some tags get changed by simply renaming them
76             #
77             # 'html tag' 'sub name'
78             our %change_tags = ('select' => 'choice',
79             'link' => 'link_tag',
80             'tr' => 'trow',
81             'td' => 'tcol',
82             'sub' => 'subscript',
83             'sup' => 'superscript',
84             'meta' => 'meta_tag', # Moose needs &meta()...
85             'q' => 'quote',
86             's' => 'strike',
87             'map' => 'map_tag',
88             );
89              
90             ######################################## IMPORT
91             #
92             # just importing this module...
93             #
94             sub import {
95 3     3   40 my $module = shift; # eat off 'Catalyst::View::ByCode::Renderer';
96              
97 3         13 my $calling_package = caller;
98              
99 3         46 my $default_export = grep {$_ eq ':default'} @_;
  3         9  
100              
101             #
102             # do Exporter's Job on Catalyst::View::ByCode::Renderer's @EXPORT
103             #
104 3         4 $module->export_to_level(1, $module, grep {!ref $_} @_);
  3         548  
105              
106             #
107             # overwrite (or create) &import in calling_package which
108             # - auto-imports all block() directives
109             # - adds a Devel::Declare-setup for every block() directive
110             #
111 3 100 66     35 if ($default_export && !UNIVERSAL::can($calling_package, '_import')) {
112 3     3   13 no strict 'refs';
  3         4  
  3         289  
113              
114             # save original -- in doubt use Exporter::import
115 2         11 local *_old_import = (*{"$calling_package\::import"}{CODE})
  0         0  
116 2         11 ? *{"$calling_package\::import"}
117 2 50       3 : *{"Exporter::import"};
118              
119 2         4 *{"$calling_package\::_import"} = *_old_import;
  2         5  
120 2         3 *{"$calling_package\::import"} = \&overloaded_import;
  2         5  
121             }
122              
123             #
124             # build HTML Tag-subs into caller's namespace
125             #
126 3 100       13 _construct_functions($calling_package)
127             if ($default_export);
128              
129             #
130             # create *OUT and *RAW in calling package to allow 'print' to work
131             # 'print OUT' works, Components use a 'select OUT' to allow 'print' alone
132             #
133 3     3   11 no strict 'refs';
  3         3  
  3         437  
134 3 100 66     1332 if ($default_export || !scalar(@_)) {
135 2         2 tie *{"$calling_package\::OUT"}, $module, 1; # escaped: OUT
  2         20  
136 2         2 tie *{"$calling_package\::RAW"}, $module, 0; # unescaped: RAW
  2         8  
137 2         2 tie *{"$calling_package\::STDOUT"}, $module, 1; # escaped: STDOUT
  2         5  
138              
139             # stupid hack to make -w happy ;-)
140 2         4 my $dummy0 = *{"$calling_package\::OUT"};
  2         4  
141 2         1 my $dummy1 = *{"$calling_package\::RAW"};
  2         5  
142 2         2 my $dummy2 = *{"$calling_package\::STDOUT"};
  2         32  
143             }
144             }
145              
146             #
147             # our importing packages' import() routine...
148             #
149             sub overloaded_import {
150 0     0 0 0 my $imported_package = $_[0];
151 0         0 my $calling_package = caller;
152              
153 3     3   11 no strict 'refs';
  3         3  
  3         1362  
154              
155 0 0       0 if (scalar(@{"$imported_package\::EXPORT_BLOCK"})) {
  0         0  
156             #
157             # process every recorded block() directive
158             #
159 0         0 my %declare;
160              
161 0         0 foreach my $symbol (@{"$imported_package\::EXPORT_BLOCK"}) {
  0         0  
162             ### FIXME: aliasing makes trouble in case of overwriting !!!!!
163 0         0 *{"$calling_package\::$symbol"} = *{"$imported_package\::$symbol"};
  0         0  
  0         0  
164             # *{"$calling_package\::$symbol"} = eval qq{ sub { goto $imported_package\::$symbol } };
165             # *{"$calling_package\::$symbol"} = eval qq{ sub { $imported_package\::$symbol(\@_) } };
166              
167 0         0 $declare{$symbol} = {
168             const => Catalyst::View::ByCode::Declare::tag_parser
169             };
170             }
171              
172 0 0       0 if (scalar(keys(%declare))) {
173 0         0 Devel::Declare->setup_for($calling_package, \%declare);
174             }
175             }
176              
177             #
178             # proceed with the original import
179             #
180 0         0 goto &{"$imported_package\::_import"};
  0         0  
181             }
182              
183             ######################################## FILE HANDLE MANAGEMENT
184             #
185             # IN/OUT stuff using a tied thing
186             #
187             sub TIEHANDLE {
188 6     6   7 my $class = shift; # my class (Catalyst::View::ByCode::Renderer)
189 6         6 my $handle = shift; # escaping on or off -- use this scalar as a handle
190             # and its value to decide escaping
191             # -- see PRINT below
192              
193 6         14 return bless \$handle, $class;
194             }
195              
196             sub PRINT {
197 7     7   125 my $handle = shift;
198              
199 7         17 push @{$top[-1]},
200             map {
201 7         8 blessed($_) && $_->can('render')
202             ? $_->render()
203             : $$handle
204 7 100 66     65 ? do { my $text = "$_";
  2 100       5  
205 2         51 $text =~ s{($NEED_ESCAPE)}{'&#' . ord($1) . ';'}oexmsg;
  3         10  
206 2         7 $text; }
207             : "$_"
208             }
209             @_;
210 7         32 return;
211             }
212              
213 0     0   0 sub PRINTF { $_[0]->PRINT(sprintf(@_[1..$#_])) }
214              
215             ######################################## MARKUP
216             #
217             #
218             #
219             sub clear_markup {
220 24     24 0 71 @m = ();
221 24         48 @top = ( \@m );
222 24         24 undef $c;
223 24         26 undef $stash;
224 24         29 undef $view;
225             }
226              
227             sub init_markup {
228 19     19 0 3369 clear_markup();
229              
230 19         18 $view = shift;
231 19         19 $c = shift;
232 19 50 33     103 $stash = $c && $c->can('stash')
233             ? $c->stash
234             : {}; # primitive fallback
235             }
236              
237 53     53 0 830 sub get_markup { _render(@m) }
238              
239             sub _render {
240 3     3   14 no warnings 'uninitialized'; # we might have undef sometimes
  3         3  
  3         1443  
241              
242             join ('',
243             map {
244 84     84   160 ref($_) eq 'ARRAY'
245             # a Tag is [ 'tag', {attrs}, content, ... ]
246 128 100       496 ? do {
247 31         41 my $attr = $_->[1];
248              
249 31         55 $_->[0]
250             # tag structure is named => <tag ...>
251             ? "<$_->[0]" .
252             # render attribute(s)
253             join('',
254             map {
255 28         114 my $k = $_;
256 31         33 my $v = $attr->{$k};
257              
258 31 100 33     516 if (!defined $v) {
    50 33        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
259 2         8 " $k";
260             } elsif ($k eq 'autofocus' ||
261             $k eq 'checked' ||
262             $k eq 'disabled' ||
263             $k eq 'formnovalidate' ||
264             $k eq 'hidden' ||
265             $k eq 'inert' ||
266             $k eq 'multiple' ||
267             $k eq 'novalidate' ||
268             $k eq 'readonly' ||
269             $k eq 'selected' ||
270             $k eq 'required') {
271             # special handling for magic names that require magic values
272 0 0       0 $v ? qq{ $k="$k"} : '';
273             } else {
274             # not a special attribute name
275 29 100       57 if (ref $v eq 'SCALAR') {
    100          
276 1         4 $v = $$v;
277             } elsif (ref $v) {
278             # handle ref values differently
279 2         5 $v = ref $v eq 'ARRAY'
280 1         2 ? join(' ', @{$v})
281             : ref $v eq 'HASH'
282             ? join(';',
283 1         3 map { my $k = $_;
284 1         5 $k =~ s{([A-Z])|_}{-\l$1}oxmsg;
285 1         5 "$k:$v->{$_}" }
286 4 50       19 keys %{$v})
    100          
    100          
287             : ref $v eq 'CODE'
288             ? $v->()
289             : "$v";
290 4         49 $v =~ s{($NEED_ESCAPE)}{'&#' . ord($1) . ';'}oexmsg;
  2         8  
291             } else {
292 24         84 $v =~ s{($NEED_ESCAPE)}{'&#' . ord($1) . ';'}oexmsg;
  2         5  
293             }
294              
295             # convert key into dash-separaed version,
296             # dataId -> data-id, data_id => data-id
297 29         103 $k =~ s{([A-Z])|_}{-\l$1}oxmsg;
298              
299             # compose attr="value"
300 29         139 qq{ $k="$v"};
301             }
302             }
303             sort # not needed but nice for testing/guessing
304 28         58 keys %{$attr}
305             ) .
306              
307             # closing tag or content?
308             (exists($EMPTY_ELEMENT{$_->[0]})
309             ? ' />'
310             : '>' .
311 3         23 _render(@{$_}[2 .. $#$_]) .
312             "</$_->[0]>")
313              
314             # tag is unnamed -- just render content
315 31 50       71 : _render(@{$_}[2 .. $#$_])
    100          
316             }
317              
318             # everything else is stringified
319             : "$_"
320             } @_);
321             }
322              
323             ######################################## EXPORTED FUNCTIONS
324             #
325             # a template definition instead of sub RUN {}
326             #
327             sub template(&) {
328 1     1 0 22 my $package = caller;
329              
330 1         35 my $code = shift;
331 3     3   14 no strict 'refs';
  3         3  
  3         351  
332 1         4 *{"$package\::RUN"} = sub {
333 1     1   18 push @{$top[-1]}, [ '', {} ];
  1         4  
334              
335 1         2 push @top, $top[-1]->[-1];
336              
337 1         3 my $text = $code->();
338 1 50 33     8 if (ref($text) && UNIVERSAL::can($text, 'render')) {
339 0         0 push @{$top[-1]}, $text->render;
  0         0  
340             } else {
341 3     3   13 no warnings 'uninitialized'; # we might see undef values
  3         4  
  3         451  
342 1         21 $text =~ s{($NEED_ESCAPE)}{'&#' . ord($1) . ';'}oexmsg;
  0         0  
343 1         1 push @{$top[-1]}, $text;
  1         4  
344             }
345              
346 1         1 pop @top;
347 1         4 return;
348 1         6 };
349              
350 1         3 return;
351             }
352              
353             #
354             # a block definition
355             #
356             sub block($&;@) {
357 1     1 0 82 my $name = shift;
358 1         2 my $code = shift;
359              
360 1         5 my $package = caller;
361              
362 3     3   11 no strict 'refs';
  3         4  
  3         73  
363 3     3   10 no warnings 'redefine';
  3         3  
  3         2039  
364              
365             #
366             # generate a sub in our namespace
367             #
368 1         7 *{"$package\::$name"} = sub(;&@) {
369 1     1   3 local $block_content = $_[0];
370              
371 1         2 push @{$top[-1]}, [ '', { @_[1 .. $#_] } ];
  1         4  
372              
373 1 50       3 if ($code) {
374 1         2 push @top, $top[-1]->[-1];
375 1         1 push @{$top[-1]}, $code->();
  1         20  
376 1         4 pop @top;
377             }
378              
379 1         2 return;
380 1         31 };
381              
382             #
383             # mark this sub as a special exportable
384             #
385 1         2 ${"$package\::EXPORT_BLOCK"}{$name} = 1;
  1         15  
386             }
387              
388             #
389             # execute a block's content
390             #
391             sub block_content {
392 0 0   0 0 0 push @{$top[-1]}, $block_content->(@_) if ($block_content);
  0         0  
393 0         0 return;
394             }
395              
396             #
397             # a simple shortcut for multiple param(name => ..., value => ...) sequences
398             #
399             sub params {
400 0     0 0 0 my %params = @_;
401              
402 0         0 while (my ($name, $value) = each %params) {
403 0         0 push @{$top[-1]}, [ 'param', { name => $name, value => $value } ];
  0         0  
404             }
405              
406 0         0 return;
407             }
408              
409             #
410             # a simple shortcut for css/js handling
411             # usage:
412             # load js => '/url/to/file.js';
413             # load css => '/url/to/file.js';
414             #
415             # load <<Controller_name>> => file_name [.js]
416             #
417             ### FIXME: build more logic into load() -- accumulate calls
418             ### and resolve as late as possible
419             #
420             sub load {
421 0     0 0 0 my $kind = shift;
422              
423 0 0 0     0 return if (!$kind || ref($kind));
424              
425 0 0 0     0 if ($kind eq 'css') {
    0 0        
    0          
426             #
427             # simple static CSS inserted just here and now
428             #
429 0         0 push @{$top[-1]},
  0         0  
430 0         0 map { [ 'link',
431             {
432             rel => 'stylesheet',
433             type => 'text/css',
434             href => $_
435             }
436             ] } @_;
437             } elsif ($kind eq 'js') {
438             #
439             # simple static JS inserted just here and now
440             #
441 0         0 push @{$top[-1]},
  0         0  
442 0         0 map { [ 'script',
443             {
444             type => 'text/javascript',
445             src => $_
446             }
447             ] } @_;
448             } elsif ((my $controller = $c->controller($kind)) &&
449             ($kind eq 'Js' || $kind eq 'Css')) {
450             ### FIXME: are Hardcoded controller names wise???
451             #
452             # some other kind of load operation we have a controller for
453             #
454             # $c->log->debug("LOAD: kind=$kind, ref(controller)=" . ref($controller));
455              
456 0 0       0 if ($kind eq 'Css') {
457 0         0 push @{$top[-1]},
  0         0  
458             [ 'link',
459             {
460             rel => 'stylesheet',
461             type => 'text/css',
462             href =>$c->uri_for($controller->action_for('default'), @_)
463             }
464             ];
465             } else {
466 0         0 push @{$top[-1]},
  0         0  
467             [ 'script',
468             {
469             type => 'text/javascript',
470             src => $c->uri_for($controller->action_for('default'), @_)
471             }
472             ];
473             }
474             }
475              
476 0         0 return;
477             }
478              
479             #
480             # a special sub-rendering command like Rails ;-)
481             #
482             # yield \&name_of_a_sub;
483             # yield a_named_yield;
484             # yield 'content';
485             # yield; # same as 'content'
486             # yield 'path/to/template.pl'
487             # ### TODO: yield package::subname
488             # ### TODO: yield +package::package::package::subname
489             #
490             sub yield(;*@) {
491 0   0 0 0 0 my $yield_name = shift || 'content';
492              
493 0 0       0 $c->log->debug("yield '$yield_name' executing...") if $c->debug;
494              
495 0 0       0 _yield(exists($c->stash->{yield}->{$yield_name})
    0          
496             ? $c->stash->{yield}->{$yield_name}
497             : $yield_name)
498             or $c->log->info("could not yield '$yield_name'");
499              
500 0         0 return;
501             }
502              
503             # helper for recursive resolution
504             sub _yield {
505 0     0   0 my $thing = shift;
506              
507 0 0       0 if (!$thing) {
    0          
    0          
    0          
508 0         0 return;
509             } elsif (ref($thing) eq 'ARRAY') {
510 0         0 my $result;
511 0         0 while (my $x = shift(@{$thing})) {
  0         0  
512 0 0       0 _yield($x) and $result = 1;
513             }
514 0         0 return $result;
515             } elsif (ref($thing) eq 'CODE') {
516 0         0 $thing->();
517 0         0 return 1;
518             } elsif (!ref($thing)) {
519 0         0 return _yield($view->_compile_template($c, $thing));
520             }
521             }
522              
523             #
524             # get/set attribute(s) of latest open tag
525             #
526             sub attr {
527             # FIXME: better discovery of set/get !defined wantarray (?)
528            
529 2 50 66 2 0 17 return $top[-1]->[1]->{$_[0]} if scalar @_ == 1 && defined wantarray;
530              
531 3     3   15 no warnings; # avoid odd no of elements in hash
  3         3  
  3         2186  
532 2         2 %{ $top[-1]->[1] } = ( %{ $top[-1]->[1] }, @_ );
  2         7  
  2         7  
533 2         3 return;
534             }
535              
536             #
537             # set a class inside a tag
538             #
539             sub class {
540 11 50   11 0 47 my @args = @_
541             or return;
542              
543             #
544             # class 'huhu'; - set 'huhu' (replacing previous name)
545             # class 'huhu zzz'; - set 'huhu' and 'zzz' (replacing previous name/s)
546             # class '-bar'; - remove 'bar'
547             # class '-bar baz'; - remove 'bar' and 'baz'
548             # class '+foo'; - add 'foo'
549             # class '+foo moo' - add 'foo' and 'moo'
550             # class '+foo -bar baz' - add 'foo', remove 'bar' and 'baz'
551             # class '+foo','-bar','baz' - add 'foo', remove 'bar' and 'baz'
552             # class qw(+foo -bar baz) - same thing.
553             #
554 11   100     33 my $class_name = $top[-1]->[1]->{class} || '';
555 8         16 my %class = map {($_ => 1)}
  8         14  
556 11         51 grep {$_}
557             split(qr{\s+}xms, $class_name);
558              
559 11         15 my $operation = 0; # -1 = sub, 0 = set, +1 = add
560 11 50 33     12 foreach my $name (grep {length} map {split qr{\s+}xms} grep {!ref && defined && length} @args) {
  16         20  
  12         38  
  12         65  
561 16 100       42 if ($name =~ s{\A([-+])}{}xms) {
562 6 100       14 $operation = $1 eq '-' ? -1 : +1;
563             }
564 16 100       29 if ($operation < 0) {
    100          
565 3         7 delete $class{$name};
566             } elsif ($operation > 0) {
567 6         11 $class{$name} = 1;
568             } else {
569 7         14 %class = ($name => 1);
570 7         11 $operation = +1;
571             }
572             }
573              
574 11         42 $top[-1]->[1]->{class} = join(' ', sort keys(%class));
575 11         29 return;
576             }
577              
578             #
579             # set an ID
580             #
581 1     1 0 7 sub id { $top[-1]->[1]->{id} = $_[0]; return; }
  1         2  
582              
583             #
584             # define a javascript-handler
585             #
586 0     0 0 0 sub on { $top[-1]->[1]->{"on$_[0]"} = join('', @_[1..$#_]); return; }
  0         0  
587              
588             #
589             # simple getters
590             #
591 0     0 0 0 sub stash { $stash }
592 0     0 0 0 sub c { $c }
593              
594             #
595             # generate a proper doctype line
596             #
597             sub doctype {
598 0     0 0 0 my $kind = join(' ', @_);
599              
600             # see http://hsivonen.iki.fi/doctype/ for details on these...
601 0         0 my @doctype_finder = (
602             [qr(html(?:\W*5)) => 'html5'],
603             [qr(html) => 'html5'],
604              
605             [qr(html(?:\W*4[0-9.]*)?\W*s) => 'html4_strict'],
606             [qr(html(?:\W*4[0-9.]*)?\W*[tl]) => 'html4_loose'],
607              
608             [qr(xhtml\W*1\W*1) => 'xhtml1_1'],
609             [qr(xhtml(?:\W*1[0-9.]*)?\W*s) => 'xhtml1_strict'],
610             [qr(xhtml(?:\W*1[0-9.]*)?\W*[tl]) => 'xhtml1_trans'],
611             [qr(xhtml) => 'xhtml1'],
612             );
613              
614 0         0 my %doctype_for = (
615             default => q{<!DOCTYPE html>},
616             html5 => q{<!DOCTYPE html>},
617             html4 => q{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN">},
618             html4_strict => q{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" } .
619             q{"http://www.w3.org/TR/html4/strict.dtd">},
620             html4_loose => q{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" } .
621             q{"http://www.w3.org/TR/html4/loose.dtd">},
622             xhtml1_1 => q{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" } .
623             q{"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">},
624             xhtml1 => q{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" } .
625             q{"http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">},
626             xhtml1_strict=> q{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" } .
627             q{"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">},
628             xhtml1_trans => q{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" } .
629             q{"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">},
630             );
631              
632 0         0 my $doctype = 'default';
633 0         0 foreach my $d (@doctype_finder) {
634 0 0       0 if ($kind =~ m{\A $d->[0]}xmsi) {
635 0         0 $doctype = $d->[1];
636 0         0 last;
637             }
638             }
639              
640 0         0 push @{$top[-1]}, $doctype_for{$doctype};
  0         0  
641             }
642              
643             sub boilerplate(;&) {
644 2     2 0 4 my $code = shift;
645              
646 2         2 push @{$top[-1]}, <<HTML;
  2         5  
647             <!--[if lt IE 7 ]> <html class="no-js ie6" lang="en"> <![endif]-->
648             <!--[if IE 7 ]> <html class="no-js ie7" lang="en"> <![endif]-->
649             <!--[if IE 8 ]> <html class="no-js ie8" lang="en"> <![endif]-->
650             <!--[if (gte IE 9)|!(IE)]><!--> <html class="no-js" lang="en"> <!--<![endif]-->
651             HTML
652              
653 2 100       6 if ($code) {
654 1         2 $code->();
655             }
656              
657 2         3 push @{$top[-1]}, '</html>';
  2         3  
658             }
659              
660             ######################################## Locale stuff
661             #
662             # get a localized version of something
663             #
664             {
665 3     3   20 no warnings 'redefine';
  3         4  
  3         319  
666 0     0   0 sub _ { return $c->localize(@_) }
667             }
668              
669 0     0 0 0 sub nbsp { "\x{00a0}" } # bad hack in the moment...
670              
671             #
672             # define a function for every tag into a given namespace
673             #
674             sub _construct_functions {
675 2     2   2 my $namespace = shift;
676              
677 3     3   15 no warnings 'redefine'; # in case of a re-compile.
  3         4  
  3         189  
678              
679 2         9 my %declare;
680              
681             # tags with content are treated the same as tags without content
682 2         3 foreach my $tag_name (@IS_KNOWN) {
683 276   66     673 my $sub_name = $change_tags{$tag_name}
684             || $tag_name;
685              
686             # install a tag-named sub in caller's namespace
687 3     3   16 no strict 'refs';
  3         4  
  3         491  
688 276         801 *{"$namespace\::$sub_name"} = sub (;&@) {
689 17     17   272 push @{$top[-1]}, [ $tag_name, { @_[1 .. $#_] } ];
  17         74  
690              
691 17 50       34 if ($_[0]) {
692 17         20 push @top, $top[-1]->[-1];
693            
694             #### TODO: find out why ->render does not work for HTML::FormFu !!!
695            
696 17         27 my $text = $_[0]->(@_);
697 17 100 100     76 if (ref $text && UNIVERSAL::can($text, 'render')) {
    100          
698 1         3 push @{$top[-1]}, $text->render;
  1         5  
699             } elsif (ref $text eq 'SCALAR') {
700 1         2 push @{$top[-1]}, $$text;
  1         4  
701             } else {
702 3     3   14 no warnings 'uninitialized'; # we might see undef values
  3         2  
  3         422  
703 15         41 $text =~ s{($NEED_ESCAPE)}{'&#' . ord($1) . ';'}oexmsg;
  0         0  
704 15         11 push @{$top[-1]}, $text;
  15         23  
705             }
706            
707 17         23 pop @top;
708             }
709              
710             ### TODO: can we call _render() here and save text instead of a structure?
711             ### would convert [ tag => {attr}, content ] to <tag attr>content</tag>
712             # $top[-1] = _render($top[-1]);
713              
714 17         41 return;
715 276         862 };
716 3     3   17 use strict 'refs';
  3         5  
  3         362  
717              
718             # remember me to generate a magic tag-parser that applies extra magic
719 276         443 $declare{$sub_name} = {
720             const => Catalyst::View::ByCode::Declare::tag_parser
721             };
722             }
723              
724             # add logic for block definitions
725             $declare{block} = {
726 2         7 const => Catalyst::View::ByCode::Declare::block_parser
727             };
728              
729             # install all tag-parsers collected above
730 2         16 Devel::Declare->setup_for($namespace, \%declare);
731             }
732              
733             1;