File Coverage

web/cgi-bin/yatt.lib/YATT/Registry.pm
Criterion Covered Total %
statement 570 631 90.3
branch 165 242 68.1
condition 52 84 61.9
subroutine 117 125 93.6
pod 0 62 0.0
total 904 1144 79.0


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2              
3             package YATT::Registry;
4 5     5   3817 use strict;
  5         11  
  5         157  
5 5     5   33 use warnings qw(FATAL all NONFATAL misc);
  5         10  
  5         201  
6 5     5   27 use Carp;
  5         9  
  5         232  
7 5     5   14396 use UNIVERSAL;
  5         40  
  5         56  
8              
9             # Debugging aid.
10             require YATT;
11 5     5   2027 use YATT::Exception;
  5         12  
  5         330  
12              
13             {
14 5     5   28 package YATT::Registry::NS; use YATT::Inc;
  5         11  
  5         42  
15 4     4   20 BEGIN {require Exporter; *import = \&Exporter::import}
  4         86  
16 4     4   20 use base qw(YATT::Class::Configurable);
  4         8  
  4         394  
17 4         23 use YATT::Fields qw(Widget
18             cf_nsid cf_parent_nsid cf_base_nsid
19             cf_pkg cf_special_entities
20             cf_name cf_vpath cf_loadkey
21             cf_mtime cf_age
22             ^is_loaded
23 4     4   21 );
  4         7  
24             # When fields is empty, %FIELDS doesn't blessed.
25             # This causes "Pseudo-hashes are deprecated"
26              
27             use YATT::Types
28             ([Dir => [qw(cf_base_template)]
29             , 'Dir'
30             , [Template => [qw(tree cf_base_template ^widget_list
31             ^cf_metainfo)]]
32             ]
33             , -base => [NS => __PACKAGE__]
34             , -alias => [Root => 'YATT::Registry'
35             , Registry => 'YATT::Registry']
36             , -default => [loader => 'YATT::Registry::Loader']
37             , -debug => $ENV{YATT_DEBUG_TYPES}
38 4         73 , qw(:type_name :export_alias)
39 4     4   541 );
  4         8  
40             }
41              
42 4     4   20 use YATT::Util qw(checked_eval checked lsearch);
  4         8  
  4         231  
43 4     4   22 use YATT::Util::Taint;
  4         9  
  4         383  
44 4     4   20 use YATT::Registry::NS;
  4         5  
  4         238  
45 4     4   20 use YATT::Util::Symbol;
  4         6  
  4         348  
46              
47 4     4   20 use base Dir;
  4         8  
  4         592  
48 4         30 use YATT::Fields qw(^Loader NS last_nsid
49             cf_auto_reload
50             cf_type_map
51             cf_debug_registry
52             cf_rc_global
53             cf_template_global
54             cf_no_lineinfo
55             current_parser
56             cf_default_base_class
57             cf_use
58             loading
59             nspattern
60             )
61             , ['^cf_namespace' => qw(yatt perl)]
62             , ['^cf_app_prefix' => "::"]
63 4     4   19 ;
  4         7  
