File Coverage

web/cgi-bin/yatt.lib/YATT/ArgMacro.pm
Criterion Covered Total %
statement 138 163 84.6
branch 36 52 69.2
condition 10 23 43.4
subroutine 24 26 92.3
pod 0 14 0.0
total 208 278 74.8


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2 3     3   4016 package YATT::ArgMacro; use YATT::Inc;
  3         5  
  3         21  
3 3     3   10 use strict;
  3         7  
  3         87  
4 3     3   10 use warnings FATAL => qw(all);
  3         4  
  3         113  
5 3     3   10 use base qw(YATT::Class::Configurable);
  3         2  
  3         208  
6 3     3   12 use Carp;
  3         3  
  3         167  
7              
8 3     3   12 use YATT::Util qw(checked_eval);
  3         3  
  3         103  
9 3     3   13 use YATT::Util::Symbol qw(globref fields_hash_of_class define_const);
  3         6  
  3         126  
10 3         152 use YATT::LRXML::Node qw(copy_array copy_node_renamed_as
11 3     3   12 create_node_from node_name node_size);
  3         5  
12              
13 3     3   14 use YATT::Fields 'spec', [disabled => 0];
  3         4  
  3         20  
14              
15 12     12 0 45 sub initargs { qw(spec) }
16              
17             use YATT::Types
18 3         30 [Spec => [qw(cf_name cf_classname
19             cf_base
20             cf_in
21             cf_out
22             cf_edit
23             cf_rename_spec
24             cf_disabled
25             trigger
26             output
27             output_map
28             prototype
29             )]]
30             , [Slot => [qw(cf_name cf_classname cf_call_spec
31             cf_spec cf_mode cf_type cf_doc)]]
32 3     3   12 ;
  3         5  
