Finalized core13 and redirector fixes
[people/pmueller/ipfire-2.x.git] / config / mpfire / perl / Accessor.pm
1 package Class::Accessor;
2 require 5.00502;
3 use strict;
4 $Class::Accessor::VERSION = '0.31';
5
6 =head1 NAME
7
8 Class::Accessor - Automated accessor generation
9
10 =head1 SYNOPSIS
11
12 package Employee;
13 use base qw(Class::Accessor);
14 Employee->mk_accessors(qw(name role salary));
15
16 # Meanwhile, in a nearby piece of code!
17 # Class::Accessor provides new().
18 my $mp = Foo->new({ name => "Marty", role => "JAPH" });
19
20 my $job = $mp->role; # gets $mp->{role}
21 $mp->salary(400000); # sets $mp->{salary} = 400000 (I wish)
22
23 # like my @info = @{$mp}{qw(name role)}
24 my @info = $mp->get(qw(name role));
25
26 # $mp->{salary} = 400000
27 $mp->set('salary', 400000);
28
29
30 =head1 DESCRIPTION
31
32 This module automagically generates accessors/mutators for your class.
33
34 Most of the time, writing accessors is an exercise in cutting and
35 pasting. You usually wind up with a series of methods like this:
36
37 sub name {
38 my $self = shift;
39 if(@_) {
40 $self->{name} = $_[0];
41 }
42 return $self->{name};
43 }
44
45 sub salary {
46 my $self = shift;
47 if(@_) {
48 $self->{salary} = $_[0];
49 }
50 return $self->{salary};
51 }
52
53 # etc...
54
55 One for each piece of data in your object. While some will be unique,
56 doing value checks and special storage tricks, most will simply be
57 exercises in repetition. Not only is it Bad Style to have a bunch of
58 repetitious code, but its also simply not lazy, which is the real
59 tragedy.
60
61 If you make your module a subclass of Class::Accessor and declare your
62 accessor fields with mk_accessors() then you'll find yourself with a
63 set of automatically generated accessors which can even be
64 customized!
65
66 The basic set up is very simple:
67
68 package My::Class;
69 use base qw(Class::Accessor);
70 My::Class->mk_accessors( qw(foo bar car) );
71
72 Done. My::Class now has simple foo(), bar() and car() accessors
73 defined.
74
75 =head2 What Makes This Different?
76
77 What makes this module special compared to all the other method
78 generating modules (L<"SEE ALSO">)? By overriding the get() and set()
79 methods you can alter the behavior of the accessors class-wide. Also,
80 the accessors are implemented as closures which should cost a bit less
81 memory than most other solutions which generate a new method for each
82 accessor.
83
84
85 =head1 METHODS
86
87 =head2 new
88
89 my $obj = Class->new;
90 my $obj = $other_obj->new;
91
92 my $obj = Class->new(\%fields);
93 my $obj = $other_obj->new(\%fields);
94
95 Class::Accessor provides a basic constructor. It generates a
96 hash-based object and can be called as either a class method or an
97 object method.
98
99 It takes an optional %fields hash which is used to initialize the
100 object (handy if you use read-only accessors). The fields of the hash
101 correspond to the names of your accessors, so...
102
103 package Foo;
104 use base qw(Class::Accessor);
105 Foo->mk_accessors('foo');
106
107 my $obj = Class->new({ foo => 42 });
108 print $obj->foo; # 42
109
110 however %fields can contain anything, new() will shove them all into
111 your object. Don't like it? Override it.
112
113 =cut
114
115 sub new {
116 my($proto, $fields) = @_;
117 my($class) = ref $proto || $proto;
118
119 $fields = {} unless defined $fields;
120
121 # make a copy of $fields.
122 bless {%$fields}, $class;
123 }
124
125 =head2 mk_accessors
126
127 Class->mk_accessors(@fields);
128
129 This creates accessor/mutator methods for each named field given in
130 @fields. Foreach field in @fields it will generate two accessors.
131 One called "field()" and the other called "_field_accessor()". For
132 example:
133
134 # Generates foo(), _foo_accessor(), bar() and _bar_accessor().
135 Class->mk_accessors(qw(foo bar));
136
137 See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
138 for details.
139
140 =cut
141
142 sub mk_accessors {
143 my($self, @fields) = @_;
144
145 $self->_mk_accessors('rw', @fields);
146 }
147
148
149 {
150 no strict 'refs';
151
152 sub _mk_accessors {
153 my($self, $access, @fields) = @_;
154 my $class = ref $self || $self;
155 my $ra = $access eq 'rw' || $access eq 'ro';
156 my $wa = $access eq 'rw' || $access eq 'wo';
157
158 foreach my $field (@fields) {
159 my $accessor_name = $self->accessor_name_for($field);
160 my $mutator_name = $self->mutator_name_for($field);
161 if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
162 $self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
163 }
164 if ($accessor_name eq $mutator_name) {
165 my $accessor;
166 if ($ra && $wa) {
167 $accessor = $self->make_accessor($field);
168 } elsif ($ra) {
169 $accessor = $self->make_ro_accessor($field);
170 } else {
171 $accessor = $self->make_wo_accessor($field);
172 }
173 unless (defined &{"${class}::$accessor_name"}) {
174 *{"${class}::$accessor_name"} = $accessor;
175 }
176 if ($accessor_name eq $field) {
177 # the old behaviour
178 my $alias = "_${field}_accessor";
179 *{"${class}::$alias"} = $accessor unless defined &{"${class}::$alias"};
180 }
181 } else {
182 if ($ra and not defined &{"${class}::$accessor_name"}) {
183 *{"${class}::$accessor_name"} = $self->make_ro_accessor($field);
184 }
185 if ($wa and not defined &{"${class}::$mutator_name"}) {
186 *{"${class}::$mutator_name"} = $self->make_wo_accessor($field);
187 }
188 }
189 }
190 }
191
192 sub follow_best_practice {
193 my($self) = @_;
194 my $class = ref $self || $self;
195 *{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
196 *{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
197 }
198
199 }
200
201 =head2 mk_ro_accessors
202
203 Class->mk_ro_accessors(@read_only_fields);
204
205 Same as mk_accessors() except it will generate read-only accessors
206 (ie. true accessors). If you attempt to set a value with these
207 accessors it will throw an exception. It only uses get() and not
208 set().
209
210 package Foo;
211 use base qw(Class::Accessor);
212 Class->mk_ro_accessors(qw(foo bar));
213
214 # Let's assume we have an object $foo of class Foo...
215 print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
216 $foo->foo(42); # BOOM! Naughty you.
217
218
219 =cut
220
221 sub mk_ro_accessors {
222 my($self, @fields) = @_;
223
224 $self->_mk_accessors('ro', @fields);
225 }
226
227 =head2 mk_wo_accessors
228
229 Class->mk_wo_accessors(@write_only_fields);
230
231 Same as mk_accessors() except it will generate write-only accessors
232 (ie. mutators). If you attempt to read a value with these accessors
233 it will throw an exception. It only uses set() and not get().
234
235 B<NOTE> I'm not entirely sure why this is useful, but I'm sure someone
236 will need it. If you've found a use, let me know. Right now its here
237 for orthoginality and because its easy to implement.
238
239 package Foo;
240 use base qw(Class::Accessor);
241 Class->mk_wo_accessors(qw(foo bar));
242
243 # Let's assume we have an object $foo of class Foo...
244 $foo->foo(42); # OK. Sets $self->{foo} = 42
245 print $foo->foo; # BOOM! Can't read from this accessor.
246
247 =cut
248
249 sub mk_wo_accessors {
250 my($self, @fields) = @_;
251
252 $self->_mk_accessors('wo', @fields);
253 }
254
255 =head1 DETAILS
256
257 An accessor generated by Class::Accessor looks something like
258 this:
259
260 # Your foo may vary.
261 sub foo {
262 my($self) = shift;
263 if(@_) { # set
264 return $self->set('foo', @_);
265 }
266 else {
267 return $self->get('foo');
268 }
269 }
270
271 Very simple. All it does is determine if you're wanting to set a
272 value or get a value and calls the appropriate method.
273 Class::Accessor provides default get() and set() methods which
274 your class can override. They're detailed later.
275
276 =head2 follow_best_practice
277
278 In Damian's Perl Best Practices book he recommends separate get and set methods
279 with the prefix set_ and get_ to make it explicit what you intend to do. If you
280 want to create those accessor methods instead of the default ones, call:
281
282 __PACKAGE__->follow_best_practice
283
284 =head2 accessor_name_for / mutator_name_for
285
286 You may have your own crazy ideas for the names of the accessors, so you can
287 make those happen by overriding C<accessor_name_for> and C<mutator_name_for> in
288 your subclass. (I copied that idea from Class::DBI.)
289
290 =cut
291
292 sub best_practice_accessor_name_for {
293 my ($class, $field) = @_;
294 return "get_$field";
295 }
296
297 sub best_practice_mutator_name_for {
298 my ($class, $field) = @_;
299 return "set_$field";
300 }
301
302 sub accessor_name_for {
303 my ($class, $field) = @_;
304 return $field;
305 }
306
307 sub mutator_name_for {
308 my ($class, $field) = @_;
309 return $field;
310 }
311
312 =head2 Modifying the behavior of the accessor
313
314 Rather than actually modifying the accessor itself, it is much more
315 sensible to simply override the two key methods which the accessor
316 calls. Namely set() and get().
317
318 If you -really- want to, you can override make_accessor().
319
320 =head2 set
321
322 $obj->set($key, $value);
323 $obj->set($key, @values);
324
325 set() defines how generally one stores data in the object.
326
327 override this method to change how data is stored by your accessors.
328
329 =cut
330
331 sub set {
332 my($self, $key) = splice(@_, 0, 2);
333
334 if(@_ == 1) {
335 $self->{$key} = $_[0];
336 }
337 elsif(@_ > 1) {
338 $self->{$key} = [@_];
339 }
340 else {
341 $self->_croak("Wrong number of arguments received");
342 }
343 }
344
345 =head2 get
346
347 $value = $obj->get($key);
348 @values = $obj->get(@keys);
349
350 get() defines how data is retreived from your objects.
351
352 override this method to change how it is retreived.
353
354 =cut
355
356 sub get {
357 my $self = shift;
358
359 if(@_ == 1) {
360 return $self->{$_[0]};
361 }
362 elsif( @_ > 1 ) {
363 return @{$self}{@_};
364 }
365 else {
366 $self->_croak("Wrong number of arguments received");
367 }
368 }
369
370 =head2 make_accessor
371
372 $accessor = Class->make_accessor($field);
373
374 Generates a subroutine reference which acts as an accessor for the given
375 $field. It calls get() and set().
376
377 If you wish to change the behavior of your accessors, try overriding
378 get() and set() before you start mucking with make_accessor().
379
380 =cut
381
382 sub make_accessor {
383 my ($class, $field) = @_;
384
385 # Build a closure around $field.
386 return sub {
387 my $self = shift;
388
389 if(@_) {
390 return $self->set($field, @_);
391 }
392 else {
393 return $self->get($field);
394 }
395 };
396 }
397
398 =head2 make_ro_accessor
399
400 $read_only_accessor = Class->make_ro_accessor($field);
401
402 Generates a subroutine refrence which acts as a read-only accessor for
403 the given $field. It only calls get().
404
405 Override get() to change the behavior of your accessors.
406
407 =cut
408
409 sub make_ro_accessor {
410 my($class, $field) = @_;
411
412 return sub {
413 my $self = shift;
414
415 if (@_) {
416 my $caller = caller;
417 $self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
418 }
419 else {
420 return $self->get($field);
421 }
422 };
423 }
424
425 =head2 make_wo_accessor
426
427 $read_only_accessor = Class->make_wo_accessor($field);
428
429 Generates a subroutine refrence which acts as a write-only accessor
430 (mutator) for the given $field. It only calls set().
431
432 Override set() to change the behavior of your accessors.
433
434 =cut
435
436 sub make_wo_accessor {
437 my($class, $field) = @_;
438
439 return sub {
440 my $self = shift;
441
442 unless (@_) {
443 my $caller = caller;
444 $self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
445 }
446 else {
447 return $self->set($field, @_);
448 }
449 };
450 }
451
452 =head1 EXCEPTIONS
453
454 If something goes wrong Class::Accessor will warn or die by calling Carp::carp
455 or Carp::croak. If you don't like this you can override _carp() and _croak() in
456 your subclass and do whatever else you want.
457
458 =cut
459
460 use Carp ();
461
462 sub _carp {
463 my ($self, $msg) = @_;
464 Carp::carp($msg || $self);
465 return;
466 }
467
468 sub _croak {
469 my ($self, $msg) = @_;
470 Carp::croak($msg || $self);
471 return;
472 }
473
474 =head1 EFFICIENCY
475
476 Class::Accessor does not employ an autoloader, thus it is much faster
477 than you'd think. Its generated methods incur no special penalty over
478 ones you'd write yourself.
479
480 accessors:
481 Rate Basic Average Fast Faster Direct
482 Basic 189150/s -- -42% -51% -55% -89%
483 Average 327679/s 73% -- -16% -22% -82%
484 Fast 389212/s 106% 19% -- -8% -78%
485 Faster 421646/s 123% 29% 8% -- -76%
486 Direct 1771243/s 836% 441% 355% 320% --
487
488 mutators:
489 Rate Basic Average Fast Faster Direct
490 Basic 173769/s -- -34% -53% -59% -90%
491 Average 263046/s 51% -- -29% -38% -85%
492 Fast 371158/s 114% 41% -- -13% -78%
493 Faster 425821/s 145% 62% 15% -- -75%
494 Direct 1699081/s 878% 546% 358% 299% --
495
496 Class::Accessor::Fast is faster than methods written by an average programmer
497 (where "average" is based on Schwern's example code).
498
499 Class::Accessor is slower than average, but more flexible.
500
501 Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an
502 array internally, not a hash. This could be a good or bad feature depending on
503 your point of view.
504
505 Direct hash access is, of course, much faster than all of these, but it
506 provides no encapsulation.
507
508 Of course, its not as simple as saying "Class::Accessor is slower than
509 average". These are benchmarks for a simple accessor. If your accessors do
510 any sort of complicated work (such as talking to a database or writing to a
511 file) the time spent doing that work will quickly swamp the time spend just
512 calling the accessor. In that case, Class::Accessor and the ones you write
513 will be roughly the same speed.
514
515
516 =head1 EXAMPLES
517
518 Here's an example of generating an accessor for every public field of
519 your class.
520
521 package Altoids;
522
523 use base qw(Class::Accessor Class::Fields);
524 use fields qw(curiously strong mints);
525 Altoids->mk_accessors( Altoids->show_fields('Public') );
526
527 sub new {
528 my $proto = shift;
529 my $class = ref $proto || $proto;
530 return fields::new($class);
531 }
532
533 my Altoids $tin = Altoids->new;
534
535 $tin->curiously('Curiouser and curiouser');
536 print $tin->{curiously}; # prints 'Curiouser and curiouser'
537
538
539 # Subclassing works, too.
540 package Mint::Snuff;
541 use base qw(Altoids);
542
543 my Mint::Snuff $pouch = Mint::Snuff->new;
544 $pouch->strong('Blow your head off!');
545 print $pouch->{strong}; # prints 'Blow your head off!'
546
547
548 Here's a simple example of altering the behavior of your accessors.
549
550 package Foo;
551 use base qw(Class::Accessor);
552 Foo->mk_accessor(qw(this that up down));
553
554 sub get {
555 my $self = shift;
556
557 # Note every time someone gets some data.
558 print STDERR "Getting @_\n";
559
560 $self->SUPER::get(@_);
561 }
562
563 sub set {
564 my ($self, $key) = splice(@_, 0, 2);
565
566 # Note every time someone sets some data.
567 print STDERR "Setting $key to @_\n";
568
569 $self->SUPER::set($key, @_);
570 }
571
572
573 =head1 CAVEATS AND TRICKS
574
575 Class::Accessor has to do some internal wackiness to get its
576 job done quickly and efficiently. Because of this, there's a few
577 tricks and traps one must know about.
578
579 Hey, nothing's perfect.
580
581 =head2 Don't make a field called DESTROY
582
583 This is bad. Since DESTROY is a magical method it would be bad for us
584 to define an accessor using that name. Class::Accessor will
585 carp if you try to use it with a field named "DESTROY".
586
587 =head2 Overriding autogenerated accessors
588
589 You may want to override the autogenerated accessor with your own, yet
590 have your custom accessor call the default one. For instance, maybe
591 you want to have an accessor which checks its input. Normally, one
592 would expect this to work:
593
594 package Foo;
595 use base qw(Class::Accessor);
596 Foo->mk_accessors(qw(email this that whatever));
597
598 # Only accept addresses which look valid.
599 sub email {
600 my($self) = shift;
601 my($email) = @_;
602
603 if( @_ ) { # Setting
604 require Email::Valid;
605 unless( Email::Valid->address($email) ) {
606 carp("$email doesn't look like a valid address.");
607 return;
608 }
609 }
610
611 return $self->SUPER::email(@_);
612 }
613
614 There's a subtle problem in the last example, and its in this line:
615
616 return $self->SUPER::email(@_);
617
618 If we look at how Foo was defined, it called mk_accessors() which
619 stuck email() right into Foo's namespace. There *is* no
620 SUPER::email() to delegate to! Two ways around this... first is to
621 make a "pure" base class for Foo. This pure class will generate the
622 accessors and provide the necessary super class for Foo to use:
623
624 package Pure::Organic::Foo;
625 use base qw(Class::Accessor);
626 Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
627
628 package Foo;
629 use base qw(Pure::Organic::Foo);
630
631 And now Foo::email() can override the generated
632 Pure::Organic::Foo::email() and use it as SUPER::email().
633
634 This is probably the most obvious solution to everyone but me.
635 Instead, what first made sense to me was for mk_accessors() to define
636 an alias of email(), _email_accessor(). Using this solution,
637 Foo::email() would be written with:
638
639 return $self->_email_accessor(@_);
640
641 instead of the expected SUPER::email().
642
643
644 =head1 AUTHORS
645
646 Copyright 2007 Marty Pauley <marty+perl@kasei.com>
647
648 This program is free software; you can redistribute it and/or modify it under
649 the same terms as Perl itself. That means either (a) the GNU General Public
650 License or (b) the Artistic License.
651
652 =head2 ORIGINAL AUTHOR
653
654 Michael G Schwern <schwern@pobox.com>
655
656 =head2 THANKS
657
658 Liz and RUZ for performance tweaks.
659
660 Tels, for his big feature request/bug report.
661
662
663 =head1 SEE ALSO
664
665 L<Class::Accessor::Fast>
666
667 These are some modules which do similar things in different ways
668 L<Class::Struct>, L<Class::Methodmaker>, L<Class::Generate>,
669 L<Class::Class>, L<Class::Contract>
670
671 L<Class::DBI> for an example of this module in use.
672
673 =cut
674
675 1;