File Coverage

web/cgi-bin/yatt.lib/YATT/Translator/Perl.pm
Criterion Covered Total %
statement 788 922 85.4
branch 358 494 72.4
condition 68 117 58.1
subroutine 119 138 86.2
pod 0 96 0.0
total 1333 1767 75.4


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2 3     3   11636 package YATT::Translator::Perl; use YATT::Inc;
  3         7  
  3         25  
3 3     3   16 use strict;
  3         6  
  3         85  
4 3     3   14 use warnings qw(FATAL all NONFATAL misc);
  3         5  
  3         144  
5 3     3   15 use Carp;
  3         6  
  3         266  
6              
7             #========================================
8              
9             our %TYPE_MAP;
10              
11 3     3   15 use base qw(YATT::Registry);
  3         6  
  3         1663  
12             use YATT::Fields [cf_mode => 'render']
13 3     0   30 , [cf_product => sub {[]}]
  0         0  
14             , qw(target_cache
15             delayed_target
16             generating_widget
17             cf_pagevars
18 3     3   15 cf_debug_translator);
  3         6  
19              
20 3     3   15 BEGIN {require Exporter; *import = \&Exporter::import}
  3         144  
21             our @EXPORT_OK = qw(qqvalue qparen);
22             our @EXPORT = @EXPORT_OK;
23              
24 3     3   16 use YATT::Registry::NS;
  3         6  
  3         189  
25 3     3   15 use YATT::Widget;
  3         5  
  3         161  
26 3     3   16 use YATT::Util qw(checked_eval add_arg_order_in terse_dump coalesce);
  3         4  
  3         220  
27 3         294 use YATT::LRXML::Node qw(node_path node_body node_name
28             node_size node_flag
29             node_children
30             create_node
31             stringify_node
32 3     3   16 TEXT_TYPE ELEMENT_TYPE ENTITY_TYPE);
  3         4  
33              
34 3     3   1871 use YATT::LRXML::EntityPath;
  3         10  
  3         222  
35 3     3   25 use YATT::Util::Taint;
  3         84  
  3         314  
36 3     3   18 use YATT::Util::Symbol qw(declare_alias);
  3         8  
  3         7605  