64              
65             sub new {
66 20     20 0 138 my $nsid = 0;
67 20         149 my Root $root = shift->SUPER::new(@_, vpath => '/', nsid => $nsid);
68              
69 20 50       83 if (defined $ENV{YATT_CF_LINEINFO}) {
70 0         0 $root->{cf_no_lineinfo} = not $ENV{YATT_CF_LINEINFO};
71             }
72              
73             # $root->{NS}{$nsid} = $root; # ← サイクルするってば。
74             # 一回、空呼び出し。
75 20         90 $root->get_package($root);
76              
77             # root は new 時に強制 refresh.
78             # after_configure だと、configure の度なので、new のみに。
79 20         88 $root->refresh($root);
80              
81             # Now safe to lift @ISA.
82 20         49 $root->{is_loaded} = 1;
83              
84 20         118 $root;
85             }
86              
87             sub configure_loader {
88 20     20 0 47 (my Root $root, my ($desc)) = @_;
89 20         72 my ($type, $loadkey, @args) = @$desc;
90 20         891 $root->{Loader} = $root->default_loader->$type->new($loadkey, @args);
91 20         117 $root->{cf_loadkey} = $loadkey;
92             }
93              
94             sub configure_DIR {
95 0     0 0 0 (my Root $root, my ($dir)) = @_;
96 0         0 $root->{Loader} = $root->default_loader->DIR->new($dir);
97 0         0 $root->{cf_loadkey} = $dir;
98             }
99              
100             sub after_configure {
101 20     20 0 41 (my Root $root) = @_;
102 20         44 my $nspat = join("|" , @{$root->namespace});
  20         86  
103 20         347 $root->{nspattern} = qr{^(?:$nspat)$};
104             }
105              
106             #========================================
107             # use YATT::Registry ** => ** 系.
108              
109             {
110             our Root $ROOT;
111             our NS $CURRENT;
112              
113             sub eval_in_dir {
114             # XXX: should take care for variable capture.
115 17     17 0 53 (my Root $root, my NS $target, my ($script, @args)) = @_;
116 17 50       79 if (is_tainted($script)) {
117 0         0 confess "script is tainted: $script\n";
118             }
119              
120 17         54 my $targetClass = $root->get_package($target);
121              
122 17         94 my $prog = "package $targetClass;"
123             . " use strict;"
124             . " use warnings FATAL => qw(all);"
125             . " $script";
126 17         53 local @_ = (@args);
127 17         40 local ($ROOT, $CURRENT) = ($root, $target);
128 17         57 &YATT::break_eval;
129 17         24 my @result;
130 17 50       56 if (wantarray) {
131 0         0 @result = eval $prog;
132             } else {
133 17     2   1407 $result[0] = eval $prog;
  2     2   15  
  2     2   4  
  2     2   72  
  2     2   11  
  2     2   4  
  2     2   744  
  2     2   992  
  2     2   5  
  2     2   54  
  2     2   14  
  2     2   3  
  2     2   425  
  2     2   16  
  2     2   5  
  2     2   65  
  2     2   10  
  2     2   4  
  2     2   629  
  2     2   11  
  2         4  
  2         48  
  2         12  
  2         4  
  2         1046  
  2         19  
  2         5  
  2         75  
  2         14  
  2         4  
  2         769  
  2         17  
  2         5  
  2         60  
  2         17  
  2         6  
  2         1135  
  2         12  
  2         5  
  2         75  
  2         12  
  2         4  
  2         58  
  2         13  
  2         5  
  2         59  
  2         10  
  2         4  
  2         75  
  2         10  
  2         3  
  2         51  
  2         12  
  2         5  
  2         56  
  2         9  
  2         5  
  2         70  
  2         10  
  2         4  
  2         42  
134             }
135             # XXX: $prog をどう見せたいかが、状況で色々変化する。
136 17 50       70 die $@ if $@;
137 17 50       101 wantarray ? @result : $result[0];
138             }
139              
140             sub import {
141 16     16   43 my $modpack = shift;
142 16         56 my $callpack = caller;
143 16         65 $modpack->install_builtins($callpack);
144              
145 16 100       63 return unless @_;
146              
147 16 50       65 croak "Odd number of arguments for 'use $modpack @_'" if @_ % 2;
148              
149 17         82 my $fields = $CURRENT->fields_hash;
150 17         98 while (my ($name, $value) = splice @_, 0, 2) {
151 14 100       125 if (my $sub = $modpack->can("import_$name")) {
    50          
    50          
152 13         68 $sub->($modpack, $callpack, $value);
153             } elsif ($sub = $CURRENT->can("configure_$name")) {
154 4         13 $sub->($CURRENT, $value);
155             } elsif ($fields->{"cf_$name"}) {
156 5         292 $CURRENT->{"cf_$name"} = $value;
157             } else {
158 4         31 croak "Unknown YATT::Registry parameter: $name";
159             }
160             }
161             }
162              
163             # Root 以外の Dir では、こちらが呼ばれる(はず)
164             sub import_base {
165 16 50   15 0 62 croak "Can't find current registry" unless defined $ROOT;
166 15         37 my ($modpack, $targetClass, $vpath) = @_;
167 15 50       88 my Dir $dir = $CURRENT->lookup_dir($ROOT, split '/', $vpath)
168             or croak "Can't find directory: $vpath";
169 15         61 $CURRENT->{cf_base_nsid} = $dir->{cf_nsid};
170 15         56 lift_isa_to($ROOT->get_package($dir), $targetClass);
171             }
172             }
173              
174             # これが呼ばれるのは Root の時だけ。
175             sub configure_base {
176 3     1 0 132 (my MY $root, my $realdir) = @_;
177 3 0       10 unless (-d $realdir) {
178 8         35 croak "No such directory for base='$realdir'";
179             }
180              
181 1         3 my $base_nsid = $root->createNS
182             (Dir => loadkey => untaint_any($realdir));
183              
184 1         6 $root->{cf_base_nsid} = $base_nsid;
185 1         3 lift_isa_to($root->get_package(my $base = $root->nsobj($base_nsid))
186             , $root->get_package($root));
187              
188 1         2 $root->refresh($base);
189              
190 1         8 $root;
191             }
192              
193             #----------------------------------------
194              
195             {
196             our $IS_RELOADING;
197 7     4 0 39 sub is_reloading { $IS_RELOADING }
198             sub with_reloading_flag {
199 18     17 0 54 (my Root $root, my ($flag, $sub)) = @_;
200 17         43 local $IS_RELOADING = $flag;
201 17         41 $sub->();
202             }
203             }
204              
205             #----------------------------------------
206              
207             sub Entity (*$) {
208 3     3 0 8 my ($name, $sub) = @_;
209 3         9 my ($instClass) = caller;
210 3         13 my $glob = globref($instClass, "entity_$name");
211 3 50 33     15 if (MY->is_reloading and defined *{$glob}{CODE}) {
  0         0  
212             # To avoid 'Subroutine MyApp5::entity_bar redefined'.
213 0         0 undef *$glob;
214             }
215 3         51 *$glob = $sub;
216             }
217              
218             sub ElementMacro (*$) {
219 0     0 0 0 my ($name, $sub) = @_;
220 0         0 my ($instClass) = caller;
221 0         0 *{globref($instClass, "macro_$name")} = $sub;
  0         0  
222             }
223              
224 13     13 0 47 sub list_builtins { qw(Entity ElementMacro) }
225              
226             sub install_builtins {
227 13     13 0 33 my ($modpack, $destpack) = @_;
228 13         46 foreach my $name ($modpack->list_builtins) {
229 26 50       179 my $sub = $modpack->can($name)
230             or die "Can't find builtin: $name";
231 26         41 *{globref($destpack, $name)} = $sub;
  26         88  
232             }
233             }
234              
235             #========================================
236              
237             sub next_nsid {
238 255     255 0 354 my Root $root = shift;
239 255         559 ++$root->{last_nsid};
240             }
241              
242             sub createNS {
243 255     255 0 630 (my Root $root, my ($type)) = splice @_, 0, 2;
244             # class_id は?
245 255         594 my $nsid = $root->next_nsid;
246 255         1782 my NS $nsobj = $root->{NS}{$nsid} = $root->$type->new(nsid => $nsid, @_);
247 255         687 my $pkg = $root->get_package($nsobj);
248 255 100       632 foreach my $name (map {defined $_ ? @$_ : ()} $root->{cf_rc_global}) {
  255         864  
249 14         18 *{globref($pkg, $name)} = *{globref($root->{cf_app_prefix}, $name)};
  14         35  
  14         38  
250             }
251 255         2410 $nsid;
252             }
253              
254             sub nsobj {
255 2277     2277 0 3728 (my Root $root, my ($nsid)) = @_;
256 2277 50       5116 unless (defined $nsid) {
257 0         0 croak "nsobj: undefined nsid!";
258             }
259 2277 100       5490 return $root if $nsid == 0;
260 1804         6487 $root->{NS}{$nsid};
261             }
262              
263             sub get_package {
264 1523     1523 0 2602 (my Root $root, my NS $nsobj, my ($sep)) = @_;
265             # nsid のまま渡しても良いように。
266 1523 100       4132 $nsobj = $root->nsobj($nsobj) unless ref $nsobj;
267              
268 1523   66     7571 $nsobj->{cf_pkg} ||= do {
269 275         302 my $pkg = do {
270 275 100       600 if ($root == $nsobj) {
271 20 100       87 $root->{cf_app_prefix} || '::'
272             } else {
273             join $sep || "::"
274             , $root->{cf_app_prefix} || '::'
275             , sprintf '%.1s%d', $nsobj->type_name
276 255   50     2344 , $nsobj->{cf_nsid};
      100        
277             }
278             };
279 275         1143 $root->checked_eval(qq{package $pkg});
280 275         1245 $pkg;
281             };
282             }
283              
284             sub refresh {
285 551     551 0 898 (my Root $root, my NS $node) = @_;
286 551   33     1424 $node ||= $root;
287 551 50       1602 return unless $node->{cf_loadkey};
288 551 100 100     2901 return if $node->{cf_age} and not $root->{cf_auto_reload};
289 229 50       642 return unless $root->{Loader};
290              
291             # age があるのに、 is_loaded に達してない == まだ構築の途中。
292 229 100 100     820 return if $node->{cf_age} and not $node->{is_loaded};
293 222         924 $root->{loading}{$node->{cf_nsid}} = 1;
294              
295             print STDERR "Referesh: $node->{cf_loadkey}\n"
296 222 50       630 if $root->{cf_debug_registry};
297              
298 222         896 $root->{Loader}->handle_refresh($root, $node);
299 216         685 $node->{is_loaded} = 1;
300 216         965 delete $root->{loading}{$node->{cf_nsid}};
301             }
302              
303             sub mark_load_failure {
304 1     1 0 4 my Root $root = shift;
305 1         4 while ((my $nsid, undef) = each %{$root->{loading}}) {
  2         18  
306 1         5 my NS $ns = $root->nsobj($nsid);
307             # 仮に、一度は load 済みだとする。
308 1         3 $ns->{is_loaded} = 1;
309 1         5 delete $root->{loading}{$nsid};
310             }
311             }
312              
313             sub get_ns {
314 6     6 0 25 (my Root $root, my ($elempath)) = @_;
315 6         32 $root->vivify_ns($root, @$elempath);
316             }
317              
318             sub get_package_from_node {
319 21     21 0 45 (my Root $root, my ($node)) = @_;
320 21         86 my Dir $dir = $root->get_dir_from_node($node);
321 21         76 $root->get_package($dir);
322             }
323              
324             sub get_dir_from_node {
325 21     21 0 45 (my Root $root, my ($node)) = @_;
326 21         73 my Template $tmpl = $root->get_template_from_node($node);
327 21         79 $root->nsobj($tmpl->{cf_parent_nsid});
328             }
329              
330             sub get_template_from_node {
331 284     284 0 507 (my Root $root, my ($node)) = @_;
332 284         936 $root->nsobj($node->metainfo->cget('nsid'));
333             }
334              
335             sub get_widget {
336 161     161 0 291 my Root $root = shift;
337 161         684 $root->get_widget_from_dir($root, @_);
338             }
339              
340             sub get_widget_from_template {
341 101     101 0 297 (my Root $root, my Template $tmpl, my ($nsname)) = splice @_, 0, 3;
342 101         153 my $widget;
343              
344             # Relative lookup. ($nsname case is for [delegate])
345 101 100       527 $widget = $tmpl->lookup_widget($root, @_ ? @_ : $nsname)
    100          
346             and return $widget;
347              
348             # Absolute, ns-specific lookup.
349 2 50       15 if ($root->has_ns($root, $nsname)) {
350 0 0       0 $widget = $root->get_widget_from_dir($root, $nsname, @_)
351             and return $widget;
352             }
353              
354             # Absolute, general lookup.
355 2         8 return $root->get_widget_from_dir($root, @_);
356             }
357              
358             sub get_widget_from_dir {
359 164     164 0 354 (my Root $root, my Dir $dir) = splice @_, 0, 2;
360 164         376 my @elempath = @_;
361 164         654 $dir = $dir->vivify_ns($root, splice @elempath, 0, @elempath - 2);
362 164 50       449 unless ($dir) {
363 0         0 croak "Can't find widget: ", join(":", @_);
364             }
365 164 100       600 if (@elempath == 2) {
    50          
366 19         88 $dir->widget_by_nsname($root, @elempath);
367             } elsif (@elempath == 1) {
368 145         443 $dir->widget_by_name($root, @elempath);
369             } else {
370 0         0 return;
371             }
372             }
373              
374             {
375             sub YATT::Registry::NS::list_declared_widget_names {
376 0     0 0 0 (my NS $tmpl) = @_;
377 0         0 my @result;
378 0         0 foreach my $name (keys %{$tmpl->{Widget}}) {
  0         0  
379 0         0 my $w = $tmpl->{Widget}{$name};
380 0 0       0 next unless $w->declared;
381 0         0 push @result, $name;
382             }
383 0         0 @result;
384             }
385              
386             # For relative lookup.
387             sub YATT::Registry::NS::Template::lookup_widget {
388 101     101 0 235 (my Template $tmpl, my Root $root) = splice @_, 0, 2;
389 101 50 33     1078 croak "lookup_widget: argument type mismatch for \$root."
      33        
390             unless defined $root and ref $root and $root->isa(Root);
391 101 50       271 return unless @_;
392              
393 101         355 foreach my NS $start ($tmpl, $root->nsobj($tmpl->{cf_parent_nsid})) {
394 103         266 my @elempath = @_;
395              
396 103         134 my NS $ns = do {
397 103 50       243 if (@elempath <= 2) {
398 103         212 $start;
399             } else {
400 0         0 $start->lookup_dir($root, splice @elempath, 0, @elempath - 2);
401             }
402             };
403              
404 103         170 my $found = do {
405 103 100       221 if (@elempath == 2) {
406 1         5 $ns->widget_by_nsname($root, @elempath);
407             } else {
408 102         414 $ns->widget_by_name($root, @elempath);
409             }
410             };
411 102 100       836 return $found if $found;
412             }
413             }
414              
415             sub YATT::Registry::NS::Template::lookup_template {
416 4     4 0 10 (my Template $tmpl, my Root $root, my ($name)) = @_;
417 4         17 $root->nsobj($tmpl->{cf_parent_nsid})->lookup_template($root, $name)
418             }
419              
420             sub YATT::Registry::NS::Template::lookup_dir {
421 0     0 0 0 (my Template $tmpl, my Root $root) = splice @_, 0, 2;
422 0         0 $root->nsobj($tmpl->{cf_parent_nsid})->lookup_dir($root, @_);
423             }
424              
425             sub YATT::Registry::NS::Dir::has_ns {
426 2     2 0 5 (my Dir $dir, my Root $root, my ($nsname)) = @_;
427 2         4 my $nsid;
428              
429 2 50 33     18 $nsid = $dir->{Dir}{$nsname} || $dir->{Template}{$nsname}
430             and return $root->nsobj($nsid);
431              
432 2 50       10 return unless $dir->{cf_base_nsid};
433              
434 0         0 $root->nsobj($dir->{cf_base_nsid})->has_ns($root, $nsname);
435             }
436              
437             sub YATT::Registry::NS::Dir::lookup_template {
438 4     4 0 9 (my Dir $dir, my Root $root, my ($name)) = @_;
439 4         7 my $nsid;
440 4   66     26 while (not($nsid = $dir->{Template}{$name})
441             and $dir->{cf_base_nsid}) {
442 2         7 $dir = $root->nsobj($dir->{cf_base_nsid});
443 2         13 $root->refresh($dir);
444             }
445 4 50       14 return unless $nsid;
446 4         12 $root->nsobj($nsid);
447             }
448              
449 4     4   25 use Carp;
  4         8  
  4         5918  
450             sub YATT::Registry::NS::Dir::lookup_dir {
451 12     12 0 37 (my Dir $dir, my Root $root, my (@nspath)) = @_;
452 12 50       65 croak "argtype mismatch! not a Root." unless UNIVERSAL::isa($root, Root);
453 12 50       43 return $root unless @nspath;
454 12         36 (my Dir $start, my (@orig)) = ($dir, @nspath);
455 12         48 $root->refresh($dir);
456 12   66     92 while ($dir and defined (my $ns = shift @nspath)) {
457 19 100 50     106 $dir = $root and next if $ns eq '';
458 12         38 my $nsid = $dir->{Dir}{$ns};
459 12 50       40 unless ($nsid) {
460             return $start->{cf_base_nsid}
461 0 0       0 ? $root->nsobj($start->{cf_base_nsid})->lookup_dir($root, @orig)
462             : undef;
463             }
464 12         43 $dir = $root->nsobj($nsid);
465 12         35 $root->refresh($dir);
466             }
467 12         61 $dir;
468             }
469              
470             sub YATT::Registry::NS::Dir::list_ns {
471 4     4 0 23 (my Dir $dir, my ($dict)) = @_;
472 4   50     25 $dict ||= {};
473 4         8 my @list;
474 4         10 foreach my $type (qw(Template Dir)) {
475 8         12 foreach my $key (keys %{$dir->{$type}}) {
  8         35  
476 9 100       44 push @list, $key unless $dict->{$key}++;
477             }
478             }
479 4 50       64 wantarray ? @list : \@list;
480             }
481              
482             sub YATT::Registry::NS::Dir::vivify_ns {
483 170     170 0 323 (my Dir $dir, my Root $root, my (@nspath)) = @_;
484 170         338 my @orig = @nspath;
485 170         560 while (@nspath) {
486 7         28 $root->refresh($dir);
487 7         11 $dir = do {
488 7         16 my $ns = shift @nspath;
489 7         14 my Dir $d = $dir;
490 7         12 my $nsid;
491 7   100     67 while (not($nsid = $d->{Dir}{$ns})
      66        
492             and not($nsid = $d->{Template}{$ns})
493             and $d->{cf_base_nsid}) {
494 2         10 $d = $root->nsobj($d->{cf_base_nsid});
495 2         8 $root->refresh($d);
496             }
497 7 50       21 unless ($nsid) {
498 0         0 croak "No such ns '$ns': " . join ":", @orig;
499             }
500 7         24 $root->nsobj($nsid);
501             };
502             }
503 170         428 $dir;
504             }
505              
506             sub YATT::Registry::NS::Dir::after_rc_loaded {
507 17     17 0 36 (my Dir $dir, my Root $root) = @_;
508 17 100       83 if (defined(my $base = $dir->{cf_base_nsid})) {
509 12         21 foreach my Template $tmpl (map {$root->nsobj($_)}
  13         39  
510 12         50 values %{$dir->{Template}}) {
511 13         52 $tmpl->{cf_base_nsid} = $base;
512             }
513             }
514             }
515              
516             sub YATT::Registry::NS::Dir::widget_by_nsname {
517 22     22 0 88 (my Dir $dir, my Root $root, my ($ns, $name)) = @_;
518 22         80 $root->refresh($dir);
519 22 50 66     112 if (defined $dir->{cf_name} and $dir->{cf_name} eq $ns) {
520 0         0 my $widget = $dir->widget_by_name($root, $name);
521 0 0       0 return $widget if $widget;
522             }
523             # [1] dir:template
524             # [2] template:widget
525 22         57 foreach my $type (qw(Dir Template)) {
526 23 100       170 next unless my $nsid = $dir->{$type}{$ns};
527 21 50       81 next unless my $widget = $root->nsobj($nsid)
528             ->widget_by_name($root, $name);
529 21         198 return $widget;
530             }
531 1 50       5 return unless $dir->{cf_base_nsid};
532 1         4 $root->nsobj($dir->{cf_base_nsid})->widget_by_nsname($root, $ns, $name);
533             }
534              
535             sub YATT::Registry::NS::Dir::widget_by_name {
536 192     192 0 405 (my Dir $dir, my Root $root, my ($name)) = @_;
537 192         616 $root->refresh($dir);
538 192 100       856 if (my $nsid = $dir->{Template}{$name}) {
539 175         446 $root->refresh($root->nsobj($nsid));
540             }
541             $dir->{Widget}{$name}
542             || $dir->{cf_base_nsid}
543 186 100 100     1723 && $root->nsobj($dir->{cf_base_nsid})->widget_by_name($root, $name);
544             }
545              
546             sub YATT::Registry::NS::Template::widget_by_nsname {
547 1     1 0 2 (my Template $tmpl, my Root $root, my ($ns, $name)) = @_;
548 1 50       5 if ($tmpl->{cf_name} eq $ns) {
549 0         0 my $widget = $tmpl->widget_by_name($root, $name);
550 0 0       0 return $widget if $widget;
551             }
552 1         4 my Dir $parent = $root->nsobj($tmpl->{cf_parent_nsid});
553 1 50 33     6 if (defined $parent->{cf_name} and $parent->{cf_name} eq $ns) {
554 0         0 my $widget = $tmpl->widget_by_name($root, $name);
555 0 0       0 return $widget if $widget;
556             }
557 1         4 $parent->widget_by_nsname($root, $ns, $name);
558             }
559              
560             sub YATT::Registry::NS::Template::widget_by_name {
561 103     103 0 195 (my Template $tmpl, my Root $root, my ($name)) = @_;
562 103         275 $root->refresh($tmpl);
563 103         120 my $widget;
564 103 100       481 $widget = $tmpl->{Widget}{$name}
565             and return $widget;
566              
567             # 同一ディレクトリのテンプレートを先に検索するため。
568             # XXX: しかし、継承順序に問題が出ているはず。
569             $widget = $root->nsobj($tmpl->{cf_parent_nsid})
570 16 100       52 ->widget_by_name($root, $name)
571             and return $widget;
572              
573 5 100       24 if ($tmpl->{cf_base_template}) {
574             $widget = $root->nsobj($tmpl->{cf_base_template})
575 3 50       14 ->widget_by_name($root, $name)
576             and return $widget;
577             }
578              
579 2 50       8 if ($tmpl->{cf_base_nsid}) {
580             $widget = $root->nsobj($tmpl->{cf_base_nsid})
581 0 0       0 ->widget_by_name($root, $name)
582             and return $widget;
583             }
584              
585 2         5 return;
586             }
587             }
588              
589             sub node_error {
590 18     18 0 61 (my Root $root, my ($node, $fmt)) = splice @_, 0, 3;
591 18 50       166 $root->node_error_obj($node
592             , error_fmt => ref $fmt ? join(" ", $fmt) : $fmt
593             , error_param => [@_]
594             , caller => [caller]);
595             }
596              
597             sub node_error_obj {
598 18     18 0 75 (my Root $root, my ($node, @param)) = @_;
599             # XXX: $root->{cf_backtrace} なら longmess も append, とか。
600             # XXX: Error オブジェクトにするべきかもね。でも依存は嫌。
601             # ← die を $root->raise で wrap すれば良い?
602 18         97 my $stringify = $root->checked(stringify => "(Can't stringify: %s)", $node);
603 18         62 my $filename = $root->checked(filename => "(Can't get filename %s)", $node);
604 18         57 my $linenum = $root->checked(linenum => "(Can't get linenum %s)", $node);
605 18         185 $root->Exception->new(@param
606             , node_obj => $node
607             , node => $stringify, file => $filename
608             , line => $linenum);
609             }
610              
611             sub node_nimpl {
612 0     0 0 0 (my Root $root, my ($node, $msg)) = @_;
613 0         0 my $caller = [my ($pack, $file, $line) = caller];
614 0   0     0 $root->node_error_obj($node
615             , error_fmt => join(' '
616             , ($msg || "Not yet implemented")
617             , "(perl file $file line $line)")
618             , caller => $caller);
619             }
620              
621             sub strip_ns {
622 811     811 0 1457 (my Root $root, my ($list)) = @_;
623 811         2188 $root->shift_ns_by($root->{nspattern}, $list);
624             }
625              
626             sub shift_ns_by {
627 862     862 0 1724 (my Root $root, my ($pattern, $list)) = @_;
628 862 100       2121 return unless @$list;
629 854 50       1783 return unless defined $pattern;
630 854 100       1956 if (ref $pattern) {
631 809 100       4842 return unless $list->[0] =~ $pattern
632             } else {
633 45 100       184 return unless $list->[0] eq $pattern;
634             }
635 818         2338 shift @$list;
636             }
637              
638             #========================================
639              
640 4     4   23 use YATT::LRXML::Node qw(DECLARATOR_TYPE node_path create_node);
  4         8  
  4         338  
