line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package WWW::Google::AutoSuggest::Obj; |
2
|
2
|
|
|
2
|
|
14
|
use strict; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
87
|
|
3
|
2
|
|
|
2
|
|
11
|
use warnings; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
60
|
|
4
|
2
|
|
|
2
|
|
2155
|
use utf8; |
|
2
|
|
|
|
|
22
|
|
|
2
|
|
|
|
|
11
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
#use feature (); |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $feature = eval { |
9
|
|
|
|
|
|
|
require feature; |
10
|
|
|
|
|
|
|
feature->import(); |
11
|
|
|
|
|
|
|
1; |
12
|
|
|
|
|
|
|
}; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# Only Perl 5.14+ requires it on demand |
16
|
2
|
|
|
2
|
|
2365
|
use IO::Handle (); |
|
2
|
|
|
|
|
17668
|
|
|
2
|
|
|
|
|
380
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Protect subclasses using AUTOLOAD |
19
|
0
|
|
|
0
|
|
0
|
sub DESTROY { } |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub import { |
22
|
4
|
|
|
4
|
|
37
|
my $class = shift; |
23
|
4
|
100
|
|
|
|
4286
|
return unless my $flag = shift; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# Base |
26
|
2
|
50
|
0
|
|
|
9
|
if ( $flag eq '-base' ) { $flag = $class } |
|
2
|
0
|
|
|
|
6
|
|
|
|
0
|
|
|
|
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# Strict |
29
|
0
|
|
|
|
|
0
|
elsif ( $flag eq '-strict' ) { $flag = undef } |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# Module |
32
|
|
|
|
|
|
|
elsif ( ( my $file = $flag ) && !$flag->can('new') ) { |
33
|
0
|
|
|
|
|
0
|
$file =~ s!::|'!/!g; |
34
|
0
|
|
|
|
|
0
|
require "$file.pm"; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# ISA |
38
|
2
|
50
|
|
|
|
8
|
if ($flag) { |
39
|
2
|
|
|
|
|
16
|
my $caller = caller; |
40
|
2
|
|
|
2
|
|
19
|
no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
1439
|
|
41
|
2
|
|
|
|
|
4
|
push @{"${caller}::ISA"}, $flag; |
|
2
|
|
|
|
|
30
|
|
42
|
2
|
|
|
14
|
|
10
|
*{"${caller}::has"} = sub { attr( $caller, @_ ) }; |
|
2
|
|
|
|
|
18
|
|
|
14
|
|
|
|
|
41
|
|
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# Mojo modules are strict! |
46
|
2
|
|
|
|
|
67
|
$_->import for qw(strict warnings utf8); |
47
|
2
|
50
|
|
|
|
74
|
if ($feature) { |
48
|
0
|
|
|
|
|
0
|
feature->import(':5.10'); |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub attr { |
53
|
14
|
|
|
14
|
1
|
26
|
my ( $self, $attrs, $default ) = @_; |
54
|
14
|
50
|
33
|
|
|
118
|
return unless ( my $class = ref $self || $self ) && $attrs; |
|
|
|
33
|
|
|
|
|
55
|
|
|
|
|
|
|
|
56
|
14
|
50
|
33
|
|
|
77
|
die 'Default has to be a code reference or constant value' |
57
|
|
|
|
|
|
|
if ref $default && ref $default ne 'CODE'; |
58
|
|
|
|
|
|
|
|
59
|
14
|
50
|
|
|
|
20
|
for my $attr ( @{ ref $attrs eq 'ARRAY' ? $attrs : [$attrs] } ) { |
|
14
|
|
|
|
|
129
|
|
60
|
14
|
50
|
|
|
|
73
|
die qq{Attribute "$attr" invalid} |
61
|
|
|
|
|
|
|
unless $attr =~ /^[a-zA-Z_]\w*$/; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# Header (check arguments) |
64
|
14
|
|
|
|
|
37
|
my $code = "package $class;\nsub $attr {\n if (\@_ == 1) {\n"; |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# No default value (return value) |
67
|
14
|
50
|
|
|
|
34
|
unless ( defined $default ) { $code .= " return \$_[0]{'$attr'};" } |
|
0
|
|
|
|
|
0
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# Default value |
70
|
|
|
|
|
|
|
else { |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# Return value |
73
|
14
|
|
|
|
|
31
|
$code |
74
|
|
|
|
|
|
|
.= " return \$_[0]{'$attr'} if exists \$_[0]{'$attr'};\n"; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# Return default value |
77
|
14
|
|
|
|
|
26
|
$code .= " return \$_[0]{'$attr'} = "; |
78
|
14
|
50
|
|
|
|
37
|
$code .= |
79
|
|
|
|
|
|
|
ref $default eq 'CODE' |
80
|
|
|
|
|
|
|
? '$default->($_[0]);' |
81
|
|
|
|
|
|
|
: '$default;'; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# Store value |
85
|
14
|
|
|
|
|
25
|
$code .= "\n }\n \$_[0]{'$attr'} = \$_[1];\n"; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# Footer (return invocant) |
88
|
14
|
|
|
|
|
21
|
$code .= " \$_[0];\n}"; |
89
|
|
|
|
|
|
|
|
90
|
14
|
50
|
|
|
|
39
|
warn "-- Attribute $attr in $class\n$code\n\n" |
91
|
|
|
|
|
|
|
if $ENV{AUTOSUGGEST_OBJ_DEBUG}; |
92
|
14
|
50
|
|
0
|
0
|
2392
|
die "WWW::Google::AutoSuggest::Obj error: $@" unless eval "$code;1"; |
|
0
|
0
|
|
0
|
0
|
|
|
|
0
|
0
|
|
0
|
1
|
|
|
|
0
|
0
|
|
0
|
1
|
|
|
|
0
|
0
|
|
0
|
1
|
|
|
|
0
|
0
|
|
0
|
1
|
|
|
|
0
|
0
|
|
0
|
0
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub new { |
97
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
98
|
0
|
0
|
0
|
|
|
|
bless @_ ? @_ > 1 ? {@_} : { %{ $_[0] } } : {}, ref $class || $class; |
|
0
|
0
|
|
|
|
|
|
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub tap { |
102
|
0
|
|
|
0
|
1
|
|
my ( $self, $cb ) = @_; |
103
|
0
|
|
|
|
|
|
$_->$cb for $self; |
104
|
0
|
|
|
|
|
|
return $self; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
1; |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
=encoding utf8 |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=head1 NAME |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
WWW::Google::AutoSuggest::Obj - Minimal base class for WWW::Google::AutoSuggest |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=head1 SYNOPSIS |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
package Cat; |
118
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj -base; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
has name => 'Nyan'; |
121
|
|
|
|
|
|
|
has [qw(birds mice)] => 2; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
package Tiger; |
124
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj 'Cat'; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
has friend => sub { Cat->new }; |
127
|
|
|
|
|
|
|
has stripes => 42; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
package main; |
130
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj -strict; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
my $mew = Cat->new(name => 'Longcat'); |
133
|
|
|
|
|
|
|
say $mew->mice; |
134
|
|
|
|
|
|
|
say $mew->mice(3)->birds(4)->mice; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
my $rawr = Tiger->new(stripes => 23, mice => 0); |
137
|
|
|
|
|
|
|
say $rawr->tap(sub { $_->friend->name('Tacgnol') })->mice; |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head1 DESCRIPTION |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
L is a simple base class for L, a fork of L. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# Automatically enables "strict", "warnings", "utf8" and Perl 5.10 features |
144
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj -strict; |
145
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj -base; |
146
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj 'SomeBaseClass'; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
All three forms save a lot of typing. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# use WWW::Google::AutoSuggest::Obj -strict; |
151
|
|
|
|
|
|
|
use strict; |
152
|
|
|
|
|
|
|
use warnings; |
153
|
|
|
|
|
|
|
use utf8; |
154
|
|
|
|
|
|
|
use feature ':5.10'; |
155
|
|
|
|
|
|
|
use IO::Handle (); |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# use WWW::Google::AutoSuggest::Obj -base; |
158
|
|
|
|
|
|
|
use strict; |
159
|
|
|
|
|
|
|
use warnings; |
160
|
|
|
|
|
|
|
use utf8; |
161
|
|
|
|
|
|
|
use feature ':5.10'; |
162
|
|
|
|
|
|
|
use IO::Handle (); |
163
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj; |
164
|
|
|
|
|
|
|
push @ISA, 'WWW::Google::AutoSuggest::Obj'; |
165
|
|
|
|
|
|
|
sub has { WWW::Google::AutoSuggest::Obj::attr(__PACKAGE__, @_) } |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# use WWW::Google::AutoSuggest::Obj 'SomeBaseClass'; |
168
|
|
|
|
|
|
|
use strict; |
169
|
|
|
|
|
|
|
use warnings; |
170
|
|
|
|
|
|
|
use utf8; |
171
|
|
|
|
|
|
|
use feature ':5.10'; |
172
|
|
|
|
|
|
|
use IO::Handle (); |
173
|
|
|
|
|
|
|
require SomeBaseClass; |
174
|
|
|
|
|
|
|
push @ISA, 'SomeBaseClass'; |
175
|
|
|
|
|
|
|
use WWW::Google::AutoSuggest::Obj; |
176
|
|
|
|
|
|
|
sub has { WWW::Google::AutoSuggest::Obj::attr(__PACKAGE__, @_) } |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=head1 FUNCTIONS |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
L implements the following functions like L, which can be imported with |
181
|
|
|
|
|
|
|
the C<-base> flag or by setting a base class. |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=head2 has |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
has 'name'; |
186
|
|
|
|
|
|
|
has [qw(name1 name2 name3)]; |
187
|
|
|
|
|
|
|
has name => 'foo'; |
188
|
|
|
|
|
|
|
has name => sub {...}; |
189
|
|
|
|
|
|
|
has [qw(name1 name2 name3)] => 'foo'; |
190
|
|
|
|
|
|
|
has [qw(name1 name2 name3)] => sub {...}; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
Create attributes for hash-based objects, just like the L"attr"> method. |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
=head1 METHODS |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
L implements the following methods. |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=head2 attr |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
$object->attr('name'); |
201
|
|
|
|
|
|
|
BaseSubClass->attr('name'); |
202
|
|
|
|
|
|
|
BaseSubClass->attr([qw(name1 name2 name3)]); |
203
|
|
|
|
|
|
|
BaseSubClass->attr(name => 'foo'); |
204
|
|
|
|
|
|
|
BaseSubClass->attr(name => sub {...}); |
205
|
|
|
|
|
|
|
BaseSubClass->attr([qw(name1 name2 name3)] => 'foo'); |
206
|
|
|
|
|
|
|
BaseSubClass->attr([qw(name1 name2 name3)] => sub {...}); |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Create attribute accessor for hash-based objects, an array reference can be |
209
|
|
|
|
|
|
|
used to create more than one at a time. Pass an optional second argument to |
210
|
|
|
|
|
|
|
set a default value, it should be a constant or a callback. The callback will |
211
|
|
|
|
|
|
|
be executed at accessor read time if there's no set value. Accessors can be |
212
|
|
|
|
|
|
|
chained, that means they return their invocant when they are called with an |
213
|
|
|
|
|
|
|
argument. |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=head2 new |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
my $object = BaseSubClass->new; |
218
|
|
|
|
|
|
|
my $object = BaseSubClass->new(name => 'value'); |
219
|
|
|
|
|
|
|
my $object = BaseSubClass->new({name => 'value'}); |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
This base class provides a basic constructor for hash-based objects. You can |
222
|
|
|
|
|
|
|
pass it either a hash or a hash reference with attribute values. |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=head2 tap |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
$object = $object->tap(sub {...}); |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
K combinator, tap into a method chain to perform operations on an object |
229
|
|
|
|
|
|
|
within the chain. The object will be the first argument passed to the callback |
230
|
|
|
|
|
|
|
and is also available as C<$_>. |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=head1 DEBUGGING |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
You can set the C environment variable to get some advanced |
235
|
|
|
|
|
|
|
diagnostics information printed to C. |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
AUTOSUGGEST_OBJ_DEBUG=1 |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
=head1 SEE ALSO |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
L, L. |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=cut |