Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Class/Base.pm |
Statements | Executed 7224 statements in 8.52ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
383 | 7 | 3 | 4.59ms | 57.7ms | new | Class::Base::
740 | 5 | 2 | 2.22ms | 2.22ms | error | Class::Base::
24 | 4 | 2 | 129µs | 129µs | debug | Class::Base::
1 | 1 | 1 | 13µs | 15µs | BEGIN@23 | Class::Base::
1 | 1 | 1 | 10µs | 17µs | BEGIN@231 | Class::Base::
1 | 1 | 1 | 7µs | 22µs | BEGIN@46 | Class::Base::
1 | 1 | 1 | 7µs | 14µs | BEGIN@256 | Class::Base::
1 | 1 | 1 | 6µs | 14µs | BEGIN@109 | Class::Base::
0 | 0 | 0 | 0s | 0s | clone | Class::Base::
0 | 0 | 0 | 0s | 0s | debugging | Class::Base::
0 | 0 | 0 | 0s | 0s | id | Class::Base::
0 | 0 | 0 | 0s | 0s | init | Class::Base::
0 | 0 | 0 | 0s | 0s | params | Class::Base::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | #============================================================= -*-perl-*- | ||||
2 | # | ||||
3 | # Class::Base | ||||
4 | # | ||||
5 | # DESCRIPTION | ||||
6 | # Module implementing a common base class from which other modules | ||||
7 | # can be derived. | ||||
8 | # | ||||
9 | # AUTHOR | ||||
10 | # Andy Wardley <abw@kfs.org> | ||||
11 | # | ||||
12 | # COPYRIGHT | ||||
13 | # Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. | ||||
14 | # | ||||
15 | # This module is free software; you can redistribute it and/or | ||||
16 | # modify it under the same terms as Perl itself. | ||||
17 | # | ||||
18 | # | ||||
19 | #======================================================================== | ||||
20 | |||||
21 | package Class::Base; | ||||
22 | |||||
23 | 3 | 76µs | 2 | 18µs | # spent 15µs (13+2) within Class::Base::BEGIN@23 which was called:
# once (13µs+2µs) by base::import at line 23 # spent 15µs making 1 call to Class::Base::BEGIN@23
# spent 2µs making 1 call to strict::import |
24 | |||||
25 | 1 | 500ns | our $VERSION = '0.04'; | ||
26 | |||||
27 | |||||
28 | #------------------------------------------------------------------------ | ||||
29 | # new(@config) | ||||
30 | # new(\%config) | ||||
31 | # | ||||
32 | # General purpose constructor method which expects a hash reference of | ||||
33 | # configuration parameters, or a list of name => value pairs which are | ||||
34 | # folded into a hash. Blesses a hash into an object and calls its | ||||
35 | # init() method, passing the parameter hash reference. Returns a new | ||||
36 | # object derived from Class::Base, or undef on error. | ||||
37 | #------------------------------------------------------------------------ | ||||
38 | |||||
39 | # spent 57.7ms (4.59+53.1) within Class::Base::new which was called 383 times, avg 151µs/call:
# 240 times (2.79ms+35.1ms) by SQL::Translator::Schema::Table::add_field at line 333 of SQL/Translator/Schema/Table.pm, avg 158µs/call
# 67 times (693µs+7.58ms) by SQL::Translator::Schema::Table::add_constraint at line 126 of SQL/Translator/Schema/Table.pm, avg 123µs/call
# 35 times (595µs+1.16ms) by SQL::Translator::Schema::Table::new at line 82 of SQL/Translator/Schema/Table.pm, avg 50µs/call
# 31 times (334µs+2.09ms) by SQL::Translator::Schema::Table::add_index at line 249 of SQL/Translator/Schema/Table.pm, avg 78µs/call
# 4 times (99µs+6.89ms) by DBIx::Class::Storage::DBI::deployment_statements at line 2725 of DBIx/Class/Storage/DBI.pm, avg 1.75ms/call
# 4 times (56µs+132µs) by SQL::Translator::Schema::new at line 65 of SQL/Translator/Schema.pm, avg 47µs/call
# 2 times (29µs+186µs) by SQL::Translator::Schema::add_view at line 420 of SQL/Translator/Schema.pm, avg 107µs/call | ||||
40 | 1915 | 4.09ms | my $class = shift; | ||
41 | |||||
42 | # allow hash ref as first argument, otherwise fold args into hash | ||||
43 | 383 | 210µs | my $config = defined $_[0] && UNIVERSAL::isa($_[0], 'HASH') # spent 210µs making 383 calls to UNIVERSAL::isa, avg 549ns/call | ||
44 | ? shift : { @_ }; | ||||
45 | |||||
46 | 3 | 167µs | 2 | 36µs | # spent 22µs (7+15) within Class::Base::BEGIN@46 which was called:
# once (7µs+15µs) by base::import at line 46 # spent 22µs making 1 call to Class::Base::BEGIN@46
# spent 15µs making 1 call to strict::unimport |
47 | my $debug = defined $config->{ debug } | ||||
48 | ? $config->{ debug } | ||||
49 | : defined $config->{ DEBUG } | ||||
50 | ? $config->{ DEBUG } | ||||
51 | : ( ${"$class\::DEBUG"} || 0 ); | ||||
52 | |||||
53 | my $self = bless { | ||||
54 | _ID => $config->{ id } || $config->{ ID } || $class, | ||||
55 | _DEBUG => $debug, | ||||
56 | _ERROR => '', | ||||
57 | }, $class; | ||||
58 | |||||
59 | 1 | 518µs | 658 | 52.9ms | return $self->init($config) # spent 37.2ms making 312 calls to SQL::Translator::Schema::Object::init, avg 119µs/call
# spent 7.55ms making 67 calls to SQL::Translator::Schema::Constraint::init, avg 113µs/call
# spent 6.88ms making 4 calls to SQL::Translator::init, avg 1.72ms/call
# spent 1.06ms making 240 calls to SQL::Translator::Schema::Field::__ANON__[SQL/Translator/Schema/Field.pm:58], avg 4µs/call
# spent 186µs making 35 calls to SQL::Translator::Schema::Table::__ANON__[SQL/Translator/Schema/Table.pm:59], avg 5µs/call |
60 | || $class->error($self->error()); | ||||
61 | } | ||||
62 | |||||
63 | |||||
64 | #------------------------------------------------------------------------ | ||||
65 | # init() | ||||
66 | # | ||||
67 | # Initialisation method called by the new() constructor and passing a | ||||
68 | # reference to a hash array containing any configuration items specified | ||||
69 | # as constructor arguments. Should return $self on success or undef on | ||||
70 | # error, via a call to the error() method to set the error message. | ||||
71 | #------------------------------------------------------------------------ | ||||
72 | |||||
73 | sub init { | ||||
74 | my ($self, $config) = @_; | ||||
75 | return $self; | ||||
76 | } | ||||
77 | |||||
78 | |||||
79 | #------------------------------------------------------------------------ | ||||
80 | # clone() | ||||
81 | # | ||||
82 | # Method to perform a simple clone of the current object hash and return | ||||
83 | # a new object. | ||||
84 | #------------------------------------------------------------------------ | ||||
85 | |||||
86 | sub clone { | ||||
87 | my $self = shift; | ||||
88 | bless { %$self }, ref($self); | ||||
89 | } | ||||
90 | |||||
91 | |||||
92 | #------------------------------------------------------------------------ | ||||
93 | # error() | ||||
94 | # error($msg, ...) | ||||
95 | # | ||||
96 | # May be called as a class or object method to set or retrieve the | ||||
97 | # package variable $ERROR (class method) or internal member | ||||
98 | # $self->{ _ERROR } (object method). The presence of parameters indicates | ||||
99 | # that the error value should be set. Undef is then returned. In the | ||||
100 | # abscence of parameters, the current error value is returned. | ||||
101 | #------------------------------------------------------------------------ | ||||
102 | |||||
103 | # spent 2.22ms within Class::Base::error which was called 740 times, avg 3µs/call:
# 458 times (1.28ms+0s) by SQL::Translator::Schema::Table::get_constraints at line 460 of SQL/Translator/Schema/Table.pm, avg 3µs/call
# 240 times (760µs+0s) by SQL::Translator::Schema::Table::get_field at line 514 of SQL/Translator/Schema/Table.pm, avg 3µs/call
# 35 times (152µs+0s) by SQL::Translator::Schema::Table::get_indices at line 486 of SQL/Translator/Schema/Table.pm, avg 4µs/call
# 4 times (15µs+0s) by SQL::Translator::Schema::get_triggers at line 660 of SQL/Translator/Schema.pm, avg 4µs/call
# 3 times (13µs+0s) by SQL::Translator::Schema::get_views at line 708 of SQL/Translator/Schema.pm, avg 4µs/call | ||||
104 | 2960 | 661µs | my $self = shift; | ||
105 | my $errvar; | ||||
106 | |||||
107 | { | ||||
108 | # get a reference to the object or package variable we're munging | ||||
109 | 3 | 326µs | 2 | 22µs | # spent 14µs (6+8) within Class::Base::BEGIN@109 which was called:
# once (6µs+8µs) by base::import at line 109 # spent 14µs making 1 call to Class::Base::BEGIN@109
# spent 8µs making 1 call to strict::unimport |
110 | 740 | 465µs | $errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"}; | ||
111 | } | ||||
112 | 1480 | 1.75ms | if (@_) { | ||
113 | # don't join if first arg is an object (may force stringification) | ||||
114 | $$errvar = ref($_[0]) ? shift : join('', @_); | ||||
115 | return undef; | ||||
116 | } | ||||
117 | else { | ||||
118 | return $$errvar; | ||||
119 | } | ||||
120 | } | ||||
121 | |||||
- - | |||||
124 | #------------------------------------------------------------------------ | ||||
125 | # id($new_id) | ||||
126 | # | ||||
127 | # Method to get/set the internal _ID field which is used to identify | ||||
128 | # the object for the purposes of debugging, etc. | ||||
129 | #------------------------------------------------------------------------ | ||||
130 | |||||
131 | sub id { | ||||
132 | my $self = shift; | ||||
133 | |||||
134 | # set _ID with $obj->id('foo') | ||||
135 | return ($self->{ _ID } = shift) if ref $self && @_; | ||||
136 | |||||
137 | # otherwise return id as $self->{ _ID } or class name | ||||
138 | my $id = $self->{ _ID } if ref $self; | ||||
139 | $id ||= ref($self) || $self; | ||||
140 | |||||
141 | return $id; | ||||
142 | } | ||||
143 | |||||
144 | |||||
145 | #------------------------------------------------------------------------ | ||||
146 | # params($vals, @keys) | ||||
147 | # params($vals, \@keys) | ||||
148 | # params($vals, \%keys) | ||||
149 | # | ||||
150 | # Utility method to examine the $config hash for any keys specified in | ||||
151 | # @keys and copy the values into $self. Keys should be specified as a | ||||
152 | # list or reference to a list of UPPER CASE names. The method looks | ||||
153 | # for either the name in either UPPER or lower case in the $config | ||||
154 | # hash and copies the value, if defined, into $self. The keys can | ||||
155 | # also be specified as a reference to a hash containing default values | ||||
156 | # or references to handler subroutines which will be called, passing | ||||
157 | # ($self, $config, $UPPER_KEY_NAME) as arguments. | ||||
158 | #------------------------------------------------------------------------ | ||||
159 | |||||
160 | sub params { | ||||
161 | my $self = shift; | ||||
162 | my $vals = shift; | ||||
163 | my ($keys, @names); | ||||
164 | my ($key, $lckey, $default, $value, @values); | ||||
165 | |||||
166 | |||||
167 | if (@_) { | ||||
168 | if (ref $_[0] eq 'ARRAY') { | ||||
169 | $keys = shift; | ||||
170 | @names = @$keys; | ||||
171 | $keys = { map { ($_, undef) } @names }; | ||||
172 | } | ||||
173 | elsif (ref $_[0] eq 'HASH') { | ||||
174 | $keys = shift; | ||||
175 | @names = keys %$keys; | ||||
176 | } | ||||
177 | else { | ||||
178 | @names = @_; | ||||
179 | $keys = { map { ($_, undef) } @names }; | ||||
180 | } | ||||
181 | } | ||||
182 | else { | ||||
183 | $keys = { }; | ||||
184 | } | ||||
185 | |||||
186 | foreach $key (@names) { | ||||
187 | $lckey = lc $key; | ||||
188 | |||||
189 | # look for value provided in $vals hash | ||||
190 | defined($value = $vals->{ $key }) | ||||
191 | || ($value = $vals->{ $lckey }); | ||||
192 | |||||
193 | # look for default which may be a code handler | ||||
194 | if (defined ($default = $keys->{ $key }) | ||||
195 | && ref $default eq 'CODE') { | ||||
196 | eval { | ||||
197 | $value = &$default($self, $key, $value); | ||||
198 | }; | ||||
199 | return $self->error($@) if $@; | ||||
200 | } | ||||
201 | else { | ||||
202 | $value = $default unless defined $value; | ||||
203 | $self->{ $key } = $value if defined $value; | ||||
204 | } | ||||
205 | push(@values, $value); | ||||
206 | delete @$vals{ $key, lc $key }; | ||||
207 | } | ||||
208 | return wantarray ? @values : \@values; | ||||
209 | } | ||||
210 | |||||
211 | |||||
212 | #------------------------------------------------------------------------ | ||||
213 | # debug(@args) | ||||
214 | # | ||||
215 | # Debug method which prints all arguments passed to STDERR if and only if | ||||
216 | # the appropriate DEBUG flag(s) are set. If called as an object method | ||||
217 | # where the object has a _DEBUG member defined then the value of that | ||||
218 | # flag is used. Otherwise, the $DEBUG package variable in the caller's | ||||
219 | # class is used as the flag to enable/disable debugging. | ||||
220 | #------------------------------------------------------------------------ | ||||
221 | |||||
222 | # spent 129µs within Class::Base::debug which was called 24 times, avg 5µs/call:
# 8 times (36µs+0s) by SQL::Translator::load at line 765 of SQL/Translator.pm, avg 4µs/call
# 8 times (23µs+0s) by SQL::Translator::_tool at line 670 of SQL/Translator.pm, avg 3µs/call
# 4 times (55µs+0s) by SQL::Translator::translate at line 516 of SQL/Translator.pm, avg 14µs/call
# 4 times (15µs+0s) by SQL::Translator::Producer::SQLite::produce at line 55 of SQL/Translator/Producer/SQLite.pm, avg 4µs/call | ||||
223 | 96 | 129µs | my $self = shift; | ||
224 | my ($flag); | ||||
225 | |||||
226 | 16 | 14µs | if (ref $self && defined $self->{ _DEBUG }) { | ||
227 | $flag = $self->{ _DEBUG }; | ||||
228 | } | ||||
229 | else { | ||||
230 | # go looking for package variable | ||||
231 | 3 | 77µs | 2 | 24µs | # spent 17µs (10+7) within Class::Base::BEGIN@231 which was called:
# once (10µs+7µs) by base::import at line 231 # spent 17µs making 1 call to Class::Base::BEGIN@231
# spent 8µs making 1 call to strict::unimport |
232 | $self = ref $self || $self; | ||||
233 | $flag = ${"$self\::DEBUG"}; | ||||
234 | } | ||||
235 | |||||
236 | return unless $flag; | ||||
237 | |||||
238 | print STDERR '[', $self->id, '] ', @_; | ||||
239 | } | ||||
240 | |||||
241 | |||||
242 | #------------------------------------------------------------------------ | ||||
243 | # debugging($flag) | ||||
244 | # | ||||
245 | # Method to turn debugging on/off (when called with an argument) or to | ||||
246 | # retrieve the current debugging status (when called without). Changes | ||||
247 | # to the debugging status are propagated to the $DEBUG variable in the | ||||
248 | # caller's package. | ||||
249 | #------------------------------------------------------------------------ | ||||
250 | |||||
251 | sub debugging { | ||||
252 | my $self = shift; | ||||
253 | my $class = ref $self; | ||||
254 | my $flag; | ||||
255 | |||||
256 | 3 | 252µs | 2 | 22µs | # spent 14µs (7+7) within Class::Base::BEGIN@256 which was called:
# once (7µs+7µs) by base::import at line 256 # spent 14µs making 1 call to Class::Base::BEGIN@256
# spent 7µs making 1 call to strict::unimport |
257 | |||||
258 | my $dbgvar = ref $self ? \$self->{ _DEBUG } : \${"$self\::DEBUG"}; | ||||
259 | |||||
260 | return @_ ? ($$dbgvar = shift) | ||||
261 | : $$dbgvar; | ||||
262 | |||||
263 | } | ||||
264 | |||||
265 | |||||
266 | 1 | 3µs | 1; | ||
267 | |||||
268 | |||||
269 | =head1 NAME | ||||
270 | |||||
271 | Class::Base - useful base class for deriving other modules | ||||
272 | |||||
273 | =head1 SYNOPSIS | ||||
274 | |||||
275 | package My::Funky::Module; | ||||
276 | use base qw( Class::Base ); | ||||
277 | |||||
278 | # custom initialiser method | ||||
279 | sub init { | ||||
280 | my ($self, $config) = @_; | ||||
281 | |||||
282 | # copy various params into $self | ||||
283 | $self->params($config, qw( FOO BAR BAZ )) | ||||
284 | || return undef; | ||||
285 | |||||
286 | # to indicate a failure | ||||
287 | return $self->error('bad constructor!') | ||||
288 | if $something_bad; | ||||
289 | |||||
290 | # or to indicate general happiness and well-being | ||||
291 | return $self; | ||||
292 | } | ||||
293 | |||||
294 | package main; | ||||
295 | |||||
296 | # new() constructor folds args into hash and calls init() | ||||
297 | my $object = My::Funky::Module->new( foo => 'bar', ... ) | ||||
298 | || die My::Funky::Module->error(); | ||||
299 | |||||
300 | # error() class/object method to get/set errors | ||||
301 | $object->error('something has gone wrong'); | ||||
302 | print $object->error(); | ||||
303 | |||||
304 | # debugging() method (de-)activates the debug() method | ||||
305 | $object->debugging(1); | ||||
306 | |||||
307 | # debug() prints to STDERR if debugging enabled | ||||
308 | $object->debug('The ', $animal, ' sat on the ', $place); | ||||
309 | |||||
310 | |||||
311 | =head1 DESCRIPTION | ||||
312 | |||||
313 | Please consider using L<Badger::Base> instead which is the successor of | ||||
314 | this module. | ||||
315 | |||||
316 | This module implements a simple base class from which other modules | ||||
317 | can be derived, thereby inheriting a number of useful methods such as | ||||
318 | C<new()>, C<init()>, C<params()>, C<clone()>, C<error()> and | ||||
319 | C<debug()>. | ||||
320 | |||||
321 | For a number of years, I found myself re-writing this module for | ||||
322 | practically every Perl project of any significant size. Or rather, I | ||||
323 | would copy the module from the last project and perform a global | ||||
324 | search and replace to change the names. Each time it got a little | ||||
325 | more polished and eventually, I decided to Do The Right Thing and | ||||
326 | release it as a module in it's own right. | ||||
327 | |||||
328 | It doesn't pretend to be an all-encompassing solution for every kind | ||||
329 | of object creation problem you might encounter. In fact, it only | ||||
330 | supports blessed hash references that are created using the popular, | ||||
331 | but by no means universal convention of calling C<new()> with a list | ||||
332 | or reference to a hash array of named parameters. Constructor failure | ||||
333 | is indicated by returning undef and setting the C<$ERROR> package | ||||
334 | variable in the module's class to contain a relevant message (which | ||||
335 | you can also fetch by calling C<error()> as a class method). | ||||
336 | |||||
337 | e.g. | ||||
338 | |||||
339 | my $object = My::Module->new( | ||||
340 | file => 'myfile.html', | ||||
341 | msg => 'Hello World' | ||||
342 | ) || die $My::Module::ERROR; | ||||
343 | |||||
344 | or: | ||||
345 | |||||
346 | my $object = My::Module->new({ | ||||
347 | file => 'myfile.html', | ||||
348 | msg => 'Hello World', | ||||
349 | }) || die My::Module->error(); | ||||
350 | |||||
351 | The C<new()> method handles the conversion of a list of arguments | ||||
352 | into a hash array and calls the C<init()> method to perform any | ||||
353 | initialisation. In many cases, it is therefore sufficient to define | ||||
354 | a module like so: | ||||
355 | |||||
356 | package My::Module; | ||||
357 | use Class::Base; | ||||
358 | use base qw( Class::Base ); | ||||
359 | |||||
360 | sub init { | ||||
361 | my ($self, $config) = @_; | ||||
362 | # copy some config items into $self | ||||
363 | $self->params($config, qw( FOO BAR )) || return undef; | ||||
364 | return $self; | ||||
365 | } | ||||
366 | |||||
367 | # ...plus other application-specific methods | ||||
368 | |||||
369 | 1; | ||||
370 | |||||
371 | Then you can go right ahead and use it like this: | ||||
372 | |||||
373 | use My::Module; | ||||
374 | |||||
375 | my $object = My::Module->new( FOO => 'the foo value', | ||||
376 | BAR => 'the bar value' ) | ||||
377 | || die $My::Module::ERROR; | ||||
378 | |||||
379 | Despite its limitations, Class::Base can be a surprisingly useful | ||||
380 | module to have lying around for those times where you just want to | ||||
381 | create a regular object based on a blessed hash reference and don't | ||||
382 | want to worry too much about duplicating the same old code to bless a | ||||
383 | hash, define configuration values, provide an error reporting | ||||
384 | mechanism, and so on. Simply derive your module from C<Class::Base> | ||||
385 | and leave it to worry about most of the detail. And don't forget, you | ||||
386 | can always redefine your own C<new()>, C<error()>, or other method, if | ||||
387 | you don't like the way the Class::Base version works. | ||||
388 | |||||
389 | =head2 Subclassing Class::Base | ||||
390 | |||||
391 | This module is what object-oriented afficionados would describe as an | ||||
392 | "abstract base class". That means that it's not designed to be used | ||||
393 | as a stand-alone module, rather as something from which you derive | ||||
394 | your own modules. Like this: | ||||
395 | |||||
396 | package My::Funky::Module | ||||
397 | use base qw( Class::Base ); | ||||
398 | |||||
399 | You can then use it like this: | ||||
400 | |||||
401 | use My::Funky::Module; | ||||
402 | |||||
403 | my $module = My::Funky::Module->new(); | ||||
404 | |||||
405 | =head2 Construction and Initialisation Methods | ||||
406 | |||||
407 | If you want to apply any per-object initialisation, then simply write | ||||
408 | an C<init()> method. This gets called by the C<new()> method which | ||||
409 | passes a reference to a hash reference of configuration options. | ||||
410 | |||||
411 | sub init { | ||||
412 | my ($self, $config) = @_; | ||||
413 | |||||
414 | ... | ||||
415 | |||||
416 | return $self; | ||||
417 | } | ||||
418 | |||||
419 | When you create new objects using the C<new()> method you can either | ||||
420 | pass a hash reference or list of named arguments. The C<new()> method | ||||
421 | does the right thing to fold named arguments into a hash reference for | ||||
422 | passing to the C<init()> method. Thus, the following are equivalent: | ||||
423 | |||||
424 | # hash reference | ||||
425 | my $module = My::Funky::Module->new({ | ||||
426 | foo => 'bar', | ||||
427 | wiz => 'waz', | ||||
428 | }); | ||||
429 | |||||
430 | # list of named arguments (no enclosing '{' ... '}') | ||||
431 | my $module = My::Funky::Module->new( | ||||
432 | foo => 'bar', | ||||
433 | wiz => 'waz' | ||||
434 | ); | ||||
435 | |||||
436 | Within the C<init()> method, you can either handle the configuration | ||||
437 | yourself: | ||||
438 | |||||
439 | sub init { | ||||
440 | my ($self, $config) = @_; | ||||
441 | |||||
442 | $self->{ file } = $config->{ file } | ||||
443 | || return $self->error('no file specified'); | ||||
444 | |||||
445 | return $self; | ||||
446 | } | ||||
447 | |||||
448 | or you can call the C<params()> method to do it for you: | ||||
449 | |||||
450 | sub init { | ||||
451 | my ($self, $config) = @_; | ||||
452 | |||||
453 | $self->params($config, 'file') | ||||
454 | || return $self->error('no file specified'); | ||||
455 | |||||
456 | return $self; | ||||
457 | } | ||||
458 | |||||
459 | =head2 Error Handling | ||||
460 | |||||
461 | The C<init()> method should return $self to indicate success or undef | ||||
462 | to indicate a failure. You can use the C<error()> method to report an | ||||
463 | error within the C<init()> method. The C<error()> method returns undef, | ||||
464 | so you can use it like this: | ||||
465 | |||||
466 | sub init { | ||||
467 | my ($self, $config) = @_; | ||||
468 | |||||
469 | # let's make 'foobar' a mandatory argument | ||||
470 | $self->{ foobar } = $config->{ foobar } | ||||
471 | || return $self->error("no foobar argument"); | ||||
472 | |||||
473 | return $self; | ||||
474 | } | ||||
475 | |||||
476 | When you create objects of this class via C<new()>, you should now | ||||
477 | check the return value. If undef is returned then the error message | ||||
478 | can be retrieved by calling C<error()> as a class method. | ||||
479 | |||||
480 | my $module = My::Funky::Module->new() | ||||
481 | || die My::Funky::Module->error(); | ||||
482 | |||||
483 | Alternately, you can inspect the C<$ERROR> package variable which will | ||||
484 | contain the same error message. | ||||
485 | |||||
486 | my $module = My::Funky::Module->new() | ||||
487 | || die $My::Funky::Module::ERROR; | ||||
488 | |||||
489 | Of course, being a conscientious Perl programmer, you will want to be | ||||
490 | sure that the C<$ERROR> package variable is correctly defined. | ||||
491 | |||||
492 | package My::Funky::Module | ||||
493 | use base qw( Class::Base ); | ||||
494 | |||||
495 | our $ERROR; | ||||
496 | |||||
497 | You can also call C<error()> as an object method. If you pass an | ||||
498 | argument then it will be used to set the internal error message for | ||||
499 | the object and return undef. Typically this is used within the module | ||||
500 | methods to report errors. | ||||
501 | |||||
502 | sub another_method { | ||||
503 | my $self = shift; | ||||
504 | |||||
505 | ... | ||||
506 | |||||
507 | # set the object error | ||||
508 | return $self->error('something bad happened'); | ||||
509 | } | ||||
510 | |||||
511 | If you don't pass an argument then the C<error()> method returns the | ||||
512 | current error value. Typically this is called from outside the object | ||||
513 | to determine its status. For example: | ||||
514 | |||||
515 | my $object = My::Funky::Module->new() | ||||
516 | || die My::Funky::Module->error(); | ||||
517 | |||||
518 | $object->another_method() | ||||
519 | || die $object->error(); | ||||
520 | |||||
521 | =head2 Debugging Methods | ||||
522 | |||||
523 | The module implements two methods to assist in writing debugging code: | ||||
524 | debug() and debugging(). Debugging can be enabled on a per-object or | ||||
525 | per-class basis, or as a combination of the two. | ||||
526 | |||||
527 | When creating an object, you can set the C<DEBUG> flag (or lower case | ||||
528 | C<debug> if you prefer) to enable or disable debugging for that one | ||||
529 | object. | ||||
530 | |||||
531 | my $object = My::Funky::Module->new( debug => 1 ) | ||||
532 | || die My::Funky::Module->error(); | ||||
533 | |||||
534 | my $object = My::Funky::Module->new( DEBUG => 1 ) | ||||
535 | || die My::Funky::Module->error(); | ||||
536 | |||||
537 | If you don't explicitly specify a debugging flag then it assumes the | ||||
538 | value of the C<$DEBUG> package variable in your derived class or 0 if | ||||
539 | that isn't defined. | ||||
540 | |||||
541 | You can also switch debugging on or off via the C<debugging()> method. | ||||
542 | |||||
543 | $object->debugging(0); # debug off | ||||
544 | $object->debugging(1); # debug on | ||||
545 | |||||
546 | The C<debug()> method examines the internal debugging flag (the | ||||
547 | C<_DEBUG> member within the C<$self> hash) and if it finds it set to | ||||
548 | any true value then it prints to STDERR all the arguments passed to | ||||
549 | it. The output is prefixed by a tag containing the class name of the | ||||
550 | object in square brackets (but see the C<id()> method below for | ||||
551 | details on how to change that value). | ||||
552 | |||||
553 | For example, calling the method as: | ||||
554 | |||||
555 | $object->debug('foo', 'bar'); | ||||
556 | |||||
557 | prints the following output to STDERR: | ||||
558 | |||||
559 | [My::Funky::Module] foobar | ||||
560 | |||||
561 | When called as class methods, C<debug()> and C<debugging()> instead | ||||
562 | use the C<$DEBUG> package variable in the derived class as a flag to | ||||
563 | control debugging. This variable also defines the default C<DEBUG> | ||||
564 | flag for any objects subsequently created via the new() method. | ||||
565 | |||||
566 | package My::Funky::Module | ||||
567 | use base qw( Class::Base ); | ||||
568 | |||||
569 | our $ERROR; | ||||
570 | our $DEBUG = 0 unless defined $DEBUG; | ||||
571 | |||||
572 | # some time later, in a module far, far away | ||||
573 | package main; | ||||
574 | |||||
575 | # debugging off (by default) | ||||
576 | my $object1 = My::Funky::Module->new(); | ||||
577 | |||||
578 | # turn debugging on for My::Funky::Module objects | ||||
579 | $My::Funky::Module::DEBUG = 1; | ||||
580 | |||||
581 | # alternate syntax | ||||
582 | My::Funky::Module->debugging(1); | ||||
583 | |||||
584 | # debugging on (implicitly from $DEBUG package var) | ||||
585 | my $object2 = My::Funky::Module->new(); | ||||
586 | |||||
587 | # debugging off (explicit override) | ||||
588 | my $object3 = My::Funky::Module->new(debug => 0); | ||||
589 | |||||
590 | If you call C<debugging()> without any arguments then it returns the | ||||
591 | value of the internal object flag or the package variable accordingly. | ||||
592 | |||||
593 | print "debugging is turned ", $object->debugging() ? 'on' : 'off'; | ||||
594 | |||||
595 | =head1 METHODS | ||||
596 | |||||
597 | =head2 new() | ||||
598 | |||||
599 | Class constructor method which expects a reference to a hash array of parameters | ||||
600 | or a list of C<name =E<gt> value> pairs which are automagically folded into | ||||
601 | a hash reference. The method blesses a hash reference and then calls the | ||||
602 | C<init()> method, passing the reference to the hash array of configuration | ||||
603 | parameters. | ||||
604 | |||||
605 | Returns a reference to an object on success or undef on error. In the latter | ||||
606 | case, the C<error()> method can be called as a class method, or the C<$ERROR> | ||||
607 | package variable (in the derived class' package) can be inspected to return an | ||||
608 | appropriate error message. | ||||
609 | |||||
610 | my $object = My::Class->new( foo => 'bar' ) # params list | ||||
611 | || die $My::Class::$ERROR; # package var | ||||
612 | |||||
613 | or | ||||
614 | |||||
615 | my $object = My::Class->new({ foo => 'bar' }) # params hashref | ||||
616 | || die My::Class->error; # class method | ||||
617 | |||||
618 | |||||
619 | =head2 init(\%config) | ||||
620 | |||||
621 | Object initialiser method which is called by the C<new()> method, passing | ||||
622 | a reference to a hash array of configuration parameters. The method may | ||||
623 | be derived in a subclass to perform any initialisation required. It should | ||||
624 | return C<$self> on success, or C<undef> on error, via a call to the C<error()> | ||||
625 | method. | ||||
626 | |||||
627 | package My::Module; | ||||
628 | use base qw( Class::Base ); | ||||
629 | |||||
630 | sub init { | ||||
631 | my ($self, $config) = @_; | ||||
632 | |||||
633 | # let's make 'foobar' a mandatory argument | ||||
634 | $self->{ foobar } = $config->{ foobar } | ||||
635 | || return $self->error("no foobar argument"); | ||||
636 | |||||
637 | return $self; | ||||
638 | } | ||||
639 | |||||
640 | =head2 params($config, @keys) | ||||
641 | |||||
642 | The C<params()> method accept a reference to a hash array as the | ||||
643 | first argument containing configuration values such as those passed | ||||
644 | to the C<init()> method. The second argument can be a reference to | ||||
645 | a list of parameter names or a reference to a hash array mapping | ||||
646 | parameter names to default values. If the second argument is not | ||||
647 | a reference then all the remaining arguments are taken as parameter | ||||
648 | names. Thus the method can be called as follows: | ||||
649 | |||||
650 | sub init { | ||||
651 | my ($self, $config) = @_; | ||||
652 | |||||
653 | # either... | ||||
654 | $self->params($config, qw( foo bar )); | ||||
655 | |||||
656 | # or... | ||||
657 | $self->params($config, [ qw( foo bar ) ]); | ||||
658 | |||||
659 | # or... | ||||
660 | $self->params($config, { foo => 'default foo value', | ||||
661 | bar => 'default bar value' } ); | ||||
662 | |||||
663 | return $self; | ||||
664 | } | ||||
665 | |||||
666 | The method looks for values in $config corresponding to the keys | ||||
667 | specified and copies them, if defined, into $self. | ||||
668 | |||||
669 | Keys can be specified in UPPER CASE and the method will look for | ||||
670 | either upper or lower case equivalents in the C<$config> hash. Thus | ||||
671 | you can call C<params()> from C<init()> like so: | ||||
672 | |||||
673 | sub init { | ||||
674 | my ($self, $config) = @_; | ||||
675 | $self->params($config, qw( FOO BAR )) | ||||
676 | return $self; | ||||
677 | } | ||||
678 | |||||
679 | but use either case for parameters passed to C<new()>: | ||||
680 | |||||
681 | my $object = My::Module->new( FOO => 'the foo value', | ||||
682 | BAR => 'the bar value' ) | ||||
683 | || die My::Module->error(); | ||||
684 | |||||
685 | my $object = My::Module->new( foo => 'the foo value', | ||||
686 | bar => 'the bar value' ) | ||||
687 | || die My::Module->error(); | ||||
688 | |||||
689 | Note however that the internal key within C<$self> used to store the | ||||
690 | value will be in the case provided in the call to C<params()> (upper | ||||
691 | case in this example). The method doesn't look for upper case | ||||
692 | equivalents when they are specified in lower case. | ||||
693 | |||||
694 | When called in list context, the method returns a list of all the | ||||
695 | values corresponding to the list of keys, some of which may be | ||||
696 | undefined (allowing you to determine which values were successfully | ||||
697 | set if you need to). When called in scalar context it returns a | ||||
698 | reference to the same list. | ||||
699 | |||||
700 | =head2 clone() | ||||
701 | |||||
702 | The C<clone()> method performs a simple shallow copy of the object | ||||
703 | hash and creates a new object blessed into the same class. You may | ||||
704 | want to provide your own C<clone()> method to perform a more complex | ||||
705 | cloning operation. | ||||
706 | |||||
707 | my $clone = $object->clone(); | ||||
708 | |||||
709 | =head2 error($msg, ...) | ||||
710 | |||||
711 | General purpose method for getting and setting error messages. When | ||||
712 | called as a class method, it returns the value of the C<$ERROR> package | ||||
713 | variable (in the derived class' package) if called without any arguments, | ||||
714 | or sets the same variable when called with one or more arguments. Multiple | ||||
715 | arguments are concatenated together. | ||||
716 | |||||
717 | # set error | ||||
718 | My::Module->error('set the error string'); | ||||
719 | My::Module->error('set ', 'the ', 'error string'); | ||||
720 | |||||
721 | # get error | ||||
722 | print My::Module->error(); | ||||
723 | print $My::Module::ERROR; | ||||
724 | |||||
725 | When called as an object method, it operates on the C<_ERROR> member | ||||
726 | of the object, returning it when called without any arguments, or | ||||
727 | setting it when called with arguments. | ||||
728 | |||||
729 | # set error | ||||
730 | $object->error('set the error string'); | ||||
731 | |||||
732 | # get error | ||||
733 | print $object->error(); | ||||
734 | |||||
735 | The method returns C<undef> when called with arguments. This allows it | ||||
736 | to be used within object methods as shown: | ||||
737 | |||||
738 | sub my_method { | ||||
739 | my $self = shift; | ||||
740 | |||||
741 | # set error and return undef in one | ||||
742 | return $self->error('bad, bad, error') | ||||
743 | if $something_bad; | ||||
744 | } | ||||
745 | |||||
746 | =head2 debug($msg, $msg, ...) | ||||
747 | |||||
748 | Prints all arguments to STDERR if the internal C<_DEBUG> flag (when | ||||
749 | called as an object method) or C<$DEBUG> package variable (when called | ||||
750 | as a class method) is set to a true value. Otherwise does nothing. | ||||
751 | The output is prefixed by a string of the form "[Class::Name]" where | ||||
752 | the name of the class is that returned by the C<id()> method. | ||||
753 | |||||
754 | =head2 debugging($flag) | ||||
755 | |||||
756 | Used to get (no arguments) or set ($flag defined) the value of the | ||||
757 | internal C<_DEBUG> flag (when called as an object method) or C<$DEBUG> | ||||
758 | package variable (when called as a class method). | ||||
759 | |||||
760 | =head2 id($newid) | ||||
761 | |||||
762 | The C<debug()> method calls this method to return an identifier for | ||||
763 | the object for printing in the debugging message. By default it | ||||
764 | returns the class name of the object (i.e. C<ref $self>), but you can | ||||
765 | of course subclass the method to return some other value. When called | ||||
766 | with an argument it uses that value to set its internal C<_ID> field | ||||
767 | which will be returned by subsequent calls to C<id()>. | ||||
768 | |||||
769 | =head1 AUTHOR | ||||
770 | |||||
771 | Andy Wardley E<lt>abw@kfs.orgE<gt> | ||||
772 | |||||
773 | =head1 VERSION | ||||
774 | |||||
775 | This is version 0.04 of Class::Base. | ||||
776 | |||||
777 | =head1 HISTORY | ||||
778 | |||||
779 | This module began life as the Template::Base module distributed as | ||||
780 | part of the Template Toolkit. | ||||
781 | |||||
782 | Thanks to Brian Moseley and Matt Sergeant for suggesting various | ||||
783 | enhancments, some of which went into version 0.02. | ||||
784 | |||||
785 | Version 0.04 was uploaded by Gabor Szabo. | ||||
786 | |||||
787 | =head1 COPYRIGHT | ||||
788 | |||||
789 | Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. | ||||
790 | |||||
791 | This module is free software; you can redistribute it and/or | ||||
792 | modify it under the same terms as Perl itself. | ||||
793 | |||||
794 | =cut |