641             sub DEFAULT_WIDGET () {''}
642              
643 4     4   2741 use YATT::LRXML::MetaInfo;
  4         12  
  4         187  
644 4     4   2344 use YATT::Widget;
  4         10  
  4         203  
645              
646 4     4   2347 use YATT::LRXML; # for Builder.
  4         12  
  4         44  
647             use YATT::Types
648 4         42 ([WidgetBuilder => [qw(cf_widget ^cf_template cf_root_builder)]]
649             , -base => qw(YATT::LRXML::Builder)
650             , -alias => [Builder => __PACKAGE__ . '::WidgetBuilder'
651             , Scanner => 'YATT::LRXML::Scanner']
652 4     4   209 );
  4         8  
653              
654             # XXX: 名前が紛らわしい。lrxml tree の root か、Registry の root か、と。
655             sub new_root_builder {
656 156     156 0 316 (my Root $root, my $parser, my Scanner $scan) = @_;
657 156         485 my MetaInfo $meta = $parser->metainfo;
658 156         617 my Template $tmpl = $root->nsobj($meta->{cf_nsid});
659              
660             my $widget = $root->create_widget_in
661             ($tmpl, DEFAULT_WIDGET
662             , filename => $meta->cget('filename')
663             , decl_start => $scan->{cf_linenum}
664 156         611 , body_start => $scan->{cf_linenum} + $scan->number_of_lines);
665              
666             # 親ディレクトリに登録。
667 156         588 my Dir $parent = $root->nsobj($tmpl->{cf_parent_nsid});
668              
669 156         571 $parent->{Widget}{$tmpl->{cf_name}} = $widget;
670              
671 156         650 $parser->configure(tree => my $sink = $widget->cget('root'));
672              
673             $root->Builder->new($sink, undef
674             , widget => $widget
675             , template => $tmpl
676             , startpos => 0
677             , startline => $scan->{cf_linenum}
678 156         2297 , linenum => $scan->{cf_linenum});
679             }
680              
681             sub fake_cursor_from {
682 19     19 0 51 (my MY $trans, my ($cursor, $node, $is_opened)) = @_;
683 19         113 my $parent = $cursor->Path->new($node, $cursor->cget('path'));
684 19 100       109 my $path = $is_opened ? $parent
685             : $cursor->Path->new($trans->create_node(unknown => undef, $node)
686             , $parent);
687 19         79 $cursor->clone($path);
688             }
689              
690             sub fake_cursor {
691 194     194 0 514 (my MY $gen, my Widget $widget, my ($metainfo)) = splice @_, 0, 3;
692 194         720 my $cursor = $widget->cursor(metainfo => $metainfo);
693 194         803 my $node = $gen->create_node(unknown => undef, @_);
694 194         931 $cursor->clone($cursor->Path->new($node, $cursor->cget('path')));
695             }
696              
697             sub fake_cursor_to_build {
698 184     184 0 354 (my MY $root, my Builder $builder, my Scanner $scan
699             , my ($elem)) = @_;
700             $root->fake_cursor($builder->{cf_widget}
701             , $builder->{cf_template}->metainfo
702             ->clone(startline => $scan->{cf_linenum})
703 184         875 , $elem);
704             }
705              
706             sub new_decl_builder {
707 183     183 0 511 (my MY $root, my Builder $builder, my Scanner $scan
708             , my ($elem, $parser)) = @_;
709 183         455 foreach my $shift (0, 1) {
710 366         1159 my $path = [node_path($elem)];
711 366 100       1307 $root->strip_ns($path) if $shift;
712 366         995 my $handler_name = join("_", declare => @$path);
713              
714 366 100       2102 if (my $handler = $root->can($handler_name)) {
715 181         585 my $nc = $root->fake_cursor_to_build($builder, $scan, $elem)->open;
716 181         1343 return $handler->($root, $builder, $scan, $nc, $parser);
717             }
718             }
719              
720 2         13 die $root->node_error($root->fake_cursor_to_build($builder, $scan, $elem)
721             , "Unknown declarator");
722             }
723              
724             sub declare_base {
725 4     4 0 12 (my Root $root, my Builder $builder, my ($scan, $args, $parser)) = @_;
726 4 50       17 if ($builder->{parent}) {
727 0         0 die $scan->token_error("Misplaced yatt:base");
728             }
729 4         21 my $path = $args->node_body;
730 4         10 my Template $this = $builder->{cf_template};
731 4 50       21 my Template $base = $this->lookup_template($root, $path)
732             or die $scan->token_error("Can't find template $path");
733              
734             # XXX: refresh は lookup_template の中ですべきか?
735 4         16 $root->refresh($base);
736              
737             # 名前は保存しなくていいの?
738 4         16 $this->{cf_base_template} = $base->{cf_nsid};
739              
740 4         19 $root->add_isa($root->get_package($this)
741             , $root->get_package($base));
742              
743             # builder を返すことを忘れずに。
744 4         83 $builder;
745             }
746              
747             sub declare_args {
748 87     87 0 275 (my Root $root, my Builder $builder
749             , my ($scan, $nc, $parser, @configs)) = @_;
750 87 50       349 if ($builder->{parent}) {
751 0         0 die $scan->token_error("Misplaced yatt:args");
752             }
753             # widget -> args の順番で出現する場合もある。
754             # root 用の builder を取り出し直す
755 87 100       240 if ($builder->{cf_root_builder}) {
756 2         7 $builder = $builder->{cf_root_builder};
757             }
758 87         188 my Widget $widget = $builder->{cf_widget};
759 87         233 $widget->{cf_declared} = 1;
760 87         206 $widget->{cf_decl_start} = $scan->{cf_last_linenum};
761 87         181 $widget->{cf_body_start} = $scan->{cf_last_linenum} + $scan->{cf_last_nol};
762 87 50       204 $widget->configure(@configs) if @configs;
763 87         364 $root->define_args($widget, $nc);
764 87         432 $root->after_define_args($widget);
765 87         1464 $builder;
766             }
767              
768             sub declare_params {
769 0     0 0 0 shift->declare_args(@_, public => 1);
770             }
771              
772             sub declare_widget {
773 90     90 0 303 (my Root $root, my Builder $builder, my Scanner $scan
774             , my ($args, $parser)) = @_;
775              
776 90 100       428 if ($builder->{parent}) {
777 1         16 die $root->node_error($root->fake_cursor_to_build($builder, $scan
778             , $builder->product)
779             , "Misplaced yatt:widget in:");
780             }
781              
782 89 50       320 defined (my $name = $args->node_name)
783             or die $root->node_error($args, "widget name is missing");
784              
785             # XXX: filename, lineno
786             my Widget $widget = $root->create_widget_in
787             ($builder->{cf_template}, $name
788             , declared => 1
789             , filename => $builder->{cf_template}->metainfo->cget('filename')
790             , decl_start => $scan->{cf_last_linenum}
791 89         410 , body_start => $scan->{cf_last_linenum} + $scan->{cf_last_nol});
792              
793 89         470 $root->define_args($widget, $args->go_next);
794 88         426 $root->after_define_args($widget);
795              
796             $root->Builder->new($widget->cget('root'), undef
797             , widget => $widget
798             , template => $builder->{cf_template}
799             , startpos => $scan->{cf_index}
800             , startline => $scan->{cf_linenum}
801             , linenum => $scan->{cf_linenum}
802             # widget -> args に戻るためには root_builder を
803             # 渡さねばならぬ
804             , root_builder =>
805 88   66     472 $builder->{cf_root_builder} || $builder
806             );
807             }
808              
809             sub create_widget_in {
810 245     245 0 726 (my Root $root, my Template $tmpl, my ($name)) = splice @_, 0, 3;
811             my $widget = YATT::Widget->new
812             (name => $name, template_nsid => $tmpl->{cf_nsid}
813 245         1349 , @_);
814 245         861 $tmpl->{Widget}{$name} = $widget;
815 245         366 push @{$tmpl->{widget_list}}, $widget;
  245         700  
816 245         517 $widget;
817             }
818              
819             sub current_parser {
820 0     0 0 0 my Root $root = shift;
821 0         0 $root->{current_parser}[0];
822             }
823              
824 2     2 0 4 sub after_define_args {shift; shift}
  2         3  
