File Coverage

blib/lib/Class/Accessor.pm

Criterion	Covered	Total	%
statement	96	102	94.1
branch	26	34	76.5
condition	20	33	60.6
subroutine	23	23	100.0
pod	12	14	85.7
total	177	206	85.9

line	stmt	bran	cond	sub	pod	time	code
1							package Class::Accessor;
2							require 5.00502;
3	5			5		83	use strict;
	5					1916
	5					88
4							$Class::Accessor::VERSION = '0.30';
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	10			10	1	326	my($proto, $fields) = @_;
117	10		33			213	my($class) = ref $proto \|\| $proto;
118
119	10	100				112	$fields = {} unless defined $fields;
120
121							# make a copy of $fields.
122	10					173	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	13			13	1	670	my($self, @fields) = @_;
144
145	13					223	$self->_mk_accessors('rw', @fields);
146							}
147
148
149							{
150	5			5		81	no strict 'refs';
	5					45
	5					67
151
152							sub _mk_accessors {
153	33			33		359	my($self, $access, @fields) = @_;
154	33		33			2239	my $class = ref $self \|\| $self;
155	33		100			424	my $ra = $access eq 'rw' \|\| $access eq 'ro';
156	33		100			386	my $wa = $access eq 'rw' \|\| $access eq 'wo';
157
158	33					305	foreach my $field (@fields) {
159	51					645	my $accessor_name = $self->accessor_name_for($field);
160	51					768	my $mutator_name = $self->mutator_name_for($field);
161	51	100	66			738	if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
162	3					60	$self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
163							}
164	51	100				521	if ($accessor_name eq $mutator_name) {
165	33					333	my $accessor;
166	33	100	100			407	if ($ra && $wa) {
		100
167	19					271	$accessor = $self->make_accessor($field);
168							} elsif ($ra) {
169	7					97	$accessor = $self->make_ro_accessor($field);
170							} else {
171	7					128	$accessor = $self->make_wo_accessor($field);
172							}
173	33	100				280	unless (defined &{"${class}::$accessor_name"}) {
	33					424
174	27					215	*{"${class}::$accessor_name"} = $accessor;
	27					525
175							}
176	33	50				1273	if ($accessor_name eq $field) {
177							# the old behaviour
178	33					2173	my $alias = "_${field}_accessor";
179	33	50				349	*{"${class}::$alias"} = $accessor unless defined &{"${class}::$alias"};
	33					538
	33					425
180							}
181							} else {
182	18	100	66			175	if ($ra and not defined &{"${class}::$accessor_name"}) {
	12					180
183	12					250	*{"${class}::$accessor_name"} = $self->make_ro_accessor($field);
	12					202
184							}
185	18	100	66			247	if ($wa and not defined &{"${class}::$mutator_name"}) {
	12					172
186	12					171	*{"${class}::$mutator_name"} = $self->make_wo_accessor($field);
	12					207
187							}
188							}
189							}
190							}
191
192							sub follow_best_practice {
193	3			3	1	28	my($self) = @_;
194	3		33			44	my $class = ref $self \|\| $self;
195	3					29	*{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
	3					45
196	3					29	*{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
	3					46
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	10			10	1	277	my($self, @fields) = @_;
223
224	10					248	$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	10			10	1	211	my($self, @fields) = @_;
251
252	10					135	$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	9			9	0	85	my ($class, $field) = @_;
294	9					93	return "get_$field";
295							}
296
297							sub best_practice_mutator_name_for {
298	9			9	0	82	my ($class, $field) = @_;
299	9					89	return "set_$field";
300							}
301
302							sub accessor_name_for {
303	33			33	1	307	my ($class, $field) = @_;
304	33					329	return $field;
305							}
306
307							sub mutator_name_for {
308	33			33	1	320	my ($class, $field) = @_;
309	33					1205	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	7			7	1	85	my($self, $key) = splice(@_, 0, 2);
333
334	7	50				218	if(@_ == 1) {
		0
335	7					91	$self->{$key} = $_[0];
336							}
337							elsif(@_ > 1) {
338	0					0	$self->{$key} = [@_];
339							}
340							else {
341	0					0	$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	14			14	1	131	my $self = shift;
358
359	14	50				177	if(@_ == 1) {
		0
360	14					214	return $self->{$_[0]};
361							}
362							elsif( @_ > 1 ) {
363	0					0	return @{$self}{@_};
	0					0
364							}
365							else {
366	0					0	$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	7			7	1	67	my ($class, $field) = @_;
384
385							# Build a closure around $field.
386							return sub {
387	10			10		163	my $self = shift;
388
389	10	100				96	if(@_) {
390	3					38	return $self->set($field, @_);
391							}
392							else {
393	7					87	return $self->get($field);
394							}
395	7					124	};
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	6			6	1	62	my($class, $field) = @_;
411
412							return sub {
413	6			6		65	my $self = shift;
414
415	6	100				1884	if (@_) {
416	1					12	my $caller = caller;
417	1					25	$self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
418							}
419							else {
420	5					240	return $self->get($field);
421							}
422	6					131	};
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	6			6	1	59	my($class, $field) = @_;
438
439							return sub {
440	4			4		75	my $self = shift;
441
442	4	100				47	unless (@_) {
443	1					13	my $caller = caller;
444	1					1603	$self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
445							}
446							else {
447	3					54	return $self->set($field, @_);
448							}
449	6					148	};
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	5			5		117	use Carp ();
	5					53
	5					84
461
462							sub _carp {
463	3			3		31	my ($self, $msg) = @_;
464	3		33			45	Carp::carp($msg \|\| $self);
465	3					55	return;
466							}
467
468							sub _croak {
469	6			6		66	my ($self, $msg) = @_;
470	6		33			275	Carp::croak($msg \|\| $self);
471	0						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							Here are Schwern's results of benchmarking Class::Accessor,
481							Class::Accessor::Fast, a hand-written accessor, and direct hash access.
482
483							Benchmark: timing 500000 iterations of By Hand - get, By Hand - set,
484							C::A - get, C::A - set, C::A::Fast - get, C::A::Fast - set,
485							Direct - get, Direct - set...
486
487							By Hand - get: 4 wallclock secs ( 5.09 usr + 0.00 sys = 5.09 CPU)
488							@ 98231.83/s (n=500000)
489							By Hand - set: 5 wallclock secs ( 6.06 usr + 0.00 sys = 6.06 CPU)
490							@ 82508.25/s (n=500000)
491							C::A - get: 9 wallclock secs ( 9.83 usr + 0.01 sys = 9.84 CPU)
492							@ 50813.01/s (n=500000)
493							C::A - set: 11 wallclock secs ( 9.95 usr + 0.00 sys = 9.95 CPU)
494							@ 50251.26/s (n=500000)
495							C::A::Fast - get: 6 wallclock secs ( 4.88 usr + 0.00 sys = 4.88 CPU)
496							@ 102459.02/s (n=500000)
497							C::A::Fast - set: 6 wallclock secs ( 5.83 usr + 0.00 sys = 5.83 CPU)
498							@ 85763.29/s (n=500000)
499							Direct - get: 0 wallclock secs ( 0.89 usr + 0.00 sys = 0.89 CPU)
500							@ 561797.75/s (n=500000)
501							Direct - set: 2 wallclock secs ( 0.87 usr + 0.00 sys = 0.87 CPU)
502							@ 574712.64/s (n=500000)
503
504							So Class::Accessor::Fast is just as fast as one you'd write yourself
505							while Class::Accessor is twice as slow, a price paid for flexibility.
506							Direct hash access is about six times faster, but provides no
507							encapsulation and no flexibility.
508
509							Of course, its not as simple as saying "Class::Accessor is twice as
510							slow as one you write yourself". These are benchmarks for the
511							simplest possible accessor, if your accessors do any sort of
512							complicated work (such as talking to a database or writing to a file)
513							the time spent doing that work will quickly swamp the time spend just
514							calling the accessor. In that case, Class::Accessor and the ones you
515							write will tend to be just as fast.
516
517
518							=head1 EXAMPLES
519
520							Here's an example of generating an accessor for every public field of
521							your class.
522
523							package Altoids;
524
525							use base qw(Class::Accessor Class::Fields);
526							use fields qw(curiously strong mints);
527							Altoids->mk_accessors( Altoids->show_fields('Public') );
528
529							sub new {
530							my $proto = shift;
531							my $class = ref $proto \|\| $proto;
532							return fields::new($class);
533							}
534
535							my Altoids $tin = Altoids->new;
536
537							$tin->curiously('Curiouser and curiouser');
538							print $tin->{curiously}; # prints 'Curiouser and curiouser'
539
540
541							# Subclassing works, too.
542							package Mint::Snuff;
543							use base qw(Altoids);
544
545							my Mint::Snuff $pouch = Mint::Snuff->new;
546							$pouch->strong('Blow your head off!');
547							print $pouch->{strong}; # prints 'Blow your head off!'
548
549
550							Here's a simple example of altering the behavior of your accessors.
551
552							package Foo;
553							use base qw(Class::Accessor);
554							Foo->mk_accessor(qw(this that up down));
555
556							sub get {
557							my $self = shift;
558
559							# Note every time someone gets some data.
560							print STDERR "Getting @_\n";
561
562							$self->SUPER::get(@_);
563							}
564
565							sub set {
566							my ($self, $key) = splice(@_, 0, 2);
567
568							# Note every time someone sets some data.
569							print STDERR "Setting $key to @_\n";
570
571							$self->SUPER::set($key, @_);
572							}
573
574
575							=head1 CAVEATS AND TRICKS
576
577							Class::Accessor has to do some internal wackiness to get its
578							job done quickly and efficiently. Because of this, there's a few
579							tricks and traps one must know about.
580
581							Hey, nothing's perfect.
582
583							=head2 Don't make a field called DESTROY
584
585							This is bad. Since DESTROY is a magical method it would be bad for us
586							to define an accessor using that name. Class::Accessor will
587							carp if you try to use it with a field named "DESTROY".
588
589							=head2 Overriding autogenerated accessors
590
591							You may want to override the autogenerated accessor with your own, yet
592							have your custom accessor call the default one. For instance, maybe
593							you want to have an accessor which checks its input. Normally, one
594							would expect this to work:
595
596							package Foo;
597							use base qw(Class::Accessor);
598							Foo->mk_accessors(qw(email this that whatever));
599
600							# Only accept addresses which look valid.
601							sub email {
602							my($self) = shift;
603							my($email) = @_;
604
605							if( @_ ) { # Setting
606							require Email::Valid;
607							unless( Email::Valid->address($email) ) {
608							carp("$email doesn't look like a valid address.");
609							return;
610							}
611							}
612
613							return $self->SUPER::email(@_);
614							}
615
616							There's a subtle problem in the last example, and its in this line:
617
618							return $self->SUPER::email(@_);
619
620							If we look at how Foo was defined, it called mk_accessors() which
621							stuck email() right into Foo's namespace. There is no
622							SUPER::email() to delegate to! Two ways around this... first is to
623							make a "pure" base class for Foo. This pure class will generate the
624							accessors and provide the necessary super class for Foo to use:
625
626							package Pure::Organic::Foo;
627							use base qw(Class::Accessor);
628							Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
629
630							package Foo;
631							use base qw(Pure::Organic::Foo);
632
633							And now Foo::email() can override the generated
634							Pure::Organic::Foo::email() and use it as SUPER::email().
635
636							This is probably the most obvious solution to everyone but me.
637							Instead, what first made sense to me was for mk_accessors() to define
638							an alias of email(), _email_accessor(). Using this solution,
639							Foo::email() would be written with:
640
641							return $self->_email_accessor(@_);
642
643							instead of the expected SUPER::email().
644
645
646							=head1 AUTHORS
647
648							Copyright 2005 Marty Pauley <marty+perl@kasei.com>
649
650							This program is free software; you can redistribute it and/or modify it under
651							the same terms as Perl itself. That means either (a) the GNU General Public
652							License or (b) the Artistic License.
653
654							=head2 ORIGINAL AUTHOR
655
656							Michael G Schwern <schwern@pobox.com>
657
658							=head2 THANKS
659
660							Liz, for performance tweaks.
661
662							Tels, for his big feature request/bug report.
663
664
665							=head1 SEE ALSO
666
667							L<Class::Accessor::Fast>
668
669							These are some modules which do similar things in different ways
670							L<Class::Struct>, L<Class::Methodmaker>, L<Class::Generate>,
671							L<Class::Class>, L<Class::Contract>
672
673							L<Class::DBI> for an example of this module in use.
674
675							=cut
676
677							1;
678