| 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 | Class::Base::new |
| 740 | 5 | 2 | 2.22ms | 2.22ms | Class::Base::error |
| 24 | 4 | 2 | 129µs | 129µs | Class::Base::debug |
| 1 | 1 | 1 | 13µs | 15µs | Class::Base::BEGIN@23 |
| 1 | 1 | 1 | 10µs | 17µs | Class::Base::BEGIN@231 |
| 1 | 1 | 1 | 7µs | 22µs | Class::Base::BEGIN@46 |
| 1 | 1 | 1 | 7µs | 14µs | Class::Base::BEGIN@256 |
| 1 | 1 | 1 | 6µs | 14µs | Class::Base::BEGIN@109 |
| 0 | 0 | 0 | 0s | 0s | Class::Base::clone |
| 0 | 0 | 0 | 0s | 0s | Class::Base::debugging |
| 0 | 0 | 0 | 0s | 0s | Class::Base::id |
| 0 | 0 | 0 | 0s | 0s | Class::Base::init |
| 0 | 0 | 0 | 0s | 0s | Class::Base::params |
| 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 | 5180 | 2.87ms | 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 | $errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"}; | ||||
| 111 | } | ||||
| 112 | 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 | 112 | 143µs | my $self = shift; | ||
| 224 | my ($flag); | ||||
| 225 | |||||
| 226 | 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 |