825              
826             sub define_args {
827 194     194 0 462 (my Root $root, my ($target, $args)) = @_;
828              
829             # $target は has_arg($name) と add_arg($name, $arg) を実装しているもの。
830             # *: widget
831             # *: codevar
832              
833 194         769 for (; $args->readable; $args->next) {
834             # マクロ引数呼び出し %name(); がここで出現
835             # comment も現れうる。
836             # body = [code title=html] みたいなグループ引数もここで。
837              
838 309 100       1030 my $sub = $root->can("add_decl_" . $args->node_type_name)
839             or next;
840              
841 290         861 $sub->($root, $target, $args);
842             }
843              
844             # おまけ。使わないけど、デバッグ時に少し幸せ。
845 193         385 $root;
846             }
847              
848             sub add_decl_attribute {
849 239     239 0 490 (my Root $root, my ($target, $args)) = @_;
850 239         738 my $argname = $args->node_name;
851 239 50       603 unless (defined $argname) {
852 0         0 die $root->node_error($args, "Undefined att name!");
853             }
854 239 50       868 if ($target->has_arg($argname)) {
855 0         0 die $root->node_error($args, "Duplicate argname: $argname");
856             }
857              
858 239         998 my ($type, @param) = $args->parse_typespec;
859 239         368 my ($typename, $subtype) = do {
860 239 100       523 if (ref $type) {
861 3         10 ($type->[0], [@{$type}[1 .. $#$type]])
  3         13  
862             } else {
863 236         524 ($type, undef);
864             }
865             };
866 239 100 100     1484 if (defined $typename and my $sub = $root->can("attr_declare_$typename")) {
867 7         35 $sub->($root, $target, $args, $argname, $subtype, @param);
868             } else {
869 232         764 $target->add_arg($argname, $root->create_var($type, $args, @param));
870             }
871             }
872              
873             sub create_var {
874 427     427 0 1210 (my Root $root, my ($type, $args, @param)) = @_;
875 427 100       1123 $type = '' unless defined $type;
876 427 100       1116 my ($primary, @subtype) = ref $type ? @$type : $type;
877 427 50       1571 defined (my $class = $root->{cf_type_map}{$primary})
878             or croak $root->node_error($args, "No such type: %s", $primary);
879 427 50       945 unshift @param, subtype => @subtype >= 2 ? \@subtype : $subtype[0]
    100          
880             if @subtype;
881 427 100       2094 if (my $sub = $root->can("create_var_$primary")) {
882 172         595 $sub->($root, $args, @param);
883             } else {
884 255         1733 $class->new(@param);
885             }
886             }
887              
888             #========================================
889             {
890 4     4   26 package YATT::Registry::Loader; use YATT::Inc;
  4         7  
  4         21  
891 4     4   29 use base qw(YATT::Class::Configurable);
  4         8  
  4         293  
892 4     4   21 use YATT::Fields qw(Cache);
  4         11  
  4         19  
893 4     4   22 use Carp;
  4         6  
  4         235  
894 4     4   19 use YATT::Registry::NS;
  4         8  
  4         1051  
895              
896             sub DIR () { 'YATT::Registry::Loader::DIR' }
897              
898             sub handle_refresh {
899 222     222 0 398 (my MY $loader, my Root $root, my NS $node) = @_;
900 222         894 my $type = $node->type_name;
901 222 50       1345 if (my $sub = $loader->can("refresh_$type")) {
902 222         662 $sub->($loader, $root, $node);
903             } else {
904 0         0 confess "Can't refresh type: $type";
905             }
906             }
907              
908             sub is_modified {
909 222     222 0 384 my MY $loader = shift;
910 222         556 my ($item, $old) = @_;
911 222         814 my $mtime = $loader->mtime($item);
912 222 100 100     1072 return if defined $old and $old >= $mtime;
913 199         800 $_[1] = $mtime;
914 199         719 return 1;
915             }
916              
917             package YATT::Registry::Loader::DIR;
918              
919 4     4   27 use base qw(YATT::Registry::Loader File::Spec);
  4         6  
  4         615  
920 4     4   23 use YATT::Fields qw(cf_DIR cf_LIB);
  4         5  
  4         20  
921 20     20   108 sub initargs { qw(cf_DIR) }
922             sub init {
923 20     20   62 my ($self, $dir) = splice @_, 0, 2;
924 20         94 $self->SUPER::init($dir, @_);
925 20 100       666 if (-d (my $libdir = "$dir/lib")) {
926 1         8 require lib; import lib $libdir
  1         11  
927             }
928 20         213 $self;
929             }
930              
931 4     4   19 use YATT::Registry::NS;
  4         8  
  4         248  
932 4     4   21 use YATT::Util;
  4         8  
  4         664  
933 4     4   18 use YATT::Util::Taint;
  4         9  
  4         610  
934              
935 222     222   303 sub mtime { shift; (stat(shift))[9]; }
  222         8137  
936              
937             sub RCFILE () {'.htyattrc'}
938             sub Parser () {'YATT::LRXML::Parser'}
939              
940 4     4   25 use Carp;
  4         6  
  4         5720  
941              
942             sub checked_read_file {
943 17     17   49 (my MY $loader, my ($fn, $layer)) = @_;
944 17 50       82 croak "Given path is tainted! $fn" if is_tainted($fn);
945 17 50 50     812 open my $fh, '<' . ($layer || ''), $fn
946             or die "Can't open $fn! $!";
947 17         81 local $/;
948 17         539 scalar <$fh>;
949             }
950              
951             sub refresh_Dir {
952 64     64   115 (my MY $loader, my Root $root, my Dir $dir) = @_;
953 64         141 my $dirname = $dir->{cf_loadkey};
954             # ファイルリストの処理.
955 64 100       304 return unless $loader->is_modified($dirname, $dir->{cf_mtime}{$dirname});
956              
957 43         132 my $is_reload = $dir->{cf_age}++;
958 43         95 undef $dir->{is_loaded};
959              
960 43 50       174 if (is_tainted($dirname)) {
961 0         0 croak "Directory $dirname is tainted"
962             }
963              
964 43 100       117 if ($root == $dir) {
965 21 50       69 foreach my $d ($dirname, map {!defined $_ ? () : ref $_ ? @$_ : $_}
  21 100       122  
966             $loader->{cf_LIB}) {
967 38         142 $loader->load_dir($root, $dir, $d);
968             }
969             } else {
970 22         86 $loader->load_dir($root, $dir, $dirname);
971             }
972              
973             # RC 読み込みの前に、 default_base_class を設定。
974 43 100 66     192 if ($root->{cf_default_base_class}
      66        
975             and ($root->{cf_default_base_class} ne $root->{cf_pkg}
976             or $root->{is_loaded})) {
977             # XXX: add_isa じゃなくて ensure_isa だね。
978             #print STDERR "loading default_base_class $root->{cf_default_base_class}"
979             # . " for dir $dirname\n";
980 4         22 $root->checked_eval(qq{require $root->{cf_default_base_class}});
981             $root->add_isa(my $pkg = $root->get_package($dir)
982 4         14 , $root->{cf_default_base_class});
983             }
984              
985             # RC 読み込みは、最後に
986 43         515 my $rcfile = $loader->catfile($dirname, $loader->RCFILE);
987 43 100       1193 if (-r $rcfile) {
988 17         36 my $script = "";
989 17 100       63 $script .= ";no warnings 'redefine';" if $is_reload;
990             $script .= sprintf(qq{\n#line 1 "%s"\n}, $rcfile)
991 17 100       92 unless $root->{cf_no_lineinfo};
992 17         80 $script .= untaint_any($loader->checked_read_file($rcfile));
993 17         81 &YATT::break_rc;
994             $root->with_reloading_flag
995             ($is_reload, sub {
996 17     17   72 $root->eval_in_dir($dir, $script);
997 17         131 });
998 17         98 &YATT::break_after_rc;
999              
1000 17         72 $dir->after_rc_loaded($root);
1001             }
1002              
1003 43         136 $dir;
1004             }
1005              
1006             sub load_dir {
1007 60     60   125 (my MY $loader, my Root $root, my Dir $dir, my ($dirname)) = @_;
1008 60         179 local *DIR;
1009 60 50       2168 opendir DIR, $dirname or die "Can't open dir '$dirname': $!";
1010 60         1679 while (my $name = readdir(DIR)) {
1011 542 100       1977 next if $name =~ /^\./;
1012 391         3379 my $path = $loader->catfile($dirname, $name);
1013             # entry を作るだけ。load はしない。→ mtime も、子供側で。
1014 391 100       9703 if (-d $path) {
    100          
1015 96 50       591 next unless $name =~ /^(?:\w|-)+$/; # Not CC for future widechar.
1016             $dir->{Dir}{$name} ||= $loader->{Cache}{$path}
1017             ||= $root->createNS(Dir => name => $name
1018             , loadkey => untaint_any($path)
1019             , parent_nsid => $dir->{cf_nsid}
1020             , base_nsid => $dir->{cf_base_nsid}
1021 96   33     929 );
      66        
1022             } elsif ($name =~ /^(\w+)\.html?$/) { # XXX: Should allow '-'.
1023             $dir->{Template}{$1} ||= $loader->{Cache}{$path}
1024             ||= $root->createNS(Template => name => $1
1025             , loadkey => untaint_any($path)
1026             , parent_nsid => $dir->{cf_nsid}
1027             , base_nsid => $dir->{cf_base_nsid}
1028 163   33     1848 );
      66        
1029             }
1030             }
1031             # XXX: 無くなったファイルの開放は?
1032 60         920 closedir DIR;
1033             }
1034              
1035             sub refresh_Template {
1036 158     158   276 (my MY $loader, my Root $root, my Template $tmpl) = @_;
1037 158         350 my $path = $tmpl->{cf_loadkey};
1038 158 100       939 unless ($loader->is_modified($path, $tmpl->{cf_mtime}{$path})) {
1039             print STDERR "refresh_Template: not modified: $path\n"
1040 2 50       9 if $root->{cf_debug_registry};
1041 2         7 return;
1042             }
1043              
1044 156 50       773 if (is_tainted($path)) {
1045 0         0 croak "template path $path is tainted";
1046             }
1047              
1048 156 100       838 if (my $cleaner = $root->can("forget_template")) {
1049 146         532 $cleaner->($root, $tmpl);
1050             }
1051              
1052 156         415 my $is_reload = $tmpl->{cf_age}++;
1053 156         318 undef $tmpl->{is_loaded};
1054              
1055             $root->add_isa(my $pkg = $root->get_package($tmpl)
1056 156         569 , $root->get_package($tmpl->{cf_parent_nsid}));
1057 156 50       506 foreach my $name (map {defined $_ ? @$_ : ()}
  156         601  
1058             $root->{cf_template_global}) {
1059 0         0 *{globref($pkg, $name)} = *{globref($root->{cf_app_prefix}, $name)};
  0         0  
  0         0  
1060             }
1061              
1062             # XXX: There can be a race. (mtime vs open)
1063             my $parser = $loader->call_type
1064             (Parser => new => untaint => 1
1065             , registry => $root
1066 156         1075 , special_entities => $root->{cf_special_entities});
1067 156         613 local $root->{current_parser}[0] = $parser;
1068              
1069 156 50       9156 open my $fh, '<', $path or die "Can't open $path";
1070              
1071             $tmpl->{cf_metainfo} = $parser->configure_metainfo
1072             (nsid => $tmpl->{cf_nsid}
1073 156         1077 , namespace => $root->namespace
1074             , filename => $path);
1075              
1076 156         771 $tmpl->{tree} = $parser->parse_handle($fh);
1077              
1078             # XXX: ついでに を解釈. ← parser に前倒し。
1079             # $root->process_declarations($tmpl);
1080             }
1081             }
1082              
1083             #========================================
1084              
1085             sub _lined {
1086 0     0   0 my $i = 1;
1087 0         0 my $result;
1088 0         0 foreach my $line (split /\n/, $_[0]) {
1089 0 0       0 if ($line =~ /^\#line (\d+)/) {
1090 0         0 $i = $1;
1091 0         0 $result .= $line . "\n";
1092             } else {
1093 0         0 $result .= sprintf "% 3d %s\n", $i++, $line;
1094             }
1095             }
1096             $result
1097 0         0 }
1098              
1099             1;