33              
34             #========================================
35              
36             sub handle {
37 0     0 0 0 my ($macro, $trans, $scope, $node, $widget) = @_;
38 0         0 $macro->accept($trans, $scope, $node, $widget);
39 0         0 $node;
40             }
41              
42             sub expand_all_macros {
43 11     11 0 31 my ($pack, $trans, $scope, $node, $widget, $trigger, $order) = @_;
44 11         46 my $copy = $node->variant_builder;
45 11         44 $copy->add_filtered_copy($node->clone, [\&filter, $trigger, \ my %found]);
46 11 100       72 if (%found) {
47 10         25 foreach my Spec $spec (@$order) {
48 12 50       36 my MY $macro = $found{$spec->refid} or next;
49             # XXX: disabled だけれど、他にも config がある場合は、エラーにすべき。
50 12 100       46 if ($macro->{disabled}) {
51 5         22 $spec->revert_into($copy, $macro);
52 5         10 next;
53             }
54 7         297 $copy = $macro->handle($trans, $scope, $copy, $widget);
55             }
56 10         84 $copy;
57             } else {
58 1         8 $node;
59             }
60             }
61              
62             sub filter {
63 18     18 0 34 my ($trigger, $unique, $name, $value) = @_;
64 18 100       55 if (my Slot $slot = $trigger->{$name}) {
65             # ここで、rename が関係する
66 17   66     81 my MY $macro = $unique->{$slot->{cf_spec}->refid}
67             ||= $slot->{cf_classname}->new($slot->{cf_spec});
68 17 100 100     96 if ($macro->{disabled} or my $out = $slot->is_output) {
69             # 出力引数が明示的に与えられていた場合は、disabled モードにする。
70 6         12 $macro->{disabled} = 1;
71             # 元の引数を残す
72             # rename 済みの override を返す。
73 6 100       30 unless ($out) {
    50          
74 1         6 copy_array($value);
75             } elsif (node_size($value)) {
76             # label_list=lh ===> label=lh
77 5         17 MY->copy_node_renamed_as($macro->output_name, $value);
78             } else {
79             # header_list ===> header=header_list
80 0         0 MY->create_node_from($value
81             , $macro->output_name
82             , node_name($value));
83             }
84             } else {
85             # text になってないと、不便では?
86             # ← でも、<:att>.... の場合も有る。
87 11         39 $macro->configure($slot->{cf_name} => copy_array($value));
88 11         53 ();
89             }
90             } else {
91 1         6 copy_array($value);
92             }
93             }
94              
95             #========================================
96              
97             #
98             # use YATT::ArgMacro AM => out => ['name=type'], in => [qw(x y z ...)];
99             # => creates new class AM.
100             #
101             sub import {
102 2     2   7 my ($pack, $macro_name) = splice @_, 0, 2;
103 2         7 my ($callpack) = caller;
104 2         6 my $class_name = "${callpack}::$macro_name";
105 2         19 my Spec $spec = Spec->new(name => $macro_name, classname => $class_name
106             , @_);
107              
108 2   50     13 my $base = $spec->{cf_base} || __PACKAGE__;
109 2         9 my @fields = $spec->fields;
110              
111 2         19 my $script = <
112             package $class_name;
113             use strict;
114             use base qw($base);
115             use YATT::Fields qw(@fields);
116              
117             sub $class_name () {'$class_name'}
118             END
119              
120             # print STDERR $script;
121 2         10 $pack->checked_eval($script);
122              
123 2         10 define_const(globref($class_name, 'macro_spec'), $spec);
124             }
125              
126             #
127             # Instanciate and register ArgMacro Spec in given widget's argument list.
128             #
129              
130             sub register_in {
131 16     16 0 36 my ($pack, $registry, $node, $widget, $rename_spec) = @_;
132 16         105 my Spec $spec = $pack->macro_spec
133             ->clone_with_renaming($rename_spec, $registry, $node);
134              
135 16         80 my ($dict, $order) = $widget->macro_specs;
136 16         36 push @$order, $spec;
137              
138 16 100       63 foreach my Slot $slot ($spec->{output} ? $spec->{output}
  7         18  
139             : @{$spec->{cf_out}}) {
140 23         108 $widget->add_arg($slot->{cf_name} => $registry->create_var
141             ($slot->{cf_type}, undef, varname => $slot->{cf_name}));
142             }
143              
144 16         27 foreach my $name (keys %{$spec->{trigger}}) {
  16         70  
145 54         71 my Slot $slot = $spec->{trigger}{$name};
146 54 50       107 if (my Slot $old = $dict->{$name}) {
147 0         0 die $registry->node_error
148             ($node, "ArgMacro %s conflicts with %s for %s"
149             , $spec->call_spec(1)
150             , $old->{cf_call_spec}, $name);
151             }
152 54         205 $dict->{$name} = $slot;
153             }
154             }
155              
156             #
157             # Directly instanciate ArgMacro spec.
158             #
159              
160             sub create_from {
161 0     0 0 0 my ($pack, $trans, $scope, $orig, $rename_spec) = @_;
162 0         0 my Spec $spec = $pack->macro_spec
163             ->clone_with_renaming($rename_spec, $trans, $orig);
164              
165 0         0 my $copy = $orig->variant_builder;
166 0         0 my ($name, $slot, @config);
167 0         0 for (my $n = $orig->clone; $n->readable; $n->next) {
168 0 0 0     0 unless ($n->is_attribute and $name = $n->node_name
      0        
      0        
169             and $slot = $spec->{trigger}{$name}
170             and not $slot->is_output) {
171 0         0 $copy->add_node(copy_array($n->current));
172 0         0 next;
173             }
174 0         0 push @config, $slot->{cf_name} => $n->current;
175             }
176 0 0       0 if (@config) {
177 0         0 my $macro = $pack->new($spec, @config);
178 0         0 $macro->accept($trans, $scope, $copy); # To avoid return value confusion.
179 0         0 ($macro, $copy)
180             } else {
181 0         0 (undef, $orig->rewind);
182             }
183             }
184              
185             #========================================
186              
187             foreach my $mode (qw(in out edit)) {
188             Spec->define("configure_$mode", sub {
189 52     52   173 spec_configure_slot(shift, "cf_$mode", $mode, @_);
190             });
191             }
192              
193             # 分かった、これが use YATT::ArgMacro と clone の両方の configure
194             # から呼ばれる。一方では生の list, 他方では Spec の list だ。
195             sub spec_configure_slot {
196 52     52 0 106 (my Spec $spec, my ($name, $mode, $list)) = @_;
197 54         215 $spec->{$name} = [map {
198 52         114 Slot->create($_, mode => $mode, classname => $spec->{cf_classname})
199             } @$list];
200 52 100 100     234 if ($mode eq 'out' && @{$spec->{$name}} == 1) {
  18         114  
201             # Only if 1 output var exists.
202 10         47 $spec->{output} = $spec->{$name}[0];
203             }
204             }
205              
206             Spec->define(fields => \&spec_fields);
207             sub spec_fields {
208 2     2 0 4 my Spec $spec = shift;
209 2 50       9 if ($spec->{cf_base}) {
210 0         0 croak "ArgMacro base= is not yet implemented";
211             }
212 2         3 my @fields;
213 2         7 foreach my $list ($spec->{cf_in}, $spec->{cf_edit}) {
214 4         11 foreach my Slot $slot (@$list) {
215 3         11 push @fields, 'cf_' . $slot->{cf_name};
216             }
217             }
218 2         4 foreach my Slot $slot (@{$spec->{cf_out}}) {
  2         7  
219 3         8 push @fields, 'out_' . $slot->{cf_name};
220             }
221 2         8 @fields;
222             }
223              
224             Spec->define(call_spec => \&spec_call_spec);
225             sub spec_call_spec {
226 35     35 0 61 (my Spec $spec, my ($user)) = @_;
227 47 100       100 my @args = grep {defined $_}
  35         110  
228 35         80 map { ref $_ ? @$_ : $_ } $spec->{cf_rename_spec};
229 35 100       152 '%'.join("", grep {defined $_}
  47 100       207  
230             ($user ? $spec->{cf_name} : $spec->{cf_classname})
231             , (@args ? ('('.join("=", @args).')') : ())).';';
232             }
233              
234             Spec->define(clone_with_renaming => \&spec_clone_with_renaming);
235             sub spec_clone_with_renaming {
236 16     16 0 42 (my Spec $orig, my ($rename, $registry, $node)) = @_;
237 16         67 my Spec $new = $orig->clone(rename_spec => $rename);
238 16         140 $new->{prototype} = $orig;
239 16         44 $new->{trigger} = \ my %trigger;
240              
241 16         43 my ($prefix, $short_name, $from) = ('');
242 16 100       44 if ($rename) {
243 6         29 die $registry->node_error($node, "ArgMacro: No output is defined")
244 6 50 33     28 unless $new->{cf_out} && @{$new->{cf_out}};
245 6         24 die $registry->node_error($node, "ArgMacro: Can't rename multiple output")
246 6 50       9 if @{$new->{cf_out}} > 1;
247              
248 6 50       35 ($short_name, $from) = ref $rename ? @$rename : $rename;
249 6         18 $prefix = $short_name . '_';
250              
251 6         14 my Slot $orig = $new->{cf_out}[0];
252 6         29 $new->{output} = $orig->clone(name => $short_name);
253 6         33 $new->{output_map}{$orig->{cf_name}} = $short_name;
254             }
255              
256 16         56 my $call_spec = $new->call_spec(1);
257 16         48 foreach my $list (grep {defined $_}
  48         65  
258             $new->{cf_in}, $new->{cf_edit}, $new->{cf_out}) {
259 48         61 foreach my Slot $slot (@$list) {
260 48         122 $trigger{$prefix . $slot->{cf_name}}
261             = $slot->clone(spec => $new, call_spec => $call_spec);
262             }
263             }
264              
265 16 100       56 if ($from) {
266 6 50       28 unless (my Slot $major = $trigger{$prefix . $from}) {
267 0         0 die $registry->node_error($node, "Unknown parameter: %s", $from);
268             } else {
269 6         19 $trigger{$short_name} = $major;
270             }
271             }
272 16         48 $new;
273             }
274              
275             Spec->define(revert_into => \&spec_revert_into);
276             sub spec_revert_into {
277 5     5 0 8 (my Spec $spec, my $node, my MY $macro) = @_;
278 5 50       12 foreach my Slot $slot (map {ref $_ ? @$_ : ()} $spec->{cf_edit}) {
  5         23  
279 0         0 my $name = "cf_$slot->{cf_name}";
280 0 0       0 defined(my $expr = $macro->{$name})
281             or next;
282 0         0 $node->add_node($expr);
283             }
284             }
285              
286             sub output_name {
287 9     9 0 18 (my MY $macro) = @_;
288 9         20 my Spec $spec = $macro->{spec};
289 9         22 my Slot $out = $spec->{output};
290 9         50 $out->{cf_name};
291             }
292              
293             #========================================
294             Slot->define(create => \&slot_create);
295             sub slot_create {
296 54     54 0 115 my ($pack, $item, @rest) = @_;
297 54         55 my ($name, @args) = do {
298 54 100       262 unless (ref $item) {
    50          
299 6         14 my ($n, $t) = split /=/, $item, 2;
300 6         15 ($n, type => $t);
301             } elsif (UNIVERSAL::isa($item, Slot)) {
302 48         141 return $item->clone;
303             } else {
304 0         0 @$item
305             }
306             };
307 6         23 $pack->new(name => $name, @args, @rest);
308             }
309              
310             Slot->define(is_output => \&slot_is_output);
311             sub slot_is_output {
312 16     16 0 29 my Slot $slot = shift;
313 16         78 $slot->{cf_mode} eq 'out';
314             }
315              
316             1;