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