git.maemo.org Git - pkg-perl/blob - deb-src/libclass-accessor-perl/libclass-accessor-perl-0.31/lib/Class/Accessor/Faster.pm

   1 package Class::Accessor::Faster;
   2 use base 'Class::Accessor';
   3 use strict;
   4 $Class::Accessor::Faster::VERSION = '0.31';
   5
   6 =head1 NAME
   7
   8 Class::Accessor::Faster - Even faster, but less expandable, accessors
   9
  10 =head1 SYNOPSIS
  11
  12   package Foo;
  13   use base qw(Class::Accessor::Faster);
  14
  15 =head1 DESCRIPTION
  16
  17 This is a faster but less expandable version of Class::Accessor::Fast.
  18
  19 Class::Accessor's generated accessors require two method calls to accompish
  20 their task (one for the accessor, another for get() or set()).
  21
  22 Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
  23 resulting in a somewhat faster accessor.
  24
  25 Class::Accessor::Faster uses an array reference underneath to be faster.
  26
  27 Read the documentation for Class::Accessor for more info.
  28
  29 =cut
  30
  31 my %slot;
  32 sub _slot {
  33     my($class, $field) = @_;
  34     my $n = $slot{$class}->{$field};
  35     return $n if defined $n;
  36     $n = keys %{$slot{$class}};
  37     $slot{$class}->{$field} = $n;
  38     return $n;
  39 }
  40
  41 sub new {
  42     my($proto, $fields) = @_;
  43     my($class) = ref $proto || $proto;
  44     my $self = bless [], $class;
  45
  46     $fields = {} unless defined $fields;
  47     for my $k (keys %$fields) {
  48         my $n = $class->_slot($k);
  49         $self->[$n] = $fields->{$k};
  50     }
  51     return $self;
  52 }
  53
  54 sub make_accessor {
  55     my($class, $field) = @_;
  56     my $n = $class->_slot($field);
  57     return sub {
  58         return $_[0]->[$n] if @_ == 1;
  59         return $_[0]->[$n] = $_[1] if @_ == 2;
  60         return (shift)->[$n] = \@_;
  61     };
  62 }
  63
  64
  65 sub make_ro_accessor {
  66     my($class, $field) = @_;
  67     my $n = $class->_slot($field);
  68     return sub {
  69         return $_[0]->[$n] if @_ == 1;
  70         my $caller = caller;
  71         $_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
  72     };
  73 }
  74
  75
  76 sub make_wo_accessor {
  77     my($class, $field) = @_;
  78     my $n = $class->_slot($field);
  79     return sub {
  80         if (@_ == 1) {
  81             my $caller = caller;
  82             $_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
  83         } else {
  84             return $_[0]->[$n] = $_[1] if @_ == 2;
  85             return (shift)->[$n] = \@_;
  86         }
  87     };
  88 }
  89
  90
  91 =head1 AUTHORS
  92
  93 Copyright 2007 Marty Pauley <marty+perl@kasei.com>
  94
  95 This program is free software; you can redistribute it and/or modify it under
  96 the same terms as Perl itself.  That means either (a) the GNU General Public
  97 License or (b) the Artistic License.
  98
  99 =head1 SEE ALSO
 100
 101 L<Class::Accessor>
 102
 103 =cut
 104
 105 1;