line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- mode: perl; coding: utf-8 -*- |
2
|
|
|
|
|
|
|
package YATT::Types; |
3
|
10
|
|
|
10
|
|
45
|
use strict; |
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
290
|
|
4
|
10
|
|
|
10
|
|
50
|
use warnings qw(FATAL all NONFATAL misc); |
|
10
|
|
|
|
|
16
|
|
|
10
|
|
|
|
|
395
|
|
5
|
10
|
|
|
10
|
|
47
|
use Carp; |
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
578
|
|
6
|
10
|
|
|
10
|
|
64
|
use YATT::Util::Symbol; |
|
10
|
|
|
|
|
19
|
|
|
10
|
|
|
|
|
999
|
|
7
|
10
|
|
|
10
|
|
53
|
use YATT::Util qw(terse_dump); |
|
10
|
|
|
|
|
19
|
|
|
10
|
|
|
|
|
804
|
|
8
|
|
|
|
|
|
|
require YATT::Inc; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
sub Base () { 'YATT::Class::Configurable' } |
11
|
10
|
|
|
10
|
|
50
|
use base Base; |
|
10
|
|
|
|
|
16
|
|
|
10
|
|
|
|
|
946
|
|
12
|
10
|
|
|
|
|
82
|
use YATT::Fields qw( |
13
|
|
|
|
|
|
|
classes |
14
|
|
|
|
|
|
|
aliases |
15
|
|
|
|
|
|
|
default_methods |
16
|
|
|
|
|
|
|
cf_rules |
17
|
|
|
|
|
|
|
) |
18
|
|
|
|
|
|
|
, [cf_base => Base] |
19
|
|
|
|
|
|
|
, qw(cf_callpack |
20
|
|
|
|
|
|
|
cf_export_alias |
21
|
|
|
|
|
|
|
cf_type_name |
22
|
|
|
|
|
|
|
cf_debug |
23
|
10
|
|
|
10
|
|
56
|
); |
|
10
|
|
|
|
|
21
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
#======================================== |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub import { |
28
|
38
|
|
|
38
|
|
881
|
my $pack = shift; |
29
|
38
|
|
|
|
|
122
|
my ($callpack) = caller; |
30
|
38
|
|
|
|
|
194
|
my %rules = (struct => [], inheritance => []); |
31
|
38
|
|
|
|
|
178
|
$pack->parse_args(\@_, \my @conf, \%rules, 'struct'); |
32
|
|
|
|
|
|
|
# use Data::Dumper; print Dumper(\%rules), "\n"; |
33
|
38
|
|
|
|
|
280
|
$pack->new(callpack => $callpack, @conf, rules => \%rules) |
34
|
|
|
|
|
|
|
->export; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# XXX: 交互でも行けるようになったはず。テストを。 |
38
|
|
|
|
|
|
|
# XXX: -constant も欲しい ← @EXPORT に入れない。 |
39
|
|
|
|
|
|
|
# XXX: \inheritance も。 |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub parse_args { |
42
|
38
|
|
|
38
|
0
|
88
|
my ($pack, $arglist, $conflist, $taskqueue, $default_task) = @_; |
43
|
38
|
|
|
|
|
157
|
while (@$arglist) { |
44
|
116
|
100
|
|
|
|
567
|
if (ref $arglist->[0]) { |
|
|
50
|
|
|
|
|
|
45
|
55
|
|
|
|
|
68
|
my ($task_name, $task_arg) = do { |
46
|
55
|
50
|
|
|
|
151
|
if (ref $arglist->[0] eq 'ARRAY') { |
|
|
0
|
|
|
|
|
|
47
|
55
|
|
|
|
|
132
|
($default_task, shift @$arglist); |
48
|
|
|
|
|
|
|
} elsif (ref $arglist->[0] eq 'SCALAR') { |
49
|
0
|
|
|
|
|
0
|
(${shift @$arglist}, shift @$arglist); |
|
0
|
|
|
|
|
0
|
|
50
|
|
|
|
|
|
|
} else { |
51
|
0
|
|
|
|
|
0
|
croak "Invalid option '$arglist->[0]'"; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
}; |
54
|
55
|
50
|
|
|
|
174
|
unless (defined $taskqueue->{$task_name}) { |
55
|
0
|
|
|
|
|
0
|
croak "Invalid task: $task_name"; |
56
|
|
|
|
|
|
|
} |
57
|
55
|
|
|
|
|
133
|
push @{$taskqueue->{$task_name}}, $task_arg; |
|
55
|
|
|
|
|
238
|
|
58
|
|
|
|
|
|
|
} elsif (my ($flag, $key) = $arglist->[0] =~ /^([\-:])(\w+)/) { |
59
|
61
|
|
|
|
|
92
|
shift @$arglist; |
60
|
61
|
100
|
|
|
|
153
|
my $value = $flag eq ':' ? 1 : shift @$arglist; |
61
|
61
|
|
|
|
|
255
|
push @$conflist, $key, $value; |
62
|
|
|
|
|
|
|
} else { |
63
|
0
|
|
|
|
|
0
|
croak "Invalid option '$arglist->[0]'"; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub export { |
69
|
38
|
|
|
38
|
0
|
56
|
my MY $opts = shift; |
70
|
38
|
|
|
|
|
109
|
my $script = $opts->make; |
71
|
38
|
50
|
|
|
|
124
|
print STDERR $script if $opts->{cf_debug}; |
72
|
10
|
|
|
10
|
0
|
55
|
eval $script; |
|
10
|
|
|
10
|
|
18
|
|
|
10
|
|
|
10
|
|
1052
|
|
|
10
|
|
|
10
|
|
52
|
|
|
10
|
|
|
10
|
|
18
|
|
|
10
|
|
|
4
|
|
69
|
|
|
10
|
|
|
4
|
|
52
|
|
|
10
|
|
|
4
|
|
19
|
|
|
10
|
|
|
4
|
|
748
|
|
|
10
|
|
|
4
|
|
50
|
|
|
10
|
|
|
4
|
|
17
|
|
|
10
|
|
|
4
|
|
71
|
|
|
10
|
|
|
3
|
|
53
|
|
|
10
|
|
|
3
|
|
21
|
|
|
10
|
|
|
3
|
|
1850
|
|
|
4
|
|
|
3
|
|
22
|
|
|
4
|
|
|
3
|
|
7
|
|
|
4
|
|
|
3
|
|
411
|
|
|
4
|
|
|
3
|
|
22
|
|
|
4
|
|
|
2
|
|
4
|
|
|
4
|
|
|
2
|
|
83
|
|
|
4
|
|
|
1
|
|
22
|
|
|
4
|
|
|
1
|
|
8
|
|
|
4
|
|
|
1
|
|
355
|
|
|
4
|
|
|
1
|
|
20
|
|
|
4
|
|
|
1
|
|
10
|
|
|
4
|
|
|
1
|
|
109
|
|
|
4
|
|
|
20
|
|
21
|
|
|
4
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
1216
|
|
|
4
|
|
|
|
|
23
|
|
|
4
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
110
|
|
|
4
|
|
|
|
|
22
|
|
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
888
|
|
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
106
|
|
|
3
|
|
|
|
|
17
|
|
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
167
|
|
|
3
|
|
|
|
|
15
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
80
|
|
|
3
|
|
|
|
|
17
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
162
|
|
|
3
|
|
|
|
|
15
|
|
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
98
|
|
|
3
|
|
|
|
|
15
|
|
|
3
|
|
|
|
|
14
|
|
|
3
|
|
|
|
|
160
|
|
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
79
|
|
|
2
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
73
|
|
|
2
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
137
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
90
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
81
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
98
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
11
|
|
|
38
|
|
|
|
|
3542
|
|
|
20
|
|
|
|
|
371
|
|
73
|
38
|
50
|
|
|
|
33605
|
die $@ if $@; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
#---------------------------------------- |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub configure_base { |
79
|
22
|
|
|
22
|
0
|
45
|
(my MY $opts, my ($value)) = @_; |
80
|
22
|
100
|
|
|
|
60
|
if (ref $value) { |
81
|
4
|
|
|
|
|
8
|
push @{$$opts{aliases}}, $value; |
|
4
|
|
|
|
|
15
|
|
82
|
4
|
|
|
|
|
13
|
$opts->{cf_base} = $value->[1]; |
83
|
|
|
|
|
|
|
} else { |
84
|
18
|
|
|
|
|
47
|
$opts->{cf_base} = $value; |
85
|
|
|
|
|
|
|
} |
86
|
22
|
|
|
|
|
74
|
$opts; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub configure_alias { |
90
|
14
|
|
|
14
|
0
|
30
|
(my MY $opts, my ($value)) = @_; |
91
|
14
|
|
|
|
|
22
|
push @{$opts->{aliases}}, chunklist($value); |
|
14
|
|
|
|
|
60
|
|
92
|
14
|
|
|
|
|
45
|
$opts; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub configure_default { |
96
|
4
|
|
|
4
|
0
|
11
|
(my MY $opts, my ($value)) = @_; |
97
|
4
|
|
|
|
|
7
|
push @{$opts->{default_methods}}, chunklist($value); |
|
4
|
|
|
|
|
14
|
|
98
|
4
|
|
|
|
|
13
|
$opts; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
#======================================== |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub make { |
104
|
38
|
|
|
38
|
0
|
63
|
my MY $opts = shift; |
105
|
38
|
|
|
|
|
51
|
my $script; |
106
|
|
|
|
|
|
|
# 順番が有る。 |
107
|
38
|
|
|
|
|
73
|
foreach my $rule (qw(struct inheritance)) { |
108
|
76
|
50
|
|
|
|
247
|
next unless my $descs = $opts->{cf_rules}{$rule}; |
109
|
76
|
100
|
|
|
|
200
|
next unless @$descs; |
110
|
32
|
|
|
|
|
171
|
$script .= $opts->can("make_$rule")->($opts, @$descs); |
111
|
|
|
|
|
|
|
} |
112
|
38
|
|
|
|
|
113
|
$script .= $opts->make_class_aliases; |
113
|
38
|
|
|
|
|
125
|
$script .= $opts->make_default_methods; |
114
|
38
|
|
|
|
|
109
|
$script; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub make_struct { |
118
|
32
|
|
|
32
|
0
|
59
|
my MY $opts = shift; |
119
|
32
|
|
|
|
|
40
|
my @result; |
120
|
32
|
|
|
|
|
69
|
foreach my $desc (@_) { |
121
|
|
|
|
|
|
|
push @result, $opts->make_class_nesting |
122
|
|
|
|
|
|
|
($desc, $$opts{cf_callpack} . '::' |
123
|
55
|
|
33
|
|
|
298
|
, $$opts{cf_base} || $opts->Base); |
124
|
|
|
|
|
|
|
} |
125
|
32
|
|
|
|
|
187
|
join "", @result; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub list_aliases { |
129
|
38
|
|
|
38
|
0
|
55
|
my MY $opts = shift; |
130
|
38
|
|
|
|
|
58
|
map {$$_[0]} @{$$opts{classes}}, @{$$opts{aliases}}; |
|
92
|
|
|
|
|
249
|
|
|
38
|
|
|
|
|
84
|
|
|
38
|
|
|
|
|
87
|
|
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub make_class_aliases { |
134
|
38
|
|
|
38
|
0
|
64
|
my MY $opts = shift; |
135
|
38
|
|
|
|
|
106
|
my $aliases = join "\n ", $opts->list_aliases; |
136
|
38
|
|
|
|
|
143
|
my $script = <
|
137
|
|
|
|
|
|
|
package $$opts{cf_callpack}; |
138
|
|
|
|
|
|
|
push our \@EXPORT_OK, qw($aliases); |
139
|
|
|
|
|
|
|
END |
140
|
|
|
|
|
|
|
|
141
|
38
|
100
|
|
|
|
147
|
$script .= <
|
142
|
|
|
|
|
|
|
push our \@EXPORT, qw($aliases); |
143
|
|
|
|
|
|
|
END |
144
|
|
|
|
|
|
|
|
145
|
38
|
|
|
|
|
73
|
my $stash = *{globref($$opts{cf_callpack}, '')}{HASH}; |
|
38
|
|
|
|
|
141
|
|
146
|
|
|
|
|
|
|
print STDERR "# [$$opts{cf_callpack} has] " |
147
|
|
|
|
|
|
|
, join(" ", sort keys %$stash), "\n" |
148
|
38
|
50
|
|
|
|
157
|
if $opts->{cf_debug}; |
149
|
38
|
|
|
|
|
61
|
foreach my $classdef (@{$$opts{classes}}, @{$$opts{aliases}}) { |
|
38
|
|
|
|
|
77
|
|
|
38
|
|
|
|
|
99
|
|
150
|
|
|
|
|
|
|
# Ignore if alias is already defined. |
151
|
92
|
|
|
|
|
171
|
my $entry = $stash->{$classdef->[0]}; |
152
|
92
|
50
|
66
|
|
|
205
|
next if defined $entry and $entry->{CODE}; |
153
|
|
|
|
|
|
|
|
154
|
92
|
|
|
|
|
309
|
$script .= qq{sub $classdef->[0] () {'$classdef->[1]'}\n}; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
38
|
|
|
|
|
216
|
$script; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub make_class_nesting { |
161
|
60
|
|
|
60
|
0
|
155
|
(my MY $opts, my ($desc, $prefix, $super)) = @_; |
162
|
60
|
|
|
|
|
146
|
my ($class, $slots) = splice @$desc, 0, 2; |
163
|
60
|
|
|
|
|
99
|
push @{$$opts{classes}}, [$class, $prefix.$class]; |
|
60
|
|
|
|
|
233
|
|
164
|
|
|
|
|
|
|
my $script = $opts->make_class($prefix.$class, $super |
165
|
|
|
|
|
|
|
, terse_dump(@$slots |
166
|
60
|
100
|
|
|
|
275
|
, map {ref $_ ? $$_[0] : $_} |
|
9
|
|
|
|
|
47
|
|
167
|
|
|
|
|
|
|
@$desc)); |
168
|
|
|
|
|
|
|
|
169
|
60
|
100
|
|
|
|
260
|
$script .= <{cf_type_name}; |
170
|
|
|
|
|
|
|
sub $prefix${class}::type_name () {'$class'} |
171
|
|
|
|
|
|
|
END |
172
|
|
|
|
|
|
|
|
173
|
60
|
|
|
|
|
133
|
foreach my $child (@$desc) { |
174
|
9
|
100
|
|
|
|
30
|
next unless ref $child; |
175
|
5
|
|
|
|
|
26
|
$script .= $opts->make_class_nesting($child, $prefix, $super); |
176
|
|
|
|
|
|
|
} |
177
|
60
|
|
|
|
|
185
|
$script; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub make_class { |
181
|
60
|
|
|
60
|
0
|
2411
|
my ($self, $class, $super, $slots) = @_; |
182
|
60
|
|
|
|
|
262
|
YATT::Inc->add_inc($class); |
183
|
60
|
50
|
|
|
|
457
|
<
|
|
|
100
|
|
|
|
|
|
184
|
|
|
|
|
|
|
package $class; |
185
|
|
|
|
|
|
|
END |
186
|
|
|
|
|
|
|
use base qw($super); |
187
|
|
|
|
|
|
|
END |
188
|
|
|
|
|
|
|
use YATT::Fields $slots; |
189
|
|
|
|
|
|
|
END |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub make_default_methods { |
193
|
38
|
|
|
38
|
0
|
63
|
my MY $opts = shift; |
194
|
38
|
|
|
|
|
58
|
join "", map {<
|
|
4
|
|
|
|
|
25
|
|
|
38
|
|
|
|
|
126
|
|
195
|
|
|
|
|
|
|
sub default_$$_[0] {'$$_[1]'} |
196
|
|
|
|
|
|
|
END |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
#---------------------------------------- |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
sub chunklist { |
203
|
18
|
|
|
18
|
0
|
31
|
my ($arg) = @_; |
204
|
18
|
|
|
|
|
22
|
my @list; |
205
|
18
|
50
|
|
|
|
52
|
if (ref $arg eq 'ARRAY') { |
|
|
0
|
|
|
|
|
|
206
|
18
|
|
|
|
|
159
|
push @list, [splice @$arg, 0, 2] while @$arg; |
207
|
|
|
|
|
|
|
} elsif (ref $arg eq 'HASH') { |
208
|
0
|
|
|
|
|
0
|
while (my ($k, $v) = each %$arg) { |
209
|
0
|
|
|
|
|
0
|
push @list, [$k, $v]; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} else { |
212
|
0
|
|
|
|
|
0
|
croak "Invalid arg for -alias"; |
213
|
|
|
|
|
|
|
} |
214
|
18
|
50
|
|
|
|
67
|
wantarray ? @list : \@list; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
1; |