line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Deprecated class |
2
|
|
|
|
|
|
|
package Object::Simple::Accessor; |
3
|
|
|
|
|
|
|
|
4
|
1
|
|
|
1
|
|
3
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
20
|
|
5
|
1
|
|
|
1
|
|
3
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
19
|
|
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
2
|
use Carp 'croak'; |
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
178
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
sub create_accessors { |
10
|
25
|
|
|
25
|
0
|
39
|
my ($type, $class, $attrs, @options) = @_; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# To array |
13
|
25
|
100
|
|
|
|
53
|
$attrs = [$attrs] unless ref $attrs eq 'ARRAY'; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# Arrange options |
16
|
25
|
100
|
|
|
|
65
|
my $options = @options > 1 ? {@options} : {default => $options[0]}; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Check options |
19
|
25
|
|
|
|
|
50
|
foreach my $oname (keys %$options) { |
20
|
31
|
100
|
100
|
|
|
275
|
croak "'$oname' is invalid option" |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
21
|
|
|
|
|
|
|
if !($oname eq 'default' || $oname eq 'inherit') |
22
|
|
|
|
|
|
|
|| ($type eq 'attr' && $oname ne 'default'); |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# Create accessors |
26
|
23
|
|
|
|
|
25
|
foreach my $attr (@$attrs) { |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# Create accessor |
29
|
27
|
50
|
|
|
|
65
|
my $code = $type eq 'attr' |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
30
|
|
|
|
|
|
|
? create_accessor($class, $attr, $options) |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
: $type eq 'class_attr' |
33
|
|
|
|
|
|
|
? create_class_accessor($class, $attr, $options) |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
: $type eq 'dual_attr' |
36
|
|
|
|
|
|
|
? create_dual_accessor($class, $attr, $options) |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
: undef; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Import |
41
|
1
|
|
|
1
|
|
7
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
252
|
|
42
|
26
|
|
|
|
|
16
|
*{"${class}::$attr"} = $code; |
|
26
|
|
|
|
|
147
|
|
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub create_attr_accessor { |
47
|
0
|
|
|
0
|
0
|
0
|
my $class = shift; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub create_accessor { |
53
|
40
|
|
|
40
|
0
|
40
|
my ($class, $attr, $options, $type) = @_; |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# Options |
56
|
40
|
|
|
|
|
53
|
my $default = $options->{default}; |
57
|
40
|
|
100
|
|
|
83
|
my $inherit = $options->{inherit} || ''; |
58
|
|
|
|
|
|
|
|
59
|
40
|
100
|
|
|
|
49
|
if ($inherit) { |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# Rearrange Inherit option |
62
|
4
|
|
|
4
|
|
8
|
$options->{inherit} = $inherit eq 'scalar_copy' ? sub { $_[0] } |
63
|
5
|
|
|
5
|
|
5
|
: $inherit eq 'array_copy' ? sub { [@{$_[0]}] } |
|
5
|
|
|
|
|
14
|
|
64
|
5
|
|
|
5
|
|
5
|
: $inherit eq 'hash_copy' ? sub { return {%{$_[0]}} } |
|
5
|
|
|
|
|
23
|
|
65
|
|
|
|
|
|
|
: undef |
66
|
10
|
100
|
|
|
|
38
|
unless ref $inherit eq 'CODE'; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# Check inherit options |
69
|
|
|
|
|
|
|
croak "'inherit' opiton must be 'scalar_copy', 'array_copy', " . |
70
|
|
|
|
|
|
|
"'hash_copy', or code reference (${class}::$attr)" |
71
|
10
|
100
|
|
|
|
115
|
unless $options->{inherit}; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# Check default option |
75
|
39
|
50
|
66
|
|
|
72
|
croak "'default' option must be scalar or code ref (${class}::$attr)" |
76
|
|
|
|
|
|
|
unless !ref $default || ref $default eq 'CODE'; |
77
|
|
|
|
|
|
|
|
78
|
39
|
|
|
|
|
24
|
my $code; |
79
|
|
|
|
|
|
|
# Class Accessor |
80
|
39
|
100
|
100
|
|
|
98
|
if (($type || '') eq 'class') { |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# With inherit option |
83
|
26
|
100
|
|
|
|
33
|
if ($inherit) { |
|
|
100
|
|
|
|
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
return sub { |
90
|
|
|
|
|
|
|
|
91
|
54
|
|
|
54
|
|
390
|
my $self = shift; |
92
|
|
|
|
|
|
|
|
93
|
54
|
100
|
|
|
|
144
|
croak "${class}::$attr must be called from class." |
94
|
|
|
|
|
|
|
if ref $self; |
95
|
|
|
|
|
|
|
|
96
|
53
|
|
|
|
|
36
|
my $class_attrs = do { |
97
|
1
|
|
|
1
|
|
4
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
164
|
|
98
|
53
|
|
100
|
|
|
31
|
${"${self}::CLASS_ATTRS"} ||= {}; |
|
53
|
|
|
|
|
157
|
|
99
|
|
|
|
|
|
|
}; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
inherit_attribute($self, $attr, $options) |
102
|
53
|
100
|
100
|
|
|
179
|
if @_ == 0 && ! exists $class_attrs->{$attr}; |
103
|
|
|
|
|
|
|
|
104
|
53
|
100
|
|
|
|
84
|
if(@_ > 0) { |
105
|
|
|
|
|
|
|
|
106
|
18
|
100
|
|
|
|
124
|
croak qq{One argument must be passed to "${class}::$attr()"} |
107
|
|
|
|
|
|
|
if @_ > 1; |
108
|
|
|
|
|
|
|
|
109
|
17
|
|
|
|
|
21
|
$class_attrs->{$attr} = $_[0]; |
110
|
|
|
|
|
|
|
|
111
|
17
|
|
|
|
|
35
|
return $self; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
35
|
|
|
|
|
105
|
return $class_attrs->{$attr}; |
115
|
6
|
|
|
|
|
22
|
}; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# With default option |
124
|
|
|
|
|
|
|
elsif (defined $default) { |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
return sub { |
131
|
|
|
|
|
|
|
|
132
|
20
|
|
|
20
|
|
798
|
my $self = shift; |
133
|
|
|
|
|
|
|
|
134
|
20
|
100
|
|
|
|
97
|
croak "${class}::$attr must be called from class." |
135
|
|
|
|
|
|
|
if ref $self; |
136
|
|
|
|
|
|
|
|
137
|
19
|
|
|
|
|
15
|
my $class_attrs = do { |
138
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
201
|
|
139
|
19
|
|
50
|
|
|
14
|
${"${self}::CLASS_ATTRS"} ||= {}; |
|
19
|
|
|
|
|
57
|
|
140
|
|
|
|
|
|
|
}; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
$class_attrs->{$attr} = ref $default ? $default->($self) : $default |
143
|
19
|
100
|
100
|
|
|
101
|
if @_ == 0 && ! exists $class_attrs->{$attr}; |
|
|
100
|
|
|
|
|
|
144
|
|
|
|
|
|
|
|
145
|
19
|
100
|
|
|
|
37
|
if(@_ > 0) { |
146
|
|
|
|
|
|
|
|
147
|
3
|
100
|
|
|
|
102
|
croak qq{One argument must be passed to "${class}::$attr()"} |
148
|
|
|
|
|
|
|
if @_ > 1; |
149
|
|
|
|
|
|
|
|
150
|
2
|
|
|
|
|
4
|
$class_attrs->{$attr} = $_[0]; |
151
|
|
|
|
|
|
|
|
152
|
2
|
|
|
|
|
6
|
return $self; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
16
|
|
|
|
|
59
|
return $class_attrs->{$attr}; |
156
|
|
|
|
|
|
|
|
157
|
12
|
|
|
|
|
42
|
}; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# Without option |
166
|
|
|
|
|
|
|
else { |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
return sub { |
173
|
|
|
|
|
|
|
|
174
|
19
|
|
|
19
|
|
20
|
my $self = shift; |
175
|
|
|
|
|
|
|
|
176
|
19
|
100
|
|
|
|
98
|
croak "${class}::$attr must be called from class." |
177
|
|
|
|
|
|
|
if ref $self; |
178
|
|
|
|
|
|
|
|
179
|
18
|
|
|
|
|
13
|
my $class_attrs = do { |
180
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
502
|
|
181
|
18
|
|
100
|
|
|
12
|
${"${self}::CLASS_ATTRS"} ||= {}; |
|
18
|
|
|
|
|
59
|
|
182
|
|
|
|
|
|
|
}; |
183
|
|
|
|
|
|
|
|
184
|
18
|
100
|
|
|
|
29
|
if(@_ > 0) { |
185
|
|
|
|
|
|
|
|
186
|
10
|
100
|
|
|
|
109
|
croak qq{One argument must be passed to "${class}::$attr()"} |
187
|
|
|
|
|
|
|
if @_ > 1; |
188
|
|
|
|
|
|
|
|
189
|
9
|
|
|
|
|
12
|
$class_attrs->{$attr} = $_[0]; |
190
|
|
|
|
|
|
|
|
191
|
9
|
|
|
|
|
15
|
return $self; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
8
|
|
|
|
|
31
|
return $class_attrs->{$attr}; |
195
|
8
|
|
|
|
|
30
|
}; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# Normal accessor |
205
|
|
|
|
|
|
|
else { |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# With inherit option |
208
|
13
|
100
|
|
|
|
17
|
if ($inherit) { |
|
|
100
|
|
|
|
|
|
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
return sub { |
215
|
|
|
|
|
|
|
|
216
|
12
|
|
|
12
|
|
10
|
my $self = shift; |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
inherit_attribute($self, $attr, $options) |
219
|
12
|
100
|
100
|
|
|
51
|
if @_ == 0 && ! exists $self->{$attr}; |
220
|
|
|
|
|
|
|
|
221
|
12
|
100
|
|
|
|
17
|
if(@_ > 0) { |
222
|
|
|
|
|
|
|
|
223
|
3
|
50
|
|
|
|
6
|
croak qq{One argument must be passed to "${class}::$attr()"} |
224
|
|
|
|
|
|
|
if @_ > 1; |
225
|
|
|
|
|
|
|
|
226
|
3
|
|
|
|
|
4
|
$self->{$attr} = $_[0]; |
227
|
|
|
|
|
|
|
|
228
|
3
|
|
|
|
|
9
|
return $self; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
9
|
|
|
|
|
36
|
return $self->{$attr}; |
232
|
3
|
|
|
|
|
18
|
}; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# With default option |
242
|
|
|
|
|
|
|
elsif (defined $default) { |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
return sub { |
249
|
|
|
|
|
|
|
|
250
|
6
|
|
|
6
|
|
7
|
my $self = shift; |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
$self->{$attr} = ref $default ? $default->($self) : $default |
253
|
6
|
100
|
33
|
|
|
38
|
if @_ == 0 && ! exists $self->{$attr}; |
|
|
50
|
|
|
|
|
|
254
|
|
|
|
|
|
|
|
255
|
6
|
50
|
|
|
|
12
|
if(@_ > 0) { |
256
|
|
|
|
|
|
|
|
257
|
0
|
0
|
|
|
|
0
|
croak qq{One argument must be passed to "${class}::$attr()"} if @_ > 1; |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
|
|
0
|
$self->{$attr} = $_[0]; |
260
|
|
|
|
|
|
|
|
261
|
0
|
|
|
|
|
0
|
return $self; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
6
|
|
|
|
|
26
|
return $self->{$attr}; |
265
|
6
|
|
|
|
|
21
|
}; |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# Without option |
274
|
|
|
|
|
|
|
else { |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
return sub { |
281
|
|
|
|
|
|
|
|
282
|
8
|
|
|
8
|
|
3
|
my $self = shift; |
283
|
|
|
|
|
|
|
|
284
|
8
|
100
|
|
|
|
15
|
if(@_ > 0) { |
285
|
|
|
|
|
|
|
|
286
|
4
|
50
|
|
|
|
10
|
croak qq{One argument must be passed to "${class}::$attr()"} if @_ > 1; |
287
|
|
|
|
|
|
|
|
288
|
4
|
|
|
|
|
5
|
$self->{$attr} = $_[0]; |
289
|
|
|
|
|
|
|
|
290
|
4
|
|
|
|
|
4
|
return $self; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
4
|
|
|
|
|
17
|
return $self->{$attr}; |
294
|
4
|
|
|
|
|
10
|
}; |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
27
|
|
|
27
|
0
|
28
|
sub create_class_accessor { create_accessor(@_, 'class') } |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
sub create_dual_accessor { |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
# Create dual accessor |
309
|
13
|
|
|
13
|
0
|
12
|
my $accessor = create_accessor(@_); |
310
|
13
|
|
|
|
|
16
|
my $class_accessor = create_class_accessor(@_); |
311
|
|
|
|
|
|
|
|
312
|
13
|
100
|
|
76
|
|
24
|
return sub { ref $_[0] ? $accessor->(@_) : $class_accessor->(@_) }; |
|
76
|
|
|
|
|
532
|
|
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
sub inherit_attribute { |
316
|
20
|
|
|
20
|
0
|
21
|
my ($proto, $attr, $options) = @_; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# Options |
319
|
20
|
|
|
|
|
20
|
my $inherit = $options->{inherit}; |
320
|
20
|
|
|
|
|
16
|
my $default = $options->{default}; |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# Called from a object |
323
|
20
|
100
|
|
|
|
35
|
if (my $class = ref $proto) { |
324
|
6
|
|
|
|
|
10
|
$proto->{$attr} = $inherit->($class->$attr); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# Called from a class |
328
|
|
|
|
|
|
|
else { |
329
|
14
|
|
|
|
|
9
|
my $base = do { |
330
|
1
|
|
|
1
|
|
4
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
70
|
|
331
|
14
|
|
|
|
|
11
|
${"${proto}::ISA"}[0]; |
|
14
|
|
|
|
|
38
|
|
332
|
|
|
|
|
|
|
}; |
333
|
14
|
100
|
|
|
|
19
|
$proto->$attr(eval { $base->can($attr) } |
|
14
|
100
|
|
|
|
103
|
|
334
|
|
|
|
|
|
|
? $inherit->($base->$attr) |
335
|
|
|
|
|
|
|
: ref $default ? $default->($proto) : $default); |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
1; |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=head1 NAME |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
Object::Simple::Accessor - DEPRECATED! |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
=cut |