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; |