line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Class::Meta::Express; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
142350
|
use strict; |
|
2
|
|
|
|
|
13
|
|
|
2
|
|
|
|
|
64
|
|
4
|
2
|
|
|
2
|
|
9
|
use vars qw($VERSION); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
114
|
|
5
|
2
|
|
|
2
|
|
1461
|
use Class::Meta 0.60; |
|
2
|
|
|
|
|
30846
|
|
|
2
|
|
|
|
|
114
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
$VERSION = '0.14'; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
my %meta_for; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
sub import { |
12
|
18
|
|
|
18
|
|
22914
|
my $pkg = shift; |
13
|
18
|
|
|
|
|
40
|
my $caller = caller; |
14
|
2
|
|
|
2
|
|
14
|
no strict 'refs'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
1381
|
|
15
|
18
|
50
|
|
|
|
29
|
return shift if defined &{"$caller\::meta"}; |
|
18
|
|
|
|
|
176
|
|
16
|
108
|
|
|
|
|
560
|
*{"$caller\::$_"} = $pkg->can($_) |
17
|
18
|
|
|
|
|
109
|
for qw(class meta ctor has method build); |
18
|
18
|
|
|
|
|
2063
|
return shift; |
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub class (&) { |
22
|
14
|
|
|
14
|
1
|
25990
|
my $code = shift; |
23
|
|
|
|
|
|
|
goto sub { |
24
|
14
|
|
|
14
|
|
38
|
$code->(); |
25
|
14
|
|
|
|
|
1110
|
goto &build; |
26
|
14
|
|
|
|
|
54
|
}; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub meta { |
30
|
25
|
|
|
25
|
1
|
22696
|
_new_meta( scalar caller, @_ ); |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub ctor { |
34
|
8
|
|
|
8
|
1
|
54
|
unshift @_, 'constructor'; |
35
|
8
|
|
|
|
|
26
|
goto &_meth; |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub has { |
39
|
21
|
|
|
21
|
1
|
1043
|
my $caller = caller; |
40
|
21
|
|
|
|
|
50
|
my $meta = _meta_for( $caller ); |
41
|
21
|
|
|
|
|
60
|
unshift @_, $meta, 'name'; |
42
|
21
|
100
|
|
|
|
56
|
splice @_, 3, 1, %{ $_[3] } if ref $_[3] eq 'HASH'; |
|
2
|
|
|
|
|
9
|
|
43
|
21
|
|
|
|
|
27
|
goto &{ $meta->can('add_attribute') }; |
|
21
|
|
|
|
|
126
|
|
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub method { |
47
|
4
|
|
|
4
|
1
|
472
|
unshift @_, 'method'; |
48
|
4
|
|
|
|
|
12
|
goto &_meth; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub build { |
52
|
26
|
|
|
26
|
1
|
986
|
my $meta = delete $meta_for{ my $caller = caller }; |
53
|
|
|
|
|
|
|
# Remove exported functions. |
54
|
26
|
|
|
|
|
70
|
_unimport($caller); |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# Build the class. |
57
|
26
|
|
|
|
|
54
|
unshift @_, $meta; |
58
|
26
|
|
|
|
|
62
|
goto &{ $meta->can('build') }; |
|
26
|
|
|
|
|
165
|
|
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub _new_meta { |
62
|
26
|
|
|
26
|
|
68
|
my ($caller, $key) = (shift, shift); |
63
|
26
|
100
|
|
|
|
96
|
my $args = ref $_[0] eq 'HASH' ? $_[0] : { @_ }; |
64
|
26
|
|
|
|
|
62
|
$args->{key} = $key; |
65
|
26
|
100
|
|
|
|
89
|
_export(delete $args->{reexport}, $caller, $args) if $args->{reexport}; |
66
|
26
|
|
100
|
|
|
93
|
my $meta_class = delete $args->{meta_class} || 'Class::Meta'; |
67
|
26
|
|
|
|
|
44
|
my $meta = $meta_class->new( package => $caller, %{ $args } ); |
|
26
|
|
|
|
|
163
|
|
68
|
26
|
|
|
|
|
6539
|
$meta_for{$caller} = $meta; |
69
|
26
|
|
|
|
|
82
|
return $meta; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub _meta_for { |
73
|
33
|
|
|
33
|
|
54
|
my $caller = shift; |
74
|
33
|
100
|
|
|
|
129
|
unless ( $meta_for{ $caller } ) { |
75
|
|
|
|
|
|
|
# Create a key from the last part of the package name. |
76
|
1
|
|
|
|
|
8
|
(my $key = $caller) =~ s/.*:://; |
77
|
1
|
|
|
|
|
3
|
$key = lcfirst $key; |
78
|
1
|
|
|
|
|
10
|
$key =~ s/([[:upper:]]+)/_\L$1/g; |
79
|
1
|
|
|
|
|
4
|
_new_meta( $caller, $key ); |
80
|
|
|
|
|
|
|
} |
81
|
33
|
|
|
|
|
65
|
return $meta_for{ $caller }; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub _meth { |
85
|
12
|
|
|
12
|
|
29
|
my $method = 'add_' . shift; |
86
|
12
|
|
|
|
|
36
|
my $meta = _meta_for( scalar caller ); |
87
|
12
|
|
|
|
|
28
|
unshift @_, $meta, 'name'; |
88
|
12
|
100
|
|
|
|
35
|
if (my $ref = ref $_[3]) { |
89
|
8
|
100
|
|
|
|
22
|
if ($ref eq 'CODE') { |
90
|
4
|
|
|
|
|
13
|
splice @_, 3, 0, 'code'; |
91
|
|
|
|
|
|
|
} else { |
92
|
4
|
50
|
|
|
|
17
|
splice @_, 3, 1, %{ $_[3] } if $ref eq 'HASH'; |
|
4
|
|
|
|
|
14
|
|
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
12
|
|
|
|
|
21
|
goto &{ $meta->can($method) }; |
|
12
|
|
|
|
|
71
|
|
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub _unimport { |
99
|
26
|
|
|
26
|
|
48
|
my $caller = shift; |
100
|
26
|
|
|
|
|
75
|
for my $fn (qw(class meta ctor has method build)) { |
101
|
2
|
|
|
2
|
|
17
|
no strict 'refs'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
563
|
|
102
|
156
|
|
|
|
|
331
|
my $name = "$caller\::$fn"; |
103
|
|
|
|
|
|
|
# Copy the current glob contents, excluding CODE. |
104
|
156
|
|
|
|
|
200
|
my %things = map { $_ => *{$name}{$_} } |
|
156
|
|
|
|
|
439
|
|
105
|
156
|
|
|
|
|
233
|
grep { defined *{$name}{$_} } |
|
780
|
|
|
|
|
987
|
|
|
780
|
|
|
|
|
1905
|
|
106
|
|
|
|
|
|
|
qw(SCALAR ARRAY HASH IO FORMAT); |
107
|
|
|
|
|
|
|
# Undefine the glob and reinstall the contents. |
108
|
156
|
|
|
|
|
232
|
undef *{$name}; |
|
156
|
|
|
|
|
380
|
|
109
|
156
|
|
|
|
|
340
|
*{$name} = $things{$_} for keys %things; |
|
156
|
|
|
|
|
450
|
|
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _export { |
114
|
8
|
|
|
8
|
|
18
|
my ($export, $pkg, $args) = @_; |
115
|
8
|
|
|
|
|
19
|
my @args = map { $_ => $args->{$_} } grep { exists $args->{$_} } |
|
8
|
|
|
|
|
23
|
|
|
56
|
|
|
|
|
115
|
|
116
|
|
|
|
|
|
|
Class::Meta::INHERITABLE, 'meta_class'; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
my $meta = !@args ? \&meta : sub { |
119
|
4
|
|
|
4
|
|
3362
|
splice @_, 1, 0, @args; |
120
|
4
|
|
|
|
|
14
|
goto &Class::Meta::Express::meta; |
121
|
8
|
100
|
|
|
|
30
|
}; |
122
|
|
|
|
|
|
|
|
123
|
8
|
100
|
|
|
|
25
|
$export = 0 unless ref $export eq 'CODE'; |
124
|
|
|
|
|
|
|
|
125
|
2
|
|
|
2
|
|
14
|
no strict 'refs'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
137
|
|
126
|
8
|
|
|
|
|
47
|
*{"$pkg\::import"} = sub { |
127
|
8
|
|
|
8
|
|
3133
|
my $caller = caller; |
128
|
2
|
|
|
2
|
|
13
|
no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
317
|
|
129
|
8
|
50
|
|
|
|
14
|
unless (defined &{"$caller\::meta"}) { |
|
8
|
|
|
|
|
72
|
|
130
|
8
|
|
|
|
|
15
|
*{"$caller\::meta"} = $meta; |
|
8
|
|
|
|
|
32
|
|
131
|
40
|
|
|
|
|
156
|
*{"$caller\::$_"} = \&{__PACKAGE__ . "::$_"} |
|
40
|
|
|
|
|
112
|
|
132
|
8
|
|
|
|
|
19
|
for qw(class ctor has method build); |
133
|
|
|
|
|
|
|
} |
134
|
8
|
100
|
|
|
|
27
|
goto $export if $export; |
135
|
4
|
|
|
|
|
438
|
return shift; |
136
|
8
|
|
|
|
|
27
|
}; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
1; |
140
|
|
|
|
|
|
|
__END__ |