File Coverage

web/cgi-bin/yatt.lib/YATT/Types.pm
Criterion Covered Total %
statement 196 204 96.0
branch 29 44 65.9
condition 3 6 50.0
subroutine 49 49 100.0
pod 0 14 0.0
total 277 317 87.3


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;