Profile of Class/Base.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:23:16 2012

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
383 | 7 | 3 | 4.59ms | 57.7ms | Class::Base::::newClass::Base::new
740 | 5 | 2 | 2.22ms | 2.22ms | Class::Base::::errorClass::Base::error
24 | 4 | 2 | 129µs | 129µs | Class::Base::::debugClass::Base::debug
1 | 1 | 1 | 13µs | 15µs | Class::Base::::BEGIN@23Class::Base::BEGIN@23
1 | 1 | 1 | 10µs | 17µs | Class::Base::::BEGIN@231Class::Base::BEGIN@231
1 | 1 | 1 | 7µs | 22µs | Class::Base::::BEGIN@46Class::Base::BEGIN@46
1 | 1 | 1 | 7µs | 14µs | Class::Base::::BEGIN@256Class::Base::BEGIN@256
1 | 1 | 1 | 6µs | 14µs | Class::Base::::BEGIN@109Class::Base::BEGIN@109
0 | 0 | 0 | 0s | 0s | Class::Base::::cloneClass::Base::clone
0 | 0 | 0 | 0s | 0s | Class::Base::::debuggingClass::Base::debugging
0 | 0 | 0 | 0s | 0s | Class::Base::::idClass::Base::id
0 | 0 | 0 | 0s | 0s | Class::Base::::initClass::Base::init
0 | 0 | 0 | 0s | 0s | Class::Base::::paramsClass::Base::params

Call graph for these subroutines as a Graphviz dot language file.

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 use strict; # 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 sub new {
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 no strict 'refs'; # 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 sub error {
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 no strict qw( refs ); # 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 sub debug {
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 no strict 'refs'; # 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 no strict 'refs'; # 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