37             require YATT::ArgMacro;
38              
39             #========================================
40              
41             sub qqvalue ($);
42             sub qparen ($);
43              
44             #========================================
45              
46             sub after_configure {
47 14     14 0 33 my MY $trans = shift;
48 14         84 $trans->SUPER::after_configure;
49 14   50     150 $trans->{cf_type_map} ||= \%TYPE_MAP;
50             }
51              
52             sub emit {
53 142     142 0 293 my MY $gen = shift;
54 142         210 my $script = join "", @{$gen->{cf_product}};
  142         503  
55 142         327 $gen->{cf_product} = [];
56 142         651 $script;
57             }
58              
59             #========================================
60              
61             sub call_handler {
62 31     31 0 108 (my MY $trans, my ($method, $widget_path)) = splice @_, 0, 3;
63 31 50       189 my ($handler, $pkg) = $trans->get_handler_to
64             ($method, ref $widget_path ? @$widget_path : split /[:\.]/, $widget_path);
65 11         51 &YATT::break_handler;
66 11         5388 $handler->($pkg, @_);
67             }
68              
69             sub parse_elempath {
70 161     161 0 405 my ($pack, @elpath) = @_;
71 161 100       471 if (@elpath == 1) {
72 142 50       332 if (ref $elpath[0]) {
73 0         0 @elpath = @{$elpath[0]};
  0         0  
74             } else {
75 142         421 @elpath = split '/', $elpath[0];
76             }
77             }
78              
79             # root dir should be ignored.
80 161 50 33     1068 shift @elpath if !defined $elpath[0] || $elpath[0] eq '';
81              
82 161         565 @elpath;
83             }
84              
85             sub get_handler_to {
86 161     161 0 401 (my MY $trans, my ($method)) = splice @_, 0, 2;
87 161         559 my @elpath = $trans->parse_elempath(@_);
88              
89 161         231 my @result;
90 161 50       315 if (wantarray) {
91 161         488 @result = $trans->lookup_handler_to($method, @elpath);
92             } else {
93 0         0 $result[0] = $trans->lookup_handler_to($method, @elpath);
94             }
95              
96 141 50       484 unless (@result) {
97 0         0 croak "Can't find widget: " . join(":", @elpath);
98             }
99              
100 141 50       893 wantarray ? @result : $result[0];
101             }
102              
103             sub lookup_handler_to {
104 161     161 0 473 (my MY $trans, my ($method, @elpath)) = @_;
105              
106 161         480 $trans->{cf_mode} = $method; # XXX: local
107 161         226 @{$trans->{cf_product}} = ();
  161         473  
108              
109 161 50       692 my Widget $widget = $trans->get_widget(@elpath)
110             or return;
111              
112 156         651 $trans->ensure_widget_is_generated($widget);
113 142 100       545 if (my $script = $trans->emit) {
114 117 50       319 print STDERR $script if $trans->{cf_debug_translator};
115 117         567 $trans->checked_eval
116             (join(";"
117             , 'use strict'
118             , 'use warnings FATAL => qw(all)'
119             # XXX: 何が redefine されるかは分からないから…
120             , 'no warnings "redefine"'
121             , untaint_any($script)));
122              
123             }
124 141         578 my ($pkg, $funcname) = $trans->get_funcname_to($method, $widget);
125 141         1325 my $handler = $pkg->can($funcname);
126              
127 141 50       412 return $handler unless wantarray;
128 141         497 ($handler
129             , scalar $trans->get_package_from_widget($widget)
130             , $widget);
131             }
132              
133             sub get_funcname_to {
134 436     436 0 871 (my MY $trans, my ($mode), my Widget $widget) = @_;
135 436         1056 my $pkg = $trans->get_package_from_widget($widget);
136 436         1176 my $fname = "${mode}_$$widget{cf_name}";
137 436 100       1750 wantarray ? ($pkg, $fname) : join("::", $pkg, $fname);
138             }
139              
140             sub get_package_from_widget {
141 593     593 0 963 (my MY $trans, my Widget $widget) = @_;
142             my $primary = $trans->get_package
143 593         2160 (my Template $tmpl = $trans->nsobj($widget->{cf_template_nsid}));
144              
145 593 100       2431 return $primary unless wantarray;
146 16         59 ($primary, $trans->get_rc_package_from_template($tmpl));
147             }
148              
149             sub get_rc_package_from_template {
150 153     153 0 260 (my MY $trans, my Template $tmpl) = @_;
151 153         573 $trans->get_package($trans->nsobj($tmpl->{cf_parent_nsid}));
152             }
153              
154             #----------------------------------------
155              
156             sub generate {
157 0     0 0 0 my MY $gen = shift;
158 0         0 foreach my $elempath (@_) {
159 0 0       0 if (my $widget = $gen->get_widget(@$elempath)) {
    0          
160 0         0 $gen->ensure_widget_is_generated($widget);
161             } elsif (my $ns = $gen->get_ns($elempath)) {
162 0         0 $gen->ensure_ns_is_generated($ns);
163             } else {
164 0         0 croak "Invalid widget path: " . join(":", @$elempath);
165             }
166             }
167 0         0 $gen->emit;
168             }
169              
170             sub mark_delayed_target {
171 0     0 0 0 (my MY $gen, my Widget $widget) = @_;
172 0         0 $gen->{delayed_target}{$widget->{cf_template_nsid}}++;
173             }
174              
175             sub ensure_widget_is_generated {
176 243     243 0 487 (my MY $gen, my Widget $widget) = @_;
177 243         809 $gen->ensure_template_is_generated($widget->{cf_template_nsid});
178             }
179              
180             sub ensure_template_is_generated {
181             # (my MY $gen, my $tmplid) = @_;
182             # $tmplid = $tmplid->cget('nsid') if ref $tmplid;
183 246     246 0 466 (my MY $gen, my $id_or_obj) = @_;
184 246         429 (my $tmplid, my Template $tmpl) = do {
185 246 50       591 if (ref $id_or_obj) {
186 0         0 ($id_or_obj->cget('nsid'), $id_or_obj)
187             } else {
188 246         867 ($id_or_obj, $gen->nsobj($id_or_obj));
189             }
190             };
191 246 100       856 if (my $baseid = $tmpl->{cf_base_template}) {
192 3         13 $gen->ensure_template_is_generated($baseid);
193             }
194 246 100       1008 unless ($gen->{target_cache}{$tmplid}++) {
195              
196             # eval は?
197 141         226 push @{$$gen{cf_product}}
  141         653  
198             , $gen->generate_template($gen->nsobj($tmplid));
199             }
200 232 50       420 if (my @delayed = keys %{$gen->{delayed_target}}) {
  232         1230  
201 0         0 foreach my $nsid (@delayed) {
202 0 0       0 next if $gen->{target_cache}{$nsid};
203 0         0 delete $gen->{delayed_target}{$nsid};
204 0         0 $gen->ensure_template_is_generated($nsid);
205             }
206             }
207             }
208              
209             sub forget_template {
210 146     146 0 317 (my MY $gen, my $tmplid) = @_;
211 146 50       800 $tmplid = $tmplid->cget('nsid') if ref $tmplid;
212 146 50       750 delete $gen->{target_cache}{$tmplid} ? 1 : 0;
213             }
214              
215             my %calling_conv;
216              
217             sub generate_template {
218 141     141 0 403 (my MY $gen, my Template $tmpl) = @_;
219             print STDERR "Generate: $tmpl->{cf_loadkey}\n"
220 141 50       489 if $gen->{cf_debug_translator};
221 141         511 my $metainfo = $tmpl->metainfo;
222             my @use = map {
223 141 50       361 unless (defined $_) {
224             ()
225 141         428 } else {
226 0 0       0 map {"use $_;"} ref $_ ? @$_ : $_
  0         0  
227             }
228 141         378 } $gen->{cf_use};
229 141         217 my @file_scope = do {
230 141 100       497 if ($gen->{cf_pagevars}) {
231 1         7 $gen->checked_eval(qq{require $gen->{cf_pagevars}});
232 1         6 push @use, "use $gen->{cf_pagevars} (qw($tmpl->{cf_name}), 1);";
233             ($gen->{cf_pagevars}->build_scope_for($gen, $tmpl->{cf_name})
234 1         12 , [\%calling_conv]);
235             } else {
236 140         362 \%calling_conv;
237             }
238             };
239 141         238 my @script;
240 141         230 foreach my $widget (@{$tmpl->widget_list}) {
  141         565  
241 220         908 push @script, $gen->generate_widget($widget, $metainfo, \@file_scope);
242             }
243 127         496 join("", q{package } . $gen->get_package($tmpl) . ';'
244             , join("",@use)
245             , @script);
246             }
247              
248             sub generate_lineinfo {
249 406     406 0 986 (my MY $gen, my Widget $widget, my ($start, $prefix)) = @_;
250 406 100       1904 return if $gen->{cf_no_lineinfo};
251             sprintf qq{%s#line %d "%s"\n}, $prefix || ''
252 50   100     428 , $start, $widget->{cf_filename};
253             }
254              
255             sub generating_widget {
256 0     0 0 0 my MY $gen = shift;
257 0         0 $gen->{generating_widget}[0];
258             }
259              
260             sub generate_widget {
261 220     220 0 460 (my MY $gen, my Widget $widget, my ($metainfo, $file_scope)) = @_;
262 220         610 local $gen->{generating_widget}[0] = $widget;
263             my @body = $gen->generate_body
264             ([{}, $widget->widget_scope($file_scope)]
265             , $widget->cursor(metainfo => $metainfo->clone
266             (startline => $widget->{cf_body_start}
267 220         1099 , caller_widget => $widget)));
268             # body が空の場合もありうる。
269 206 100       2410 return unless @body;
270 203         778 my ($pkg, $funcname) = $gen->get_funcname_to($gen->{cf_mode}, $widget);
271             join(""
272             , $gen->generate_lineinfo($widget, $widget->{cf_decl_start}, "\n")
273             , $gen->generate_getargs($widget, $metainfo)
274             , $gen->generate_lineinfo($widget, $widget->{cf_body_start})
275 203         865 , $gen->as_sub
276             ($funcname
277             , $gen->genprolog($widget)
278             , $gen->as_statement_list(@body))
279             , "\n");
280             }
281              
282             sub generate_getargs {
283 203     203 0 350 (my MY $gen, my Widget $widget, my ($metainfo)) = @_;
284 203         893 $gen->as_sub("getargs_$$widget{cf_name}", sprintf q{
285             my ($call) = shift;
286             $_[0] = shift @$call; shift;
287             my $args = $_[0] = shift @$call; shift;
288             if (ref $args eq 'ARRAY') {
289             %s} else {
290             %s
291             }
292             }
293             , $gen->gen_getargs_static($widget, $metainfo)
294             , $gen->gen_getargs_dynamic($widget, $metainfo));
295             }
296              
297             sub genprolog {
298 203     203 0 331 (my MY $gen, my Widget $widget) = @_;
299 203         439 my @args = qw($this $args);
300 203 100 66     750 if ($widget->{arg_order} && @{$widget->{arg_order}}) {
  161         808  
301 161         279 foreach my $name (@{$widget->{arg_order}}) {
  161         417  
302 391         1000 push @args, $widget->{arg_dict}{$name}->as_lvalue
303             }
304             }
305             sprintf q{getargs_%s(\@_, my (%s))}
306 203         1384 , $$widget{cf_name}, join(", ", @args);
307             }
308              
309             sub generate_body {
310 285     285 0 607 (my MY $gen, my ($scope, $cursor)) = @_;
311 285         826 my @code;
312 285         902 for (; $cursor->readable; $cursor->next) {
313 850 50       2413 if (my $sub = $gen->can("trans_" . (my $t = $cursor->node_type_name))) {
314 850         2074 push @code, $sub->($gen, $scope, $cursor);
315             } else {
316 0         0 die $gen->node_error($cursor, "Can't handle node type: %s", $t);
317             }
318             }
319 269         1146 @code;
320             }
321              
322             sub as_sub {
323 444     444 0 1202 my ($gen, $func_name) = splice @_, 0, 2;
324 444         1341 "sub $func_name ". $gen->as_block(@_);
325             }
326              
327             sub as_block {
328 460     460 0 796 my ($gen) = shift;
329 460 50       1123 return '{}' unless @_;
330 460         835 my $last = pop;
331 460         666 $last .= do {
332 460 100       2666 if ($last =~ s/(\n+)$//) {
333 326         1038 "}$1";
334             } else {
335 134         256 '}';
336             }
337             };
338 460         3813 '{ '.join("; ", @_, $last);
339             }
340              
341             sub as_join {
342 14     14 0 31 my MY $gen = shift;
343 14         23 my (@result);
344 14         34 foreach my $trans (@_) {
345 35 50       70 if (ref $trans) {
346 0         0 push @result, qq(YATT::capture {$$trans});
347             } else {
348 35         78 push @result, $trans;
349             }
350             }
351 14         127 sprintf q{join('', %s)}, join ", ", @result;
352             }
353              
354             use YATT::Types
355 3     3   19 [queued_joiner => [qw(queue printable last_ws)]];
  3         8  
  3         29  
356              
357             sub YATT::Translator::Perl::queued_joiner::joiner {
358             # 行が変わらない限り、一つの print に入れる。
359             # 行が変われば、別の print にする。
360             # 印字可能要素が無いなら、空白をそのまま入れる。
361 279     279 0 640 (my queued_joiner $me, my ($head)) = splice @_, 0, 2;
362 279         615 my ($line, $prenl, @result, $argc, $nlines) = ('', '');
363 279         516 foreach my $i (@_) {
364 590 100       1937 unless ($i =~ /\S/) {
365 44 50       240 push @result, $i
366             and next;
367             }
368 546 100       1041 if ($line eq '') {
369             # 先頭
370 306 100       1085 if ($i =~ s/^(\s+)//) {
371 86         221 $prenl .= $1;
372             }
373 306 50       747 if ($i ne '') {
374 306         763 $line .= $prenl . $head . $i;
375             }
376             } else {
377             # 残り
378 240         515 $line .= ', ' . $i;
379             }
380 546 100       1602 if ($i =~ /\n/) {
381 246         415 push @result, $line;
382 246         359 $line = '';
383 246         473 $prenl = '';
384             }
385             }
386 279 100       704 push @result, $line if $line ne '';
387 279         747 @result;
388             }
389              
390             sub YATT::Translator::Perl::queued_joiner::add {
391 689     689 0 1066 (my queued_joiner $me, my $str) = @_;
392 689         776 push @{$me->{queue}}, $str;
  689         1601  
393 689 100       2024 if ($str =~ /\S/) {
394 546         860 $me->{printable}++;
395 546         1300 undef $me->{last_ws};
396             } else {
397 143         462 $me->{last_ws} = 1;
398             }
399             }
400              
401             sub YATT::Translator::Perl::queued_joiner::emit_to {
402 406     406 0 651 (my queued_joiner $me, my ($result)) = @_;
403 406 100       1104 if ($me->{printable}) {
404 279 100       336 my $ws; $ws = pop @{$me->{queue}} if $me->{last_ws};
  279         790  
  20         62  
405 279 50       399 push @$result, $me->joiner('print ', @{$me->{queue}}) if @{$me->{queue}};
  279         841  
  279         934  
406 279 100       845 $result->[-1] .= $ws if $me->{last_ws};
407             } else {
408 127 100       412 push @$result, @{$me->{queue}} if $me->{queue};
  87         247  
409             }
410 406         715 undef @{$me->{queue}};
  406         1108  
411 406         623 undef $me->{printable};
412 406         704 undef $me->{last_ws};
413             }
414              
415             sub as_statement_list {
416 256     256 0 401 my MY $gen = shift;
417 256         1631 my queued_joiner $queue = queued_joiner->new;
418 256         461 my (@result);
419 256         555 foreach my $trans (@_) {
420 839 100       1568 if (ref $trans) {
421 150         514 $queue->emit_to(\@result);
422 150         340 push @result, $$trans;
423             } else {
424 689         1533 $queue->add($trans);
425             }
426             }
427 256         631 $queue->emit_to(\@result);
428 256 50       1439 wantarray ? @result : join('', @result);
429             }
430              
431             #----------------------------------------
432             # trans_zzz
433              
434             sub trans_comment {
435 0     0 0 0 (my MY $trans, my ($scope, $node)) = @_;
436 0         0 \ ("\n" x $node->node_nlines);
437             }
438              
439             sub trans_text {
440 527     527 0 976 (my MY $trans, my ($scope, $node)) = @_;
441 527         1577 my $body = $node->current;
442 527         1216 my ($pre, $post) = ('', '');
443 527         1751 my $CRLF = qr{\r?\n};
444 527 100       1661 if ($node->node_is_beginning) {
    100          
445 233 100       2595 $pre = $1 if $body =~ s/^($CRLF+)//;
446             } elsif ($node->node_is_end) {
447 211 100 100     862 if (not $node->has_parent
448             and $node->metainfo->caller_widget->no_last_newline) {
449 35         343 $body =~ s/($CRLF+)$//s;
450             } else {
451 176 100       1354 $post = $2 if $body =~ s/($CRLF)($CRLF+)$/$1/s;
452             }
453             }
454 527         1052 $pre.do {
455 527 100       2398 if ($body eq '') {
    100          
456 146         964 ''
457             } elsif ($body =~ /^$CRLF$/) {
458 129         429 sprintf qq{"%s"\n}, qcrlf($body);
459             } else {
460 252         576 qparen($body);
461             }
462             }.$post;
463             }
464              
465             sub trans_pi {
466 17     17 0 71 (my MY $trans, my ($scope, $node)) = @_;
467              
468             # XXX: 処理を許すかどうか、選べるようにすべき。あるいは、mapping が欲しい。
469 17 50       66 if ($node->node_nsname ne 'perl') {
470 0         0 return '';
471             }
472              
473 17         63 my $body = $trans->genexpr_node($scope, 0, $node->open);
474 17 100       183 unless ($body =~ s/^(=+)//) {
    100          
475 3         15 \ $body;
476             } elsif (length($1) >= 3) {
477             # print without escaping.
478 6         35 \ qq{print $body};
479             } else {
480 8         44 qq{YATT::escape(do {$body})}
481             }
482             }
483              
484             sub genexpr_node {
485 34     34 0 71 (my MY $trans, my ($scope, $early_escaped, $node)) = @_;
486 34 100       136 join("", map { ref $_ ? $$_ : $trans->dots_for_arrows(my $cp = $_) }
  53         226  
487             $trans->mark_vars($scope, $early_escaped, $node));
488             }
489              
490             #========================================
491              
492 3     3   19 use YATT::Util::Enum -prefix => 'ENT_', qw(RAW ESCAPED PRINTED);
  3         7  
  3         30  
493              
494             sub trans_entity {
495 158     158 0 359 (my MY $trans, my ($scope, $node)) = @_;
496 158         568 $trans->generate_entref($scope, ENT_PRINTED, $node);
497             }
498              
499             sub trans_html {
500 11     11 0 24 (my MY $trans, my ($scope, $node)) = @_;
501 11         39 my $tag = $node->node_name;
502 11         27 my ($string, $tagc, $end) = do {
503 11 100       48 if ($node->is_empty_element) {
504 9         32 ("<$tag", " />", '');
505             } else {
506 2         11 ("<$tag", ">", "");
507             }
508             };
509              
510 11         45 my $item = $node->open;
511 11         19 my @script;
512 11         42 for (; $item->readable; $item->next) {
513 24 100       80 last unless $item->is_primary_attribute;
514 22         71 my $name = $item->node_name;
515 22 50       78 if (my $var = $trans->has_pass_through_var($scope, $item, $name)) {
516 0         0 push @script, qparen($string), $var->as_escaped;
517 0         0 $string = '';
518 0         0 next;
519             }
520 22         46 $string .= ' ';
521 22         72 my ($open, $close) = $item->node_attribute_format;
522 22         36 $string .= $open;
523             # XXX: quote されてないとき、変数推測をしても良いかも。
524 22         133 for (my $frag = $item->open; $frag->readable; $frag->next) {
525 27         82 my $type = $frag->node_type;
526 27 100       91 if ($type == TEXT_TYPE) {
    50          
527 12         35 $string .= $frag->current;
528             } elsif ($type == ENTITY_TYPE) {
529             # should be entity
530 15         43 push @script, qparen($string)
531             , $trans->generate_entref($scope, ENT_ESCAPED, $frag);
532 15         69 $string = '';
533             } else {
534 0         0 die $trans->node_error($frag, "Invalid node in html attribute");
535             }
536             }
537 22         128 $string .= $close;
538             }
539              
540 11 50       42 $string .= $tagc if $tagc ne '';
541 11         39 for (; $item->readable; $item->next) {
542 4 100       14 if ($item->node_type == TEXT_TYPE) {
543 2         9 $string .= $item->current;
544             } else {
545 2         12 push @script, qparen($string), $trans->generate_body($scope, $item);
546 2         9 $string = '';
547             }
548             }
549 11 100       37 $string .= $end if $end;
550 11 50       39 push @script, qparen($string) if $string ne '';
551 11         90 @script;
552             }
553              
554             #========================================
555              
556             my %control = (if => undef, unless => undef);
557             sub trans_element {
558 137     137 0 380 (my MY $trans, my ($scope, $node)) = @_;
559 137         607 my $tmpl = $trans->get_template_from_node($node);
560              
561             # ■ 最初に要素マクロ ← RC から検索。
562 137 100       600 if (my $macro = $trans->has_element_macro($tmpl, $node, $node->node_path)) {
563             # XXX: ssri:foreach → yatt:foreach も。
564 23         107 return $macro->($trans, $scope, $node->open);
565             }
566              
567             # ■ 次に if/unless/else,
568 114 100       545 if (my @arm = $trans->collect_arms($node, else => \%control)) {
569 5         21 return $trans->gencall_conditional($scope, @arm);
570             }
571              
572             # ■ 無条件呼び出し
573 109         392 $trans->gencall_always($scope, $node);
574             }
575              
576             sub gencall_conditional {
577 5     5 0 15 (my MY $trans, my ($scope, $ifunless, @elses)) = @_;
578 5         14 my $pkg;
579 5         10 my $script = do {
580 5         11 my ($cond, $action) = @$ifunless; # (node, cursor)
581             sprintf(q{%s (%s) {%s}}
582             , $cond->node_name
583             , $trans->genexpr_node($scope, 0, $cond->open)
584 5         16 , ${ $trans->gencall_always($scope, $action->make_wrapped) });
  5         24  
585             };
586              
587 5         49 foreach my $arm (@elses) {
588 5         14 my ($cond, $action) = @$arm;
589 5         9 $script .= do {
590 5 100       18 if ($cond) {
591 2         10 sprintf q{ elsif (%s) }
592             , $trans->genexpr_node($scope, 0, $cond->open);
593             } else {
594 3         8 q{ else }
595             }
596             };
597             $script .= sprintf q{{%s}}
598 5         17 , ${ $trans->gencall_always($scope, $action->make_wrapped) };
  5         21  
599             }
600 5         35 \ $script;
601             }
602              
603             sub gencall_always {
604 119     119 0 253 (my MY $trans, my ($scope, $node)) = @_;
605              
606 119         408 my $tmpl = $trans->get_template_from_node($node);
607 119 50       424 my @elempath = $node->node_path or do {
608 0         0 die $trans->node_error($node, "Empty element path");
609             };
610              
611             # ■ 局所引数… これも、型の固有処理に任せる. delegate もここで。
612 119 100       479 if (my $codevar = $trans->find_codearg($scope, @elempath)) {
613             # ← 特に、親の call の body の中で、
614             # 呼ばれるとき, だよね?
615 30         104 return $codevar->gen_call($trans, $scope, $node);
616             }
617              
618             # ■ さもなければ、通常の Widget の呼び出し
619 89         367 my Widget $widget = $trans->get_widget_from_template($tmpl, @elempath);
620 89 100       299 unless ($widget) {
621 2         10 die $trans->node_error($node, "No such widget");
622             }
623 87         343 $trans->gencall($widget, $scope, $node->open);
624             }
625              
626             sub has_unique_argmacro {
627 87     87 0 175 (my MY $trans, my Widget $callee, my Widget $caller) = @_;
628 87 100       466 return unless $callee->{argmacro_dict};
629             # 現状では、name の重複は無いはず。
630 19         43 my %suppress; $suppress{$_->call_spec} = 1 for @{$caller->{argmacro_order}};
  19         40  
  19         82  
631 19 100       39 my @order = grep {not $suppress{$_->call_spec}} @{$callee->{argmacro_order}}
  16         73  
  19         80  
632             or return;
633 11         21 my %dict;
634 11         24 foreach my $arg (keys %{$callee->{argmacro_dict}}) {
  11         48  
635 45         104 $dict{$arg} = $callee->{argmacro_dict}{$arg};
636             }
637 11         69 (\%dict, \@order);
638             }
639              
640             sub gencall {
641 87     87 0 336 (my MY $trans, my Widget $widget, my ($scope, $node)) = @_;
642 87         325 $trans->ensure_widget_is_generated($widget);
643              
644             # 引数マクロの抜き出し
645 87 100       354 if (my ($dict, $order) = $trans->has_unique_argmacro
646             ($widget, $node->metainfo->caller_widget)) {
647 11         86 $node = YATT::ArgMacro->expand_all_macros
648             ($trans, $scope, $node, $widget, $dict, $order);
649             }
650              
651 87         387 my $func = $trans->get_funcname_to($trans->{cf_mode}, $widget);
652             # actual 一覧の作成
653 87         403 my ($post, @args) = $trans->genargs_static
654             ($scope, $node, $widget->arg_specs);
655              
656             # XXX: calling convention 周り
657             return \ sprintf(' %s($this, [%s])%s', $func
658 83 100       353 , join(", ", map {defined $_ ? $_ : 'undef'} @args)
  127         1169  
659             , $post);
660             }
661              
662             sub has_single_bare_varexpr {
663 6     6 0 14 (my MY $trans, my ($scope, $node)) = @_;
664 6         23 my $clone = $node->clone($node->clone_path);
665 6         27 my $parent = $clone->parent;
666 6 100 66     25 return unless $parent->is_bare_attribute and $parent->node_size == 1;
667 1         6 my (@expr) = ($trans->mark_vars($scope, ENT_RAW, $clone));
668 1 50 33     10 return unless @expr and ref $expr[0] eq 'SCALAR';
669 1         9 $expr[0];
670             }
671              
672             sub has_pass_through_var {
673 133     133 0 353 (my MY $trans, my ($scope, $args, $name)) = @_;
674 133 100       452 return if $args->node_size >= 2;
675 118 100 100     353 if ($args->node_size == 1 and ($args->node_flag || 0) == 0) {
    100 100        
676             # bareword 渡し。
677 20         90 $trans->find_var($scope, $args->node_body);
678             } elsif ($args->node_size == 0) {
679             # value less 渡し
680 43         106 $trans->find_var($scope, $name);
681             }
682             }
683              
684             sub genargs_static {
685 117     117 0 303 (my MY $trans, my ($scope, $args, $arg_dict, $arg_order, $delegate_vars)) = @_;
686 117         466 my ($body, @actual) = $args->variant_builder;
687 117         554 my ($postnl, $startline) = ('', $args->linenum);
688 117         437 for (my $nth = 0; $args->readable; $args->next) {
689 177 100       654 unless ($args->is_attribute) {
690 75         212 $body->add_node($args->current);
691 75         241 next;
692             }
693              
694 102         355 my ($name, $typename) = $trans->arg_name_types($args);
695 102 100       290 unless (defined $name) {
696 2 50       10 $name = $arg_order->[$nth++]
697             or die $trans->node_error($args, "Too many args");
698             }
699 102         225 my $argdecl = $arg_dict->{$name};
700 102 50       249 unless ($argdecl) {
701 0         0 die $trans->node_error($args, "Unknown arg '%s'", $name);
702             }
703             # XXX: $typename (attname:type の type) を活用していない。
704             # XXX: code 型引数を primary で渡したときにまで、 print が作られてる。
705             # $args->is_quoted_by_element で判別せよ。
706 102         134 $actual[$argdecl->argno] = do {
707 102 100       328 if (my $var = $trans->has_pass_through_var($scope, $args, $name)) {
    100          
    100          
708             # XXX: early_escaped が一致するか、検査せよ。
709 38 100       130 $argdecl->early_escaped ? $var->as_escaped : $var->as_lvalue;
710             } elsif (defined $args->node_body) {
711 60         255 $argdecl->gen_assignable_node($trans, $scope, $args);
712             } elsif ($argdecl->isa($trans->t_scalar)) {
713 3         13 $argdecl->quote_assignable(my $copy = 1);
714             } else {
715 1         6 die $trans->node_error($args, "valueless arg '%s'", $name);
716             }
717             };
718             }
719 116 100 66     489 if ($body->array_size
720             and my $bodydecl = $arg_dict->{body}) {
721             # if $actual[$bodydecl->argno]; なら、エラーを報告すべきでは?
722             # code か、html か。
723 35         130 $actual[$bodydecl->argno]
724             = $bodydecl->gen_assignable_node($trans, $scope, $body, 1);
725             }
726              
727 114         514 for (my $i = 0; $i < @$arg_order; $i++) {
728 212 100       686 next if defined $actual[$i];
729 79         145 my $name = $arg_order->[$i];
730 79 100       382 if ($delegate_vars->{$name}) {
    100          
731             # delegate 宣言では、型は同じになるはず。
732             # XXX: 引数rename
733 17         42 $actual[$i] = $arg_dict->{$name}->as_lvalue;
734             } elsif ($arg_dict->{$name}->is_required) {
735 1         5 die $trans->node_error($args->parent
736             , "Argument '%s' is missing", $name);
737             }
738             }
739              
740 113 100       633 if ($args->parent->is_empty_element) {
741 80         273 my $diff = $args->parent->linenum(+1)
742             - $startline - $args->count_lines_of(@actual);
743 80 100       375 $postnl = "\n" x $diff if $diff;
744             } else {
745             # XXX: どうする?
746             }
747 113         1048 ($postnl, @actual);
748             }
749              
750             sub collect_arms {
751 114     114 0 262 my ($pack, $call, $key, $dict) = @_;
752 114         459 my ($type, $name) = $call->node_headings;
753 114         445 my $args = $call->open;
754 114         518 my ($cond, $body) = $pack->consume_arm($args, $dict, $type, $name
755             , primary_only => 1);
756 114 100       1068 return unless $cond;
757 5         17 my @case = [$cond, $body];
758 5         23 for (; $args->readable; $args->next) {
759 9 100 66     30 if ($args->is_attribute && $args->node_name eq $key) {
760 5         21 push @case, [$pack->consume_arm($args->open, $dict, $type, $name)];
761             } else {
762             # XXX: 多分、$case[0] (== $body)
763 4         17 $case[-1][-1]->add_node($args->current);
764             }
765             }
766 5         37 @case;
767             }
768              
769             sub consume_arm {
770 119     119 0 346 my ($trans, $node, $dict, $type, $name, @opts) = @_;
771 119         509 my $arm = $node->variant_builder($type, $name);
772 119         599 my @cond = $arm->filter_or_add_from($node, $dict, @opts);
773 119 50       372 if (@cond >= 2) {
774             die $trans->node_error
775             ($node, "Too many condtitions: %s"
776 0         0 , join("", map {stringify_node($_)} @cond));
  0         0  
777             }
778             # $cond[0] は undef かもしれない。 ex. <:else/>
779              
780 119 100       198 my $cond; $cond = $trans->fake_cursor_from($arm, $cond[0]) if defined $cond[0];
  119         344  
781 119         346 ($cond, $arm);
782             }
783              
784             #----------------------------------------
785              
786             sub has_element_macro {
787 137     137 0 448 (my MY $trans, my Template $tmpl, my ($node, @elempath)) = @_;
788             # XXX: macro の一覧は、ちゃんと取り出せるか?
789              
790 137 50       571 if (@elempath > 2) {
791             # Not implemented.
792 0         0 return;
793             }
794              
795 137         489 my $pkg = $trans->get_rc_package_from_template($tmpl);
796 137         223 my $ns;
797 137         311 foreach my $shift (0, 1) {
798 251 100       811 $ns = $trans->strip_ns(\@elempath) if $shift;
799 251         715 my $macro_name = join("_", macro => @elempath);
800 251 100 66     4056 if (my $sub = $pkg->can($macro_name) || $trans->can($macro_name)) {
801 23         122 return $sub;
802             }
803             }
804             }
805              
806             #========================================
807             # 宣言関連
808              
809             # XXX: use は perl 固有だから、ここに持たせるのは理にかなう。
810       0 0   sub declare_use {
811             }
812              
813             sub attr_declare_delegate {
814 7     7 0 37 (my MY $trans, my ($widget, $args, $argname, $subtype, @param)) = @_;
815 7 100       39 my @elempath = $subtype ? @$subtype : $argname;
816 7         36 my Template $tmpl = $trans->get_template_from_node($args);
817 7         40 my Widget $base = $trans->get_widget_from_template($tmpl, @elempath);
818 7 50       29 unless ($base) {
819 0         0 die $trans->node_error($args, "No such widget %s"
820             , join(":", @elempath));
821             }
822 7 50       31 if ($tmpl->{cf_nsid} != $base->template_nsid) {
823 0         0 $trans->mark_delayed_target($base);
824             }
825              
826 7 100       29 if ($base->{arg_dict}{$argname}) {
827 1         7 die $trans->node_error($args, q{delegate '%1$s' hides argument '%1$s' of widget %2$s}
828             , $argname, join(":", @elempath));
829             }
830              
831             # pass thru する変数名の一覧。
832             # でも、未指定なものだけね。
833             # XXX: 引数rename
834 6         11 my %vars; $vars{$_} = 1 for $widget->copy_specs_from($base);
  6         32  
835              
836             #
837             # arg とは別の、コンパイル時のみの仮想的な変数として登録。
838             #
839 6 50       29 if ($widget->has_virtual_var($argname)) {
840 0         0 die $trans->node_error($args, "Duplicate delegate? %s", $argname);
841             }
842             $widget->add_virtual_var
843 6         34 ($argname, $trans->create_var(delegate => $args
844             , base_path => \@elempath
845             , base_widget => $base
846             , delegate_vars => \%vars, @param));
847             }
848              
849             sub after_define_args {
850 173     173 0 299 (my MY $trans, my ($target)) = @_;
851 173 100       532 unless ($target->has_arg('body')) {
852 154         550 $target->add_arg(body => $trans->create_var('code'));
853             }
854 173         517 $trans;
855             }
856              
857             sub decode_decl_entpath {
858 16     16 0 33 (my MY $trans, my $node) = @_;
859 16         57 my ($has_body, @entpath)
860             = $trans->decode_entpath($node, my $entns = [$node->node_path]);
861              
862 16 100       56 unless ($has_body) {
863 10         40 return $node->node_nsname('', '_');
864             }
865              
866 6         12 my (@macro_name, $rename_spec);
867 6         19 while (@entpath) {
868 6         9 my ($type, $name, @args) = @{shift @entpath};
  6         20  
869 6 50       28 if ($type eq 'var') {
    50          
870 0 0       0 if (@args) {
871             # foo{name,name,...} case.
872 0         0 die $trans->node_nimpl($node);
873             } else {
874 0         0 push @macro_name, $name;
875             }
876             } elsif ($type eq 'call') {
877 6         13 push @macro_name, $name;
878 6         20 foreach my $arg (@args) {
879 6         16 my ($type, $name, @args) = @$arg;
880 6 50       23 if ($type ne 'text') {
    50          
881 0         0 die $trans->node_nimpl($node);
882             } elsif ($rename_spec) {
883 0         0 die $trans->node_nimpl($node); # Error: ()()
884             } else {
885 6         50 $rename_spec = [split /=/, $name, 2];
886             }
887             }
888             } else {
889 0         0 die $trans->nimpl($node);
890             }
891             }
892              
893 6         29 (join("_", @macro_name), $rename_spec);
894             }
895              
896             # For ArgMacro
897             sub add_decl_entity {
898 51     51 0 108 (my MY $trans, my Widget $widget, my ($node)) = @_;
899              
900             # Widget の configure を呼ぶだけ、のケース ← config(value) でどう?
901             {
902 51         200 my $is_sysns = $trans->shift_ns_by(yatt =>
903             my $entns = [$node->node_path]);
904 51 100 66     311 if ($is_sysns && @$entns == 1) {
905 35 50       179 if ($widget->can_configure($entns->[0])) {
906 35         126 $widget->configure($entns->[0], 1);
907 35         161 return;
908             }
909             }
910             }
911              
912             {
913 51         95 my ($macro_name, @args) = $trans->decode_decl_entpath($node);
  16         24  
  16         58  
914              
915 16         69 foreach my $pkg ($trans->get_package_from_widget($widget)) {
916 16         27 my $macro_class = do {
917 16 50       238 my $sub = $pkg->can($macro_name)
918             or next;
919 16         47 $sub->();
920             };
921 16 50       151 unless ($macro_class->can('handle')) {
922 0         0 die $trans->node_error
923             ($node, "ArgMacro doesn't implement ->handle method: %s"
924             , $node->node_name);
925             }
926 16         97 return $macro_class->register_in($trans, $node, $widget, @args);
927             }
928             }
929 0         0 die $trans->node_error($node, "No such ArgMacro: %s"
930             , $node->node_nsname);
931             }
932              
933             #========================================
934             # 変数関連
935              
936 3         24 use YATT::Types [VarType =>
937             [qw(cf_varname ^cf_argno ^cf_subtype
938             cf_default cf_default_mode
939             cf_filename cf_linenum
940             )]]
941 3     3   20 , qw(:export_alias);
  3         6  
942              
943             sub find_var {
944 414     414 0 1074 (my MY $trans, my ($scope, $varName)) = @_;
945 414         1155 for (; $scope; $scope = $scope->[1]) {
946 987 50       2203 croak "Undefined varName!" unless defined $varName;
947 987 100       3810 if (defined (my $value = $scope->[0]{$varName})) {
948 275         1021 return $value;
949             }
950             }
951 139         747 return;
952             }
953              
954             sub find_codearg {
955 145     145 0 546 (my MY $trans, my ($scope, @elempath)) = @_;
956 145 50       453 return if @elempath >= 3;
957 145         551 $trans->strip_ns(\@elempath);
958 145 50       408 return unless @elempath == 1;
959 145 100       526 my $var = $trans->find_var($scope, $elempath[0])
960             or return;
961 40 100 66     416 return unless ref $var and $var->can('arg_specs');
962 38         142 $var;
963             }
964              
965             sub gen_getargs_static {
966 203     203 0 515 (my MY $gen, my Widget $widget, my ($metainfo)) = @_;
967 203         293 my (@args, %scope);
968 203 100       637 foreach my $name ($widget->{arg_order} ? @{$widget->{arg_order}} : ()) {
  161         539  
969 391         879 my VarType $var = $widget->{arg_dict}{$name};
970 391         787 $scope{$name} = $var;
971 391         989 my $decl = sprintf q{my %s = $_[%d]}, $var->as_lvalue, $$var{cf_argno};
972 391         2058 my $value = $var->gen_getarg
973             ($gen, [\%scope], $widget, $metainfo, qq{\$args->[$$var{cf_argno}]});
974 391         1456 push @args, "$decl = $value;\n";
975             }
976 203         1176 join "", @args;
977             }
978              
979             sub gen_getargs_dynamic {
980 203     203 0 1190 '';
981             }
982              
983             sub gen_pass_through_arg_typed {
984 0     0 0 0 (my MY $gen, my ($type, $scope, $baseNC, $targetNode)) = @_;
985 0 0       0 my $node = $targetNode
986             ? $gen->fake_cursor_from($baseNC, $targetNode)
987             : $baseNC;
988 0         0 my $name = $node->node_name;
989 0 0       0 if (my $var = $gen->has_pass_through_var($scope, $node, $name)) {
990 0         0 $var->as_lvalue;
991             } else {
992 0         0 $gen->faked_gentype($type => $scope, $node)
993             }
994             }
995              
996             sub try_pass_through {
997 0     0 0 0 (my MY $trans, my ($scope, $cursor, $rawNode, $defaultFlag)) = @_;
998 0 0 0     0 if (node_size($rawNode) == 1 and node_flag($rawNode) == 0
    0 0        
999             and (my $nm = node_body($rawNode)) =~ /^\w+$/) {
1000              
1001             # [name=bareword_ident]
1002             # Must be an existing variable.
1003 0 0       0 if (my $var = $trans->find_var($scope, $nm)) {
1004 0         0 $var->as_lvalue;
1005             } else {
1006 0         0 die $trans->node_error($cursor, "No such variable '%s'", $nm);
1007             }
1008             } elsif (node_size($rawNode) == 0) {
1009              
1010             # [name]
1011             # variable or flag.
1012 0 0       0 if (my $var = $trans->find_var($scope, my $nm = node_name($rawNode))) {
    0          
1013 0         0 $var->as_lvalue;
1014             } elsif (defined $defaultFlag) {
1015 0         0 $defaultFlag
1016             } else {
1017 0         0 die $trans->node_error($cursor, "No such variable '%s'", $nm);
1018             }
1019             } else {
1020 0         0 undef;
1021             }
1022             }
1023              
1024             sub mark_vars {
1025 102     102 0 233 (my MY $trans, my ($scope, $early_escaped, $node)) = @_;
1026 102         173 my @result;
1027 102         343 for (; $node->readable; $node->next) {
1028 149 100       485 if ($node->node_type == TEXT_TYPE) {
    50          
1029             # XXX: dots_for_arrows
1030 109         280 push @result, $node->current;
1031             } elsif ($node->node_type == ELEMENT_TYPE) {
1032 0         0 push @result, \ $trans->generate_captured($scope, $node);
1033             } else {
1034 40         153 push @result, \ $trans->generate_entref($scope, $early_escaped, $node);
1035             }
1036             }
1037 102         463 @result;
1038             }
1039              
1040             sub feed_array_if {
1041 283     283 0 544 (my MY $trans, my ($name, $array)) = @_;
1042 283 50       652 return unless @$array >= 1;
1043 283 100       1229 return unless $array->[0][0] eq $name;
1044 90         164 my $desc = shift @$array;
1045 90 50       261 wantarray ? @{$desc}[1..$#$desc] : $desc;
  90         433  
1046             }
1047              
1048             # $node の情報を借りながら、@_ を generate.
1049             sub gen_entref_list {
1050 32     32 0 95 (my MY $trans, my ($scope, $node)) = splice @_, 0, 3;
1051 32         62 my @result;
1052 32         75 foreach my $item (@_) {
1053 50 100       177 push @result, $trans->gen_entref_path
1054             ($scope, $node
1055             , is_nested_entpath($item) ? @$item : $item);
1056             }
1057 32         184 @result;
1058             }
1059              
1060             sub gen_entref_path {
1061 90     90 0 262 (my MY $trans, my ($scope, $node)) = splice @_, 0, 3;
1062 90         137 my $var;
1063 90         130 my @expr = do {
1064 90 100       313 if (my ($name, @args) = $trans->feed_array_if(call => \@_)) {
    100          
    100          
    100          
    50          
    50          
1065 16         101 my $pkg = $trans->get_package_from_node($node);
1066 16         32 my $dont_call;
1067 16         31 my $call = do {
1068             # XXX: codevar は、path の先頭だけ。
1069             # 引数にも現れるから、
1070 16 100       203 if ($pkg->can(my $en = "entity_$name")) {
    100          
    100          
    50          
1071 8         55 sprintf('%s->%s', $pkg, $en);
1072             } elsif ($var = $trans->find_codearg($scope, $name)) {
1073 1         4 sprintf('%1$s && %1$s->', $var->as_lvalue);
1074             } elsif ($var = $trans->find_var($scope, $name)) {
1075 1 50       7 if (my $handler = $var->can("entmacro_")) {
1076 1         2 $dont_call++;
1077 1         6 $handler->($var, $trans, $scope, $node, \@_, [], @args);
1078             } else {
1079             # XXX: 本当は $pkg よりもファイル名を出すべき。
1080 0         0 die $trans->node_error
1081             ($node, "not implemented call '%s' for %s in %s"
1082             , $name, $pkg, $node->node_body);
1083             }
1084             } elsif (my $handler = $trans->can("entmacro_$name")) {
1085             # XXX: $pkg->can の方が、拡張向きで良いのだが…
1086             # 予約語も持ちたい。
1087 6         13 $dont_call++;
1088 6         29 $handler->($pkg, $trans, $scope, $node, \@_, [], @args);
1089             } else {
1090 0         0 die $trans->node_error($node, "not implemented call '%s' in %s"
1091             , $name, $node->node_body);
1092             }
1093             };
1094              
1095 16 100 66     141 ($dont_call || ref $call) ? $call : sprintf q{(%s(%s))}, $call, join ", "
1096             , $trans->gen_entref_list($scope, $node, @args);
1097             } elsif (($name) = $trans->feed_array_if(var => \@_)) {
1098 35 50       112 unless ($var = $trans->find_var($scope, $name)) {
1099 0         0 die $trans->node_error($node, "No such variable '%s'", $name);
1100             } else {
1101 35         119 $var->as_lvalue;
1102             }
1103             } elsif (($name) = $trans->feed_array_if(expr => \@_)) {
1104 11         33 $name;
1105             } elsif (my @items = $trans->feed_array_if(array => \@_)) {
1106 2         11 '['.join(", ", $trans->gen_entref_list($scope, $node, @items)).']';
1107             } elsif (my @pairs = $trans->feed_array_if(hash => \@_)) {
1108             # XXX: '=>' is better.
1109 0         0 '{'.join(", ", $trans->gen_entref_list($scope, $node, @pairs)).'}';
1110             } elsif (($name) = $trans->feed_array_if(text => \@_)) {
1111 26         77 qqvalue($name);
1112             } else {
1113 0         0 die $trans->node_error($node, "NIMPL(%s)", terse_dump(@_));
1114             }
1115             };
1116              
1117 90         341 while (@_) {
1118 33         72 my $item = shift;
1119 33         54 push @expr, do {
1120 33         75 my ($type, $name, @args) = @$item;
1121 33 100       120 if ($type eq 'call') {
    100          
    50          
1122             # 先頭の変数が確定している場合の、特殊処理。
1123             # XXX: 同じ名前のメソッドが呼べなくなる、というデメリットが有る。
1124 20 100 33     240 if ($var and not ref $name
      66        
1125             and my $handler = $var->can("entmacro_$name")) {
1126             # ここまでの式を reset する必要が有る時がある。
1127 19         69 $handler->($var, $trans, $scope, $node, \@_, \@expr, @args);
1128             } else {
1129 1         4 sprintf q{%s(%s)}, $name, join ", "
1130             , $trans->gen_entref_list($scope, $node, @args);
1131             }
1132             } elsif ($type eq 'var') {
1133 2 50       10 sprintf '{%s}', join ", ", ref $name
1134             ? $trans->gen_entref_list($scope, $node, $name, @args)
1135             : qqvalue($name);
1136             } elsif ($type eq 'aref') {
1137             # list は本来冗長だが、nest の処理のため。
1138 11 50       54 sprintf '[%s]', join", ", ref $name
1139             ? $trans->gen_entref_list($scope, $node, $name, @args)
1140             : $name;
1141             } else {
1142 0         0 die $trans->node_error($node, "NIMPL(type=$type)");
1143             }
1144             };
1145             }
1146              
1147 90 100       405 @expr > 1 ? join("->", @expr) : $expr[0];
1148             }
1149              
1150             sub find_if_codearg {
1151 156     156 0 392 (my MY $trans, my ($scope, $node, $entpath)) = @_;
1152 156         527 my @entns = $node->node_path;
1153 156 100       555 return unless $trans->strip_ns(\@entns);
1154 155 100       922 return if @entns;
1155 24 100       91 return unless @$entpath == 1;
1156 18 50       59 return unless $entpath->[0][0] eq 'call';
1157 18         30 my ($op, $name, @args) = @{$entpath->[0]};
  18         56  
1158 18 100       66 my $codearg = $trans->find_codearg($scope, $name)
1159             or return;
1160 7         43 ($codearg, @args);
1161             }
1162              
1163             sub decode_entpath {
1164 229     229 0 480 (my MY $trans, my ($node, $entns)) = @_;
1165 229         437 my $has_entns = defined $entns;
1166 229 100       508 unless ($has_entns) {
1167 213         696 $trans->strip_ns($entns = [$node->node_path]);
1168             }
1169 229         992 my $body = $node->node_body;
1170 229 100 100     890 substr($body, 0, 0) = ':' if defined $body and not defined $node->node_name;
1171 229         638 my @entpath = $trans->parse_entpath(join('', map {':'.$_} @$entns)
  194         1051  
1172             . coalesce($body, '')
1173             , $trans, $node);
1174              
1175 227 100       646 my $has_body = $body ? 1 : 0;
1176              
1177 227 100       931 $has_entns ? ($has_body, @entpath) : ($entns, $has_body, @entpath);
1178             }
1179              
1180             sub generate_entref {
1181 213     213 0 540 (my MY $trans, my ($scope, $escaped, $node)) = @_;
1182              
1183 213         767 my ($entns, $has_body, @entpath) = $trans->decode_entpath($node);
1184              
1185             # 特例。&yatt:codevar(); は、副作用で print.
1186 211 100 100     1099 if ($escaped == ENT_PRINTED
1187             and my ($codearg, @args)
1188             = $trans->find_if_codearg($scope, $node, \@entpath)) {
1189             return \ sprintf('%1$s && %1$s->(%2$s)', $codearg->as_lvalue
1190             , join(", ", map {
1191 7         22 $trans->gen_entref_path($scope, $node, $_)
  0         0  
1192             } @args));
1193             # 引数。
1194             }
1195 204 100 66     1142 if ($has_body || @$entns > 1) {
1196             # path が有る。
1197 40         179 my $expr = $trans->gen_entref_path($scope, $node, @entpath);
1198             # XXX: sub { print } なら \ $expr にすべきだが、
1199             # sub { value } などは、むしろ YATT::escape(do {$expr}) すべき。
1200 40 100       139 return $expr if ref $expr;
1201 38 100       367 return $escaped ? qq(YATT::escape($expr)) : $expr;
1202             }
1203              
1204 164         311 my $varName = shift @$entns;
1205 164 100       538 unless (my $vardecl = $trans->find_var($scope, $varName)) {
1206 7         38 die $trans->node_error($node, "No such variable '%s'", $varName);
1207             } else {
1208 157 100       601 $escaped ? $vardecl->as_escaped : $vardecl->as_lvalue;
1209             }
1210             }
1211              
1212             #========================================
1213             # マクロなどで、cursor になっていない targetNode を入手した後で、
1214             # それを再び cursor にして、指定の型のソースを生成する仕組み。
1215              
1216             # デフォルト値を最初に指定。
1217             sub default_gentype {
1218 0     0 0 0 (my MY $trans, my ($default, $type, $scope, $baseNC, $targetNode)) = @_;
1219 0 0       0 if (ref $type) {
1220 0         0 croak "Type mismatch: \$type should be string for default_gentype: $type";
1221             }
1222 0 0 0     0 unless (defined $targetNode and node_body($targetNode)) {
1223 0         0 return $default;
1224             }
1225             # my $name = node_name($targetNode);
1226             # if (my $var
1227             # = $trans->has_pass_through_var($scope, $targetNode, $name)) {
1228             # $var->as_lvalue;
1229             # } else {
1230 0         0 $trans->faked_gentype($type, $scope, $baseNC, $targetNode);
1231             # }
1232             }
1233              
1234             sub faked_gentype {
1235 2     2 0 5 (my MY $trans, my ($type, $scope, $baseNC, $targetNode)) = @_;
1236 2 50       7 my $node = $targetNode ? $trans->fake_cursor_from($baseNC, $targetNode)
1237             : $baseNC;
1238 2 50       14 my $sub = $trans->can("t_$type")
1239             or die $trans->node_error($node, "No such argtype: %s", $type);
1240 2         15 $sub->()->gen_assignable_node($trans, $scope, $node);
1241             }
1242              
1243             # expr 専用。デフォルト値も渡せる。
1244             sub faked_genexpr {
1245 0     0 0 0 (my MY $trans, my ($scope, $baseNC, $targetNode, $default, $ent_flag)) = @_;
1246 0 0 0     0 unless (defined $targetNode and node_body($targetNode)) {
1247 0         0 return $default;
1248             }
1249             # open するのが、faked_gentype(scalar) とも違う所、のはず。
1250 0         0 my $nc = $trans->fake_cursor_from($baseNC, $targetNode)->open;
1251 0 0       0 $trans->genexpr_node($scope, defined $ent_flag ? $ent_flag : ENT_RAW
1252             , $nc);
1253             }
1254              
1255             #========================================
1256              
1257             sub YATT::Translator::Perl::VarType::gen_getarg {
1258 391     391 0 934 (my VarType $var, my MY $gen
1259             , my ($scope, $widget, $metainfo, $actual)) = @_;
1260             return $actual unless defined $var->{cf_default}
1261 391 100 100     1842 and defined (my $mode = $var->{cf_default_mode});
1262              
1263 12 100       41 if ($mode eq "!") {
1264 2         12 return qq{defined $actual ? $actual : }
1265             . qq{die "Argument '$var->{cf_varname}' is undef!"}
1266             }
1267              
1268 10         16 my ($cond) = do {
1269 10 100       52 if ($mode eq "|") {
    100          
    50          
1270 2         4 qq{$actual}
1271             } elsif ($mode eq "?") {
1272 6         21 qq{defined $actual && $actual ne ""}
1273             } elsif ($mode eq "/") {
1274 2         5 qq{defined $actual}
1275             } else {
1276 0         0 die "Unknown defaulting mode: $mode"
1277             }
1278             };
1279              
1280             my $default = $var->gen_assignable_node
1281             ($gen, $scope
1282             , $gen->fake_cursor($widget, $metainfo
1283 10 100       64 , map {ref $_ ? @$_ : $_} $var->{cf_default})
1284 10         27 , 1);
1285              
1286 10         81 qq{($cond ? $actual : $default)};
1287             }
1288              
1289             sub YATT::Translator::Perl::VarType::gen_assignable_node {
1290 67     67 0 205 (my VarType $var, my MY $trans, my ($scope, $node, $is_opened)) = @_;
1291             # early escaped な変数への代入値は、代入前に escape される。
1292 67         228 my $escaped = $var->early_escaped;
1293 67 100       309 $var->quote_assignable
1294             ($trans->mark_vars($scope, $escaped, $is_opened ? $node : $node->open));
1295             }
1296              
1297             sub YATT::Translator::Perl::VarType::is_required {
1298 62     62 0 98 my VarType $var = shift;
1299 62 100       424 defined $var->{cf_default_mode} && $var->{cf_default_mode} eq '!';
1300             }
1301              
1302 0     0 0 0 sub YATT::Translator::Perl::VarType::can_call { 0 }
1303 103     103 0 247 sub YATT::Translator::Perl::VarType::early_escaped { 0 }
1304 929     929 0 4571 sub YATT::Translator::Perl::VarType::lvalue_format {'$%s'}
1305             sub YATT::Translator::Perl::VarType::as_lvalue {
1306 956     956 0 1309 my VarType $var = shift;
1307 956         2136 sprintf $var->lvalue_format, $var->{cf_varname};
1308             }
1309              
1310 107     107 0 1013 sub YATT::Translator::Perl::VarType::escaped_format {'YATT::escape($%s)'}
1311              
1312             sub YATT::Translator::Perl::VarType::as_escaped {
1313 123     123 0 180 my VarType $var = shift;
1314 123         342 sprintf $var->escaped_format, $var->{cf_varname};
1315             }
1316              
1317             sub YATT::Translator::Perl::VarType::as_typespec {
1318 0     0 0 0 shift->type_name;
1319             }
1320              
1321             sub YATT::Translator::Perl::VarType::as_argspec {
1322 0     0 0 0 (my VarType $var) = @_;
1323 0         0 my $spec = $var->as_typespec;
1324 0 0       0 if (my $mode = $var->{cf_default_mode}) {
1325 0         0 $spec .= $mode;
1326 0 0       0 if (defined (my $default = $var->{cf_default})) {
1327             $spec .= join "", map {
1328 0 0       0 ref $_ ? map(ref $_ ? stringify_node($_) : $_, @$_) : $_
  0 0       0  
1329             } $default;
1330             }
1331             }
1332 0         0 $spec;
1333             }
1334              
1335             use YATT::ArgTypes
1336 3         49 (-type_map => \%TYPE_MAP
1337             , -base => VarType
1338             , -type_fmt => join("::", MY, 't_%s')
1339             , [text => -alias => '']
1340             , [html => \ lvalue_format => '$html_%s', \ early_escaped => 1]
1341             , [scalar => -alias => ['value', 'flag']]
1342             , ['list']
1343             , [attr => -base => 'text']
1344             , [code => -alias => 'expr', \ can_call => 1
1345             # 引数の型情報
1346             , -fields => [qw(arg_dict arg_order)]]
1347             , [delegate => -fields => [qw(cf_base_path
1348             cf_base_widget
1349             cf_delegate_vars)]]
1350             , qw(:type_name)
1351 3     3   1310 );
  3         8  
1352              
1353             $calling_conv{this} = t_scalar->new(varname => 'this');
1354             $calling_conv{args} = t_scalar->new(varname => 'args');
1355             $calling_conv{_} = t_scalar->new(varname => '_');
1356              
1357             sub YATT::Translator::Perl::t_text::quote_assignable {
1358 45     45   75 shift;
1359 45         82 my ($nvars);
1360             my @items = map {
1361 45 100       89 if (ref $_) {
  53         129  
1362 7         15 $nvars++;
1363 7         19 $$_
1364             } else {
1365             # $var is prohibited.
1366 46         141 qparen($_);
1367             }
1368             } @_;
1369 45 100 100     243 if (@items == 1 && !$nvars) {
1370 39         202 $items[0];
1371             } else {
1372 6         43 MY->as_join(@items);
1373             }
1374             }
1375              
1376             # XXX: 本当に良いのか?
1377             sub YATT::Translator::Perl::t_html::quote_assignable {
1378 0     0   0 shift;
1379 0         0 sprintf q{YATT::escape(%s)}, t_text->quote_assignable(@_);
1380             }
1381              
1382 16     16   186 sub YATT::Translator::Perl::t_html::escaped_format {shift->lvalue_format}
1383              
1384             sub YATT::Translator::Perl::t_html::gen_assignable_node {
1385 6     6   16 (my VarType $var, my MY $trans, my ($scope, $node, $is_opened)) = @_;
1386             # XXX: フラグがダサい。
1387 6 100       22 my $n = $is_opened ? $node : $node->open;
1388 6 100       26 if (my $expr = $trans->has_single_bare_varexpr($scope, $n)) {
1389 1         5 t_scalar->quote_assignable($expr);
1390             } else {
1391 5         17 $trans->as_join($trans->generate_body($scope, $n));
1392             }
1393             }
1394              
1395             sub YATT::Translator::Perl::t_attr::as_typespec {
1396 0     0   0 my t_attr $var = shift;
1397 0   0     0 join(":", $var->type_name, $var->{cf_subtype} || $var->{cf_varname});
1398             }
1399              
1400              
1401             sub YATT::Translator::Perl::t_attr::entmacro_ {
1402 1     1   3 (my t_attr $var, my MY $trans
1403             , my ($scope, $node, $restExpr, $queue, @args)) = @_;
1404 1 50       5 if (@$restExpr) {
1405 0         0 die $trans->node_error($node, "attr() should be last call.");
1406             }
1407 1 50       5 if (ref $var->{cf_subtype}) {
1408 0         0 die $trans->node_error($node, "nested subtype for attr");
1409             }
1410 1         6 my @expr = $trans->gen_entref_list($scope, $node, @args);
1411             sprintf(q{YATT::attr('%s', %s)}
1412             , $var->{cf_subtype} || $var->{cf_varname}
1413 1   33     8 , join(", ", $var->as_lvalue, @expr));
1414             }
1415              
1416             sub YATT::Translator::Perl::t_attr::as_escaped {
1417 4     4   8 my t_attr $var = shift;
1418 4 50       16 if (ref $var->{cf_subtype}) {
1419 0         0 die "nested subtype for attr: $var->{cf_varname}";
1420             }
1421 4         18 my $realvar = sprintf $var->lvalue_format, $var->{cf_varname};
1422             sprintf(q{YATT::named_attr('%s', %s)}
1423             , $var->{cf_subtype} || $var->{cf_varname}
1424 4   33     38 , $realvar);
1425             }
1426              
1427             sub YATT::Translator::Perl::t_scalar::quote_assignable {
1428 13     13   26 shift;
1429 13 100       34 'scalar(do {'.join("", map { ref $_ ? $$_ : $_ } @_).'})';
  21         141  
1430             }
1431              
1432             sub YATT::Translator::Perl::t_list::quote_assignable {
1433 13     13   28 shift;
1434 13 100       38 '['.join("", map { ref $_ ? $$_ : $_ } @_).']';
  25         151  
1435             }
1436              
1437             sub YATT::Translator::Perl::t_list::entmacro_expand {
1438 17     17   45 (my t_list $var, my MY $trans
1439             , my ($scope, $node, $restExpr, $queue, @args)) = @_;
1440 17         55 my $was = join "->", splice @$queue, 0;
1441 17         117 sprintf q{map($_ ? @$_ : (), %s)}, $was;
1442             }
1443              
1444             sub YATT::Translator::Perl::t_list::entmacro_size {
1445 2     2   6 (my t_list $var, my MY $trans
1446             , my ($scope, $node, $restExpr, $queue, @args)) = @_;
1447 2         8 my $was = join "->", splice @$queue, 0;
1448 2         15 sprintf q{scalar(map(defined $_ ? @$_ : (), %s))}, $was;
1449             }
1450              
1451             # XXX: head($n), tail($n)
1452              
1453             sub YATT::Translator::Perl::t_list::entmacro_head {
1454 0     0   0 (my t_list $var, my MY $trans
1455             , my ($scope, $node, $restExpr, $queue, @args)) = @_;
1456 0         0 my $was = join "->", splice @$queue, 0;
1457 0         0 sprintf q{map($_ ? $$_[0] : (), %s)}, $was;
1458             }
1459              
1460             sub YATT::Translator::Perl::t_list::entmacro_tail {
1461 0     0   0 (my t_list $var, my MY $trans
1462             , my ($scope, $node, $restExpr, $queue, @args)) = @_;
1463 0         0 my $was = join "->", splice @$queue, 0;
1464 0         0 sprintf q{map($_ ? @{$_}[1..$#$_] : (), %s)}, $was;
1465             }
1466              
1467             sub YATT::Translator::Perl::t_code::gen_call {
1468 25     25   54 (my t_code $argdecl, my MY $trans, my ($scope, $node)) = @_;
1469 25         112 my ($post, @args) = $trans->genargs_static
1470             ($scope, $node->open, $argdecl->arg_specs);
1471             # XXX: こっちを () しなくて済むのはなぜ? => の call だから?
1472 25         145 return \ sprintf '%1$s && %1$s->(%2$s)%3$s', $argdecl->as_lvalue
1473             , join(", ", @args), $post;
1474             }
1475              
1476             sub YATT::Translator::Perl::t_code::arg_specs {
1477 31     31   64 my t_code $argdecl = shift;
1478 31   100     325 ($argdecl->{arg_dict} ||= {}, $argdecl->{arg_order} ||= []);
      100        
1479             }
1480              
1481             sub YATT::Translator::Perl::t_code::gen_args {
1482 39     39   160 (my t_code $argdecl) = @_;
1483             return unless $argdecl->{arg_order}
1484 39 100 100     219 && (my @args = @{$argdecl->{arg_order}});
  16         126  
1485             \ sprintf('my (%s) = @_', join(", ", map {
1486 9         30 $argdecl->{arg_dict}{$_}->as_lvalue;
  10         46  
1487             } @args));
1488             }
1489              
1490             sub YATT::Translator::Perl::t_code::gen_body {
1491 40     40   119 (my t_code $argdecl, my MY $trans, my ($scope, $is_expr, $node)) = @_;
1492 40 50       153 return unless $node->array_size;
1493 40 100       110 if ($is_expr) {
1494 1         4 $trans->genexpr_node($scope, ENT_RAW, $node);
1495             } else {
1496             $trans->as_statement_list
1497             ($argdecl->gen_args
1498 39         116 , $trans->generate_body([{}, [$argdecl->{arg_dict}, $scope]], $node));
1499             }
1500             }
1501              
1502             sub YATT::Translator::Perl::t_code::gen_assignable_node {
1503 40     40   101 (my t_code $argdecl, my MY $trans, my ($scope, $node, $is_opened)) = @_;
1504 40   100     143 my $is_expr = !$is_opened && !$node->is_quoted_by_element;
1505 40 100       182 $trans->as_sub('', $argdecl->gen_body($trans, $scope, $is_expr
1506             , $is_opened ? $node : $node->open));
1507             }
1508              
1509             sub YATT::Translator::Perl::t_code::has_arg {
1510 12     12   26 (my t_code $argdecl, my ($name)) = @_;
1511 12         54 defined $argdecl->{arg_dict}{$name};
1512             }
1513              
1514             sub YATT::Translator::Perl::t_code::add_arg {
1515 13     13   41 (my t_code $codevar, my ($name, $arg)) = @_;
1516 13         72 add_arg_order_in($codevar->{arg_dict}, $codevar->{arg_order}, $name, $arg);
1517 13         64 $codevar;
1518             }
1519              
1520             sub YATT::Translator::Perl::t_code::clone {
1521 6     6   15 (my t_code $orig) = @_;
1522 6         38 my t_code $new = $orig->SUPER::clone;
1523 6         37 my ($dict, $order) = $orig->arg_specs;
1524 6         21 foreach my $name (@$order) {
1525 1         6 $new->add_arg($name, $dict->{$name}->clone);
1526             }
1527             $new
1528 6         23 }
1529              
1530             # code 型の変数宣言の生成
1531             sub create_var_code {
1532 172     172 0 384 (my MY $trans, my ($node, @param)) = @_;
1533 172         1450 my t_code $codevar = $trans->t_code->new(@param);
1534 172 100       449 $trans->define_args($codevar, $node->open) if $node;
1535 172         847 $codevar;
1536             }
1537              
1538             sub YATT::Translator::Perl::t_delegate::gen_call {
1539 5     5   16 (my t_delegate $argdecl, my MY $trans, my ($scope, $node)) = @_;
1540             my $func = $trans->get_funcname_to($trans->{cf_mode}
1541 5         21 , $argdecl->{cf_base_widget});
1542             # XXX: テストを書け。body が code か html か、だ。
1543             # my $body_dict = $argdecl->{cf_base_widget}->get_arg_spec(body => undef);
1544 5         12 my $body_spec = $argdecl->{cf_base_widget}->{arg_dict}->{body};
1545 5         12 my $body_scope = do {
1546 5 50       26 if ($body_spec->type_name eq 'code') {
1547 5         18 [$body_spec->{arg_dict}, $scope]
1548             } else {
1549 0         0 $scope
1550             }
1551             };
1552 5         26 my ($post, @args) = $trans->genargs_static
1553             ([{}, $body_scope]
1554             , $node->open, $argdecl->arg_specs);
1555             return \ sprintf(' %s($this, [%s])%s', $func
1556 5 50       27 , join(", ", map {defined $_ ? $_ : 'undef'} @args)
  18         93  
1557             , $post);
1558             }
1559              
1560             sub YATT::Translator::Perl::t_delegate::arg_specs {
1561 5     5   14 my t_delegate $argdecl = shift;
1562             ($argdecl->{cf_base_widget}->arg_specs
1563 5         28 , $argdecl->{cf_delegate_vars});
1564             }
1565              
1566             #========================================
1567              
1568             sub make_arg_spec {
1569 7     7 0 19 my ($dict, $order) = splice @_, 0, 2;
1570 7         14 foreach my $name (@_) {
1571 19         41 $dict->{$name} = @$order;
1572 19         40 push @$order, $name;
1573             }
1574             }
1575              
1576             sub arg_name_types {
1577 109     109 0 200 (my MY $trans, my ($args)) = @_;
1578 109         335 my (@path) = $args->node_path;
1579 109 100 66     347 if ($args->is_attribute and $args->is_quoted_by_element) {
1580 8         15 shift @path;
1581             }
1582 109         259 my ($name) = shift @path;
1583 109 50       476 @path >= 2 ? ($name, \@path) : ($name, $path[0]);
1584             }
1585              
1586             # macro の、 my:type=var など専用。
1587             sub feed_arg_spec {
1588 14     14 0 46 (my MY $trans, my ($args, $arg_dict, $arg_order)) = splice @_, 0, 4;
1589 14         27 my $found;
1590 14         58 for (my $nth = 0; $args->readable; $args->next) {
1591 31 100       103 last unless $args->is_primary_attribute;
1592 17         57 my ($name, @ext) = $args->node_path;
1593 17 100       48 unless (defined $name) {
1594 4 50       21 $name = $arg_order->[$nth++]
1595             or die $trans->node_error($args, "Too many args");
1596             }
1597 17 50       65 defined (my $argno = $arg_dict->{$name})
1598             or die $trans->node_error($args, "Unknown arg '%s'", $name);
1599              
1600 17         54 $_[$argno] = $args->current;
1601 17         64 $found++;
1602             }
1603 14         52 $found;
1604             }
1605              
1606             {
1607             # list=list/value, my=text, ith=text
1608             make_arg_spec(\ my %arg_dict, \ my @arg_order
1609             , qw(list my ith));
1610              
1611             declare_alias macro_yatt_foreach => \¯o_foreach;
1612             sub macro_foreach {
1613 6     6 0 17 (my MY $trans, my ($scope, $args, $fragment)) = @_;
1614              
1615 6 50       34 $trans->feed_arg_spec($args, \%arg_dict, \@arg_order
1616             , my ($list, $my, $ith))
1617             or die $trans->node_error($args, "Not enough arguments");
1618              
1619 6 50       24 unless (defined $list) {
1620 0         0 die $trans->node_error($args, "no list= is given");
1621             }
1622              
1623             # $ith をまだ使っていない。
1624 6         13 my %local;
1625 6         12 my $loopvar = do {
1626 6 100       32 if ($my) {
1627 5         20 my ($x, @type) = node_path($my);
1628 5         26 my $varname = node_body($my);
1629 5   50     54 $local{$varname} = $trans->create_var
1630             ($type[0] || '', undef, varname => $varname);
1631 5         19 'my $' . $varname;
1632             } else {
1633             # _ は? entity 自体に処理させるか…
1634 1         3 ''
1635             }
1636             };
1637              
1638 6         13 my $fmt = q{foreach %1$s (%2$s) %3$s};
1639 6         11 my $listexpr = do {
1640 6         8 if (0) {
1641             print STDERR "# foreach list: "
1642             , YATT::LRXML::Node::stringify_node($list), "\n";
1643             }
1644             # XXX: 何故使い分けが必要になってしまうのか?
1645             # my $fc = $args->adopter_for($list);
1646             # my $fc = $trans->fake_cursor_from($args, $list);
1647 6 100       30 if (my $var = $trans->has_pass_through_var
1648             ($scope, my $fc = $trans->fake_cursor_from($args, $list), 'list')) {
1649 3 100       20 unless ($var->type_name eq 'list') {
1650 1         7 my $path = $args->parent->node_path;
1651 1         10 die $trans->node_error($fc, "$path - should be list type")
1652             }
1653 2         8 '@'.$var->as_lvalue;
1654             } else {
1655 3         16 $trans->genexpr_node($scope, 0, $args->adopter_for($list));
1656             }
1657             };
1658 5         59 my @statements = $trans->as_statement_list
1659             ($trans->generate_body([\%local, $scope], $args));
1660              
1661 5 50       24 if ($fragment) {
1662 0         0 ($fmt, $loopvar, $listexpr, \@statements);
1663             } else {
1664 5         20 \ sprintf $fmt, $loopvar, $listexpr, $trans->as_block(@statements);
1665             }
1666             }
1667             }
1668              
1669             {
1670             # if
1671             make_arg_spec(\ my %arg_dict, \ my @arg_order
1672             , qw(if unless));
1673             sub gen_macro_if_arm {
1674 8     8 0 23 (my MY $trans, my ($scope, $primary, $pkg, $if, $unless, $body)) = @_;
1675 8         16 my $header = do {
1676 8 100       17 if ($primary) {
1677 5         10 my ($kw, $cond) = do {
1678 5 50       15 if ($if) { (if => $if) }
  5 0       13  
1679 0         0 elsif ($unless) { (unless => $unless) }
1680 0         0 else { die "??" }
1681             };
1682 5         31 sprintf q{%s (%s) }, $kw
1683             , $trans->genexpr_node($scope, 0
1684             , $trans->fake_cursor_from($body, $cond, 1));
1685             } else {
1686 3         4 my ($cond, $true) = do {
1687 3 100       13 if ($if) { ($if, 1) }
  1 50       3  
1688 0         0 elsif ($unless) { ($unless, 0) }
1689             else {}
1690             };
1691 3 100       8 unless (defined $cond) {
1692 2         7 q{else }
1693             } else {
1694 1         5 my $expr = $trans->genexpr_node
1695             ($scope, 0
1696             , $trans->fake_cursor_from($body, $cond, 1));
1697 1 50       9 sprintf q{elsif (%s) }, $true ? $expr : qq{not($expr)};
1698             }
1699             }
1700             };
1701 8         45 $header . $trans->as_block
1702             ($trans->as_statement_list
1703             ($trans->generate_body($scope, $body)));
1704             }
1705              
1706             declare_alias macro_yatt_if => \¯o_if;
1707             sub macro_if {
1708 5     5 0 14 (my MY $trans, my ($scope, $args)) = @_;
1709              
1710 5         10 my @case = do {
1711 5 50       29 $trans->feed_arg_spec($args, \%arg_dict, \@arg_order
1712             , my ($if, $unless))
1713             or die $trans->node_error($args, "Not enough arguments");
1714 5         20 ([$if, $unless, $args->variant_builder]);
1715             };
1716 5         23 for (; $args->readable; $args->next) {
1717 12 100 66     37 if ($args->is_attribute && $args->node_name eq 'else') {
1718 3         10 my $kid = $args->open;
1719 3         12 $trans->feed_arg_spec($kid, \%arg_dict, \@arg_order
1720             , my ($if, $unless));
1721 3         16 push @case, [$if, $unless, $kid];
1722             } else {
1723             # XXX: 多分、$case[0]
1724 9         33 $case[-1][-1]->add_node($args->current);
1725             }
1726             }
1727              
1728 5         30 my $pkg = $trans->get_package_from_node($args);
1729 5         11 my @script = $trans->gen_macro_if_arm($scope, 1, $pkg, @{shift @case});
  5         23  
1730 5         43 while (my $arm = shift @case) {
1731 3         11 push @script, $trans->gen_macro_if_arm($scope, 0, $pkg, @$arm);
1732             }
1733 5         36 \ join " ", @script;
1734             }
1735             }
1736              
1737             {
1738             declare_alias macro_yatt_block => \¯o_block;
1739             sub macro_block {
1740 3     3 0 7 (my MY $trans, my ($scope, $args)) = @_;
1741 3         14 \ $trans->as_block
1742             ($trans->as_statement_list
1743             ($trans->generate_body([{}, $scope], $args)));
1744             }
1745              
1746             declare_alias macro_yatt_my => \¯o_my;
1747             sub macro_my {
1748 6     6 0 16 (my MY $trans, my ($scope, $args)) = @_;
1749 6         13 my @assign;
1750 6         23 my $filename = $args->metainfo->filename;
1751 6         39 for (; $args->readable; $args->next) {
1752 8 100       36 last unless $args->is_primary_attribute;
1753 7         32 my ($name, $typename) = $trans->arg_name_types($args);
1754 7 100 66     47 $typename ||= $args->next_is_body ? 'html' : 'text';
1755 7 50       26 if (my VarType $old = $scope->[0]{$name}) {
1756             die $trans->node_error
1757             ($args, "Variable '%s' redefined (previously at file %s line %s)"
1758             , $name, $old->{cf_filename} || '(unknown)'
1759 0   0     0 , $old->{cf_linenum} || '(unknown)');
      0        
1760             }
1761 7         35 my $var = $scope->[0]{$name}
1762             = $trans->create_var($typename, $args
1763             , varname => $name
1764             , filename => $filename
1765             , linenum => $args->linenum);
1766              
1767 7 100       35 push @assign, [$var, $args->node_size
1768             ? $var->gen_assignable_node($trans, $scope, $args)
1769             : ()];
1770             }
1771              
1772 6 100       22 if ($args->readable) {
1773 1         4 my $var = $assign[-1][0];
1774 1   33     14 $assign[-1][1] ||= $var->gen_assignable_node($trans, $scope, $args, 1);
1775             }
1776              
1777 6         11 my @script;
1778 6         15 foreach my $desc (@assign) {
1779 7         17 my ($var, $value) = @$desc;
1780 7         23 my $script = sprintf q{my %s}, $var->as_lvalue;
1781 7 100       25 $script .= q{ = } . $value if defined $value;
1782 7         44 push @script, \ $script;
1783             }
1784 6         37 @script;
1785             }
1786             }
1787              
1788             {
1789             declare_alias macro_yatt_format => \¯o_format;
1790             sub macro_format {
1791 3     3 0 7 (my MY $trans, my ($scope, $args)) = @_;
1792              
1793 3 50 33     12 unless ($args->readable && $args->is_primary_attribute) {
1794 0         0 die $trans->node_error($args, "format parameter is missing");
1795             }
1796              
1797 3         12 my $name = $args->node_name;
1798              
1799 3         5 my $format = do {
1800 3 100       15 if (my $var = $trans->has_pass_through_var($scope, $args, $name)) {
1801 1         5 $var->as_lvalue;
1802             } else {
1803 2         12 $trans->faked_gentype(text => $scope, $args);
1804             }
1805             };
1806              
1807 3         22 $args->next;
1808              
1809 3         15 sprintf(q|sprintf(%s, %s)|
1810             , $format
1811             , $trans->as_join($trans->generate_body([{}, $scope], $args)));
1812             }
1813             }
1814              
1815             sub macro_dbfetch {
1816 0     0 0 0 require YATT::Translator::Perl::macro_dbfetch;
1817 0         0 shift->YATT::Translator::Perl::macro_dbfetch::macro(@_);
1818             }
1819              
1820             sub feed_arg_or_make_hash_of {
1821 0     0 0 0 (my $trans
1822             , my ($type, $scope, $args, $arg_dict, $arg_order)) = splice @_, 0, 6;
1823 0         0 my (@primary, @secondary);
1824 0         0 for (my $nth = 0; $args->readable; $args->next) {
1825 0 0       0 last unless $args->is_primary_attribute;
1826 0         0 my ($name, @ext) = $args->node_path;
1827 0 0       0 unless (defined $name) {
1828 0 0       0 $name = $arg_order->[$nth++]
1829             or die $trans->node_error($args, "Too many args");
1830             }
1831 0 0       0 if ($name =~ /^-(.*)/) {
1832             # XXX: そもそも -name=[...] で構造化したかった
1833 0         0 push @secondary, [$name, $trans->faked_gentype
1834             ($type => $scope, $args, $args->current)];
1835 0         0 next;
1836             }
1837 0 0       0 defined (my $argno = $arg_dict->{$name}) or do {
1838 0         0 push @primary, [$name, $trans->faked_gentype
1839             ($type => $scope, $args, $args->current)];
1840 0         0 next;
1841             };
1842              
1843 0         0 $_[$argno] = $args->current;
1844             }
1845 0 0       0 grep {@$_ ? $_ : ()} (\@primary, \@secondary);
  0         0  
1846             }
1847              
1848             #========================================
1849             sub entmacro_if {
1850 4     4 0 13 my ($this, $trans
1851             , $scope, $node, $restExpr, $queue, @args) = @_;
1852             # XXX: $cond を文字列にするのは不便。
1853 4         18 my ($cond, $then, $else)
1854             = $trans->gen_entref_list($scope, $node, @args);
1855             # XXX: 三項演算だと、狂いが出そうな。
1856             sprintf q{((%s) ? %s : %s)}
1857 4 50 50     19 , map {ref $_ ? $$_ : $_} $cond, $then, $else || q{''};
  12         63  
1858             };
1859              
1860             sub entmacro_render {
1861 2     2 0 6 my ($this, $trans
1862             , $scope, $node, $restExpr, $queue, @args) = @_;
1863 2         9 my ($type, @expr)
1864             = $trans->gen_entref_list($scope, $node, @args);
1865 2         16 \ sprintf q{__PACKAGE__->can('render_'.%s)->($this, [%s])}
1866             , $type, join(", ", @expr);
1867             };
1868             #========================================
1869              
1870             sub paren_escape ($) {
1871 352 50   352 0 838 unless (defined $_[0]) {
1872 0         0 confess "Undefined text";
1873             }
1874 352         769 $_[0] =~ s{([\(\)\\])}{\\$1}g;
1875 352         2445 $_[0]
1876             }
1877              
1878             sub qparen ($) {
1879 352     352 0 884 'q('.paren_escape($_[0]).')'
1880             }
1881              
1882             sub qqvalue ($) {
1883 26     26 0 72 'q'.qparen($_[0]);
1884             }
1885              
1886             {
1887             my %map = ("\r", "r", "\n", "n");
1888             sub qcrlf ($) {
1889 129     129 0 241 my ($crlf) = @_;
1890 129         924 $crlf =~ s{([\r\n])}{\\$map{$1}}g;
1891 129         1094 $crlf;
1892             }
1893             }
1894              
1895             sub dots_for_arrows {
1896 31     31 0 49 shift;
1897 31 50       92 return unless defined $_[0];
1898 31         73 $_[0] =~ s{\b\.(?=\w+\()}{->}g;
1899 31         122 $_[0];
1900             }
1901              
1902             1;