File Coverage

blib/lib/Class/Accessor/Classy.pm

Criterion	Covered	Total	%
statement	296	347	85.3
branch	70	110	63.6
condition	18	33	54.5
subroutine	47	55	85.4
pod	18	18	100.0
total	449	563	79.7

package Class::Accessor::Classy;
$VERSION = v0.9.1;

use warnings;
use strict;
use Carp;

=head1 NAME

Class::Accessor::Classy - accessors with minimal inheritance

=head1 SYNOPSIS

  package YourPackage;

  use Class::Accessor::Classy;
    with qw(new);              # with a new() method
    ro qw(foo);                # read-only
    rw qw(bar);                # read-write
    rs baz => \ (my $set_baz); # read-only, plus a secret writer

    # alternatively:
    my $set_bip = rs 'bip';

    ro_c suitcase => 'red';    # read-only class data
    rw_c hat      => 'black';  # read-write class data
    rs_c socks    => \ (my $set_socks) => undef;

    # alternative secret writer syntax
    my $set_shoes = rs_c shoes => undef;

    # also class read-only:
    constant seven => 7;
    constant eight => this->seven + 1;
  no  Class::Accessor::Classy;
  # ^-- removes all of the syntax bits from your namespace

  package whatever;

  YourPackage->set_hat(undef);
  my $obj = YourPackage->new(foo => 4, bar => 2);
  # NOTE I'm thinking of deprecating the get_foo() usage
  warn "foo ", $obj->foo;
  YourPackage->$set_socks("tube");

=head1 About

This module provides an extremely small-footprint accessor/mutator
declaration scheme for fast and convenient object attribute setup.  It
is intended as a simple and speedy mechanism for preventing hash-key
typos rather than a full-blown object system with type checking and so
on.

The accessor methods appear as a hidden parent class of your package and
generally try to stay out of the way.  The accessors and mutators
generated are of the form C and C, respectively.

=head1 Frontend

Unlike other class-modifying code, this is not designed to be inherited
from.  Instead, you simply use it and get an invisible subclass
containing your accessors.  If you use the 'no' syntax (to call
unimport), you are left with a squeaky-clean namespace.

After 'use' and before 'no', the following pieces of syntax are
available.

=head2 with

Add a 'standard' method to your class.

=over

=item new

=back

=head2 ro

Read-only properties (accessors only.)

  ro qw(foo bar baz);

=head2 rw

Define read-write (accessor + mutator) properties.

  rw qw(foo bar baz);

=head2 lv

Properties with lvalue accessors.

  lv qw(thing deal stuff);

=head2 ri

Immutable properties.  Once set, further calls to the mutator throw
errors.

  ri qw(foo bar baz);

=head2 rs

Read-only properties with a secret mutator.

  rs foo => \(my $set_foo);

=head2 lo

Read-only list properties.  These are stored as an array-ref, but the
accessor returns a list.

  lo qw(foo bar baz);

=head2 lw

Read-write list properties.  The mutator takes a list.

  lw 'foo';

This defaults to create foo()|get_foo(), set_foo(), and add_foo()
methods.  Other features are possible here, but currently experimental.

=head2 ls

List property with a secret mutator.

  ls foo => \(my $set_foo);

=head2 this

A shortcut for your classname.  Useful for e.g. defining one constant in
terms of another.

  this->some_class_method;

=head2 getter

Define a custom getter.

=head2 setter

Define a custom setter.

=head2 constant

A class constant.

  constant foo => 7;

=head2 ro_c

Read-only class method.

=head2 rw_c

A read-write class method, with a default.

  rw_c foo => 9;

=head2 rs_c

A class method with a secret setter.

  rs_c bar => \(my $set_bar) => 12;

=head2 in

Specify the destination package.  You need to set this before defining
anything else (but it is usually best to just not set it.)

  in 'why_be_so_secretive';

=head2 aka

Add an alias for an existing method.

  aka have_method => 'want_method', 'and_also_want';

=cut

=head1 Utilities

This introspection stuff is unreliable -- don't use it.

=head2 find_accessors

  @attribs = Class::Accessor::Classy->find_accessors($class);

=cut

sub find_accessors {
  my $package = shift;
  my ($class) = @_;

  # TODO just cache them rather than introspect?

  my @classes = $package->find_subclasses($class);
  my @acc;
  foreach my $c (@classes) {
    no strict 'refs';
    push(@acc, keys(%{$c . '::'}));
  }
  my %skip = map({$_ => 1} qw(new import)); # XXX no introspecting!?
  my %got;
  return(
    grep({
      ($_ !~ m/^[gs]et_/) and (lc($_) ne 'isa') and
      ($got{$_} ? 0 : ($got{$_} = 1)) and
      (! $skip{$_})
    } @acc)
  );
} # end subroutine find_accessors definition
########################################################################

=head2 find_subclasses

  @classlist = Class::Accessor::Classy->find_subclasses($class);

=cut

sub find_subclasses {
  my $package = shift;
  my ($class) = @_;

  my $get_isa;
  $get_isa = sub {
    my ($p) = @_;
    my @isa = eval {no strict 'refs'; @{$p . '::ISA'}};
    $@ and die;
    return($p, map({$get_isa->($_)} @isa));
  };
  return(grep({$_ =~ m/::--accessors$/} $get_isa->($class)));
} # end subroutine find_subclasses definition
########################################################################

=head1 Subclassable

Customized subclasses may override these methods to create a new kind of
accessor generator.

=over

=item NOTE

You do not subclass Class::Accessor::Classy to construct your objects.

If you are just creating MyObject, you are not inheriting any of these
methods.

The rest of this documentation only pertains to you if you are trying to
create something like Class::Accessor::Classy::MyWay.

=back

=over

=item notation:

Read these as: $CAC = 'Class::Accessor::Classy'; (or whatever subclass
you're creating.)

=back

=head2 exports

  my %exports = $CAC->exports;

=cut

sub exports {
  my $package = shift; # allows us to be subclassed :-)
  my $CP = sub {$package->create_package(class => $_[0])};
  my %exports = (
    with => sub (@) {
      $package->make_standards($CP->(caller), @_);
    },
    this => sub () {
      (caller)[0];
    },
    getter => sub (&) {
      my ($subref) = @_;
      $package->install_sub($CP->(caller), '--get', $subref,
        'custom getter'
      );
    },
    setter => sub (&) {
      my ($subref) = @_;
      $package->install_sub($CP->(caller), '--set', $subref,
        'custom setter'
      );
    },
    constant => sub ($$) { # same as class_ro
      $package->make_class_data('ro', $CP->(caller), @_);
    },
    ro_c => sub {
      $package->make_class_data('ro', $CP->(caller), @_);
    },
    rw_c => sub {
      $package->make_class_data('rw', $CP->(caller), @_);
    },
    rs_c => sub {
      my @list = @_;
      my @pairs;
      my @refs;
      if((ref($list[1]) || '') eq 'SCALAR') {
        croak("number of elements in argument list") if(@list % 3);
        @pairs = map({[$list[$_*3], $list[$_*3+2]]} 0..($#list / 3));
        @refs =  map({$list[$_*3+1]} 0..($#list / 3));
      }
      else {
        @pairs = map({[$list[$_*2], $list[$_*2+1]]} 0..($#list / 2));
      }
      my @names;
      my $class = $CP->(caller);
      foreach my $pair (@pairs) {
        push(@names,
          $package->make_class_data('rs', $class, @$pair)
        );
      }
      if(@refs) {
        ${$refs[$_]} = $names[$_] for(0..$#names);
      }
      else {
        @names == @pairs or die "oops";
      }
      (@names > 1) or return($names[0]);
      return(@names);
    },
    in => sub ($) {
      # put them in this package
      my ($in) = @_;
      my $caller = caller;
      my $class = $package->create_package(
        class => $caller,
        in    => $in,
      );
    },
    ro => sub (@) {
      my (@list) = @_;
      my $class = $CP->(caller);
      $package->make_getters($class, @list);
      $package->make_aliases($class, @list);
    },
    rw => sub (@) {
      my (@list) = @_;
      my $class = $CP->(caller);
      $package->make_getters($class, @list);
      $package->make_aliases($class, @list);
      $package->make_setters($class, @list);
    },
    lv => sub (@) {
      my (@list) = @_;
      my $class = $CP->(caller);
      $package->make_lv_getters($class, @list);
      $package->make_aliases($class, @list);
    },
    ri => sub (@) {
      my (@list) = @_;
      my $class = $CP->(caller);
      $package->make_getters($class, @list);
      $package->make_aliases($class, @list);
      $package->make_immutable($class, @list);
    },
    rs => sub (@) {
      my (@list) = @_;
      # decide if we got passed refs or should return a list
      my @items;
      my @refs;
      if((ref($list[1]) || '') eq 'SCALAR') {
        croak("odd number of elements in argument list") if(@list % 2);
        @items = map({$list[$_*2]} 0..($#list / 2));
        @refs =  map({$list[$_*2+1]} 0..($#list / 2));
      }
      else {
        @items = @list;
      }
      my $class = $CP->(caller);
      $package->make_getters($class, @items);
      $package->make_aliases($class, @items);
      my @names = $package->make_secrets($class, @items);
      (@names == @items) or die "oops";
      if(@refs) {
        ${$refs[$_]} = $names[$_] for(0..$#names);
      }
      (@names > 1) or return($names[0]);
      return(@names);
    },
    lo => sub {
      my (@list) = @_;
      my $class = $CP->(caller);
      foreach my $item (@list) {
        $package->make_array_method(
          class => $class,
          item  => $item,
          functions => [qw(get)],
        );
      }
    },
    lw => sub { # no list here
      my ($item, @args) = @_;
      my @f = @args;
      #@f and croak("not yet");
      $package->make_array_method(
        class => $CP->(caller),
        item  => $item,
        functions => [qw(get set add), @f],
      );
    },
    ls => sub {
      my ($item, @args) = @_;
      my $setref = shift(@args) if((ref($args[0])||'') eq 'SCALAR');

      my @f;
      my @r;
      if((ref($args[1]) || '') eq 'SCALAR') {
        croak("odd number of elements in argument list") if(@args % 2);
        @f = map({$args[$_*2]} 0..($#args / 2));
        @r = map({$args[$_*2+1]} 0..($#args / 2));
      }
      else {
        @f = @args;
      }
      my @ans = $package->make_array_method(
        class => $CP->(caller),
        item  => $item,
        functions => [qw(get set), @f],
        secret => 1,
      );

      $$setref = shift(@ans) if($setref);
      if(@r) {
        ${$r[$_]} = $ans[$_] for(0..$#ans);
      }
      return(@ans);
    },
    aka => sub (@) {
      my ($from, @to) = @_;
      my $class = $CP->(caller);
      $package->make_aka($class, $from, @to);
    },
  );
} # end subroutine exports definition
########################################################################

=head2 import

  $CAC->import;

=cut

sub import {
  my $package = shift;

  my $caller = caller();
  # we should never export to main
  croak 'cannot have accessors on the main package' if($caller eq 'main');
  my %exports = $package->exports;
  foreach my $name (keys(%exports)) {
    no strict 'refs';
    #no warnings 'redefine';
    #my $ugh = *{$caller . '::' . $name} if defined(&{$caller . '::' . $name});
    #warn "ugh $name ", $ugh if($ugh);
    *{$caller . '::' . $name} = $exports{$name};
  }
} # end subroutine import definition
########################################################################

=head2 unimport

  $CAC->unimport;

=cut

sub unimport {
  my $package = shift;

  my $caller = caller();
  my %exports = $package->exports;
  #carp "unimport $caller";
  foreach my $name (keys(%exports)) {
    no strict 'refs';
    if(defined(&{$caller . '::' . $name})) {
      delete(${$caller . '::'}{$name});
    }
  }
} # end subroutine unimport definition
########################################################################



=head2 create_package

Creates and returns the package in which the accessors will live.  Also
pushes the created accessor package into the caller's @ISA.

If it already exists, simply returns the cached value.

  my $package = $CAC->create_package(
    class => $caller,
    in    => $package, # optional
  );

=cut

{
my %package_map;
sub create_package {
  my $this_package = shift;
  (@_ % 2) and croak("odd number of elements in argument list");
  my (%options) = @_;

  my $class = $options{class} or croak('no class?');
  if(exists($package_map{$class})) {
    # check for attempt to change package (not allowed)
    if(exists($options{in})) {
      ($package_map{$class} eq $options{in}) or die;
    }
    return($package_map{$class});
  }

  # use a package that can't be stepped on unless they ask for one
  my $package = $options{in} || $class . '::--accessors';
  $package_map{$class} = $package;

  my $class_isa = do { no strict 'refs'; \@{"${class}::ISA"}; };
  push(@$class_isa, $package)
    unless(grep({$_ eq $package} @$class_isa));
  return($package);
} # end subroutine create_package definition
} # and closure
########################################################################

=head2 install_sub

  $CAC->install_sub($class, $name, $subref, $note);

=cut

sub install_sub {
  my $package = shift;
  my ($class, $name, $subref, $note) = @_;
  my $fullname = $class . '::' . $name;
  if(defined(&{$fullname})) {
    # play nice with Module::Refresh and such?
    my $lvl = 1;
    while(defined(my $p = caller($lvl++))) {
      if($p eq 'Module::Refresh') { $lvl = 0; last; }
    }
    $lvl and croak("$fullname is already defined");
  }
  {
    no strict 'refs';
    *{$fullname} = $subref;
  }
  $package->annotate($class, $name, $note) if($note);
  return($fullname);
} # end subroutine install_sub definition
########################################################################

=head2 annotate

  $CAC->annotate($class, $name, $note);

=cut

{
my %notes;
sub annotate {
  my $package = shift;
  my ($class, $name, $note) = @_;
  $notes{$class} ||= {};
  $notes{$class}{$name} = $note;
} # end subroutine annotate definition
########################################################################

=head2 get_notes

  my %notes = $CAC->get_notes;

=cut

sub get_notes {
  my $package = shift;
  return(%notes);
} # end subroutine get_notes definition
} # and closure
########################################################################

=head2 make_standards

  $CAC->make_standards($class, @list);

=cut

{
my %standards = (
  'new' => sub {
    my $class = shift;
    croak('odd number of elements in argument list') if(@_ % 2);
    my $self = {@_};
    bless($self, $class);
    return($self);
  }
);
sub make_standards {
  my $package = shift;
  my ($class, @list) = @_;
  @list or croak("no list?");
  foreach my $item (@list) {
    my $subref = $standards{$item} or
      croak("no standard method for '$item'");
    $package->install_sub($class, $item, $subref, 'stock');
  }
} # end subroutine make_standards definition
} # end closure
########################################################################

=head2 _getter

Returns a compiled getter subref corresponding to whether or not the
class has a '--get' method.

  $CAC->_getter($class, $item);

=cut

sub _getter {
  my $package = shift;
  my ($class, $item, $opt) = @_;

  my $and = '';
  if($opt and my $attr = $opt->{attrs}) {
    $and = ' () ' . $attr;
  }

  if($class->can('--get')) {
    return $package->do_eval(
      "sub$and {\$_[0]->\$\{\\'--get'\}('$item')}",
      $item
    );
  }
  else {
    return $package->do_eval("sub$and {\$_[0]->{'$item'}}", $item);
  }
} # end subroutine _getter definition
########################################################################

=head2 make_getters

  $CAC->make_getters($class, @list);

=cut

sub make_getters {
  my $package = shift;
  my ($class, @list) = @_;
  foreach my $item (@list) {
    my $subref = $package->_getter($class, $item);
    $package->install_sub($class, $item, $subref, 'getter');
  }
} # end subroutine make_getters definition
########################################################################

=head2 make_lv_getters

  $CAC->make_lv_getters($class, @list);

=cut

sub make_lv_getters {
  my $package = shift;
  my ($class, @list) = @_;

  require attributes;
  foreach my $item (@list) {
    my $subref = $package->_getter($class, $item, {attrs => ':lvalue'});
    $package->install_sub($class, $item, $subref, 'getter');
  }
} # end subroutine make_lv_getters definition
########################################################################

=head2 _setter

Returns a compiled setter subref corresponding to whether or not the
class has a '--set' method.

  $CAC->_setter($class, $item);

=cut

sub _setter {
  my $package = shift;
  my ($class, $item, %args) = @_;

  my $before = $args{before} || '';

  if($class->can('--set')) {
    return $package->do_eval(
      'sub {my $self = shift; ' . $before .
        q($self->${\'--set'}) . "('$item',\$_[0])}",
      $item
    );
  }
  else {
    return $package->do_eval(
      'sub {my $self = shift; ' . $before .
        '$self'."->{'$item'} = \$_[0]}",
      $item
    );
  }
} # end subroutine _setter definition
########################################################################

=head2 make_setters

  $CAC->make_setters($class, @list);

=cut

sub make_setters {
  my $package = shift;
  my ($class, @list) = @_;
  foreach my $item (@list) {
    my $subref = $package->_setter($class, $item);
    $package->install_sub($class, 'set_' . $item, $subref, 'setter');
  }
} # end subroutine make_setters definition
########################################################################

=head2 make_immutable

Creates immutable (one-time-only) setters.

  CAC->make_immutable($class, @list);

=cut

sub make_immutable {
  my $package = shift;
  my ($class, @list) = @_;
  foreach my $item (@list) {
    my $check = 'exists($self->{' . $item . '}) and croak(' .
      qq("$item is immutable") . ');';
    my $subref = $package->_setter($class, $item, before => $check);
    $package->install_sub($class, 'set_' . $item, $subref, 'immutable');
  }
} # end subroutine make_immutable definition
########################################################################

=head2 make_secrets

  my @names = $CAC->make_secrets($class, @list);

=cut

sub make_secrets {
  my $package = shift;
  my ($class, @list) = @_;
  my @names;
  foreach my $item (@list) {
    my $subref = $package->_setter($class, $item);
    my $name = '--set_' . $item;
    push(@names, $name);
    $package->install_sub($class, $name, $subref, 'private');
  }
  return(@names);
} # end subroutine make_secrets definition
########################################################################

=head2 make_aliases

Constructs 'get_' aliases for a @list of accessors.

  $CAC->make_aliases($class, @list);

=cut

sub make_aliases {
  my $package = shift;
  my ($class, @list) = @_;
  foreach my $item (@list) {
    my $subref = $package->do_eval("sub {\$_[0]->$item}", $item);
    $package->install_sub($class, 'get_' . $item, $subref, "->$item");
  }
} # end subroutine make_aliases definition
########################################################################

=head2 make_aka

Create a list of alias methods which runtime refer to $realname.

  $CAC->make_aka($where, $realname, @aliases);

=cut

sub make_aka {
  my $package = shift;
  my ($class, $item, @aka) = @_;

  my $get_attr = attributes->can('get');
  my $got = $class->can($item);
  my $attr = (
    $get_attr and $got and grep(/^lvalue$/, $get_attr->($got))
    ) ? '() :lvalue' : '';
  my $subref = $package->do_eval("sub $attr {\$_[0]->$item}", $item);
  foreach my $aka (@aka) {
    $package->install_sub($class, $aka, $subref, "->$item");
  }
} # end subroutine make_aka definition
########################################################################

=head2 do_eval

  my $subref = $package->do_eval($string, @checks);

=cut

sub do_eval {
  my $self = shift;
  my ($string, @checks) = @_;
  foreach my $check (@checks) {
    ($check =~ m/^[a-z_][\w]*$/i) or croak("'$check' not a valid name");
  }
  my $subref = eval($string);
  $@ and croak("oops $@");
  return($subref);
} # end subroutine do_eval definition
########################################################################

=head1 List Accessors

=head2 make_array_method

  $CAC->make_array_method(
    class     => $class,
    item      => $name,
    functions => [@functions],
    secret    => $bool,
  );

If secret is true, will return the list of names.

=cut

sub make_array_method {
  my $package = shift;
  my %opts = @_;
  my $class = $opts{class} or die;
  my $item = $opts{item};
  my @functions = @{$opts{functions}};
  my %subs = $package->_get_array_subs($item);
  my @ret;
  ($item =~ m/^[a-z_][\w]*$/i) or croak("'$item' not a valid name");
  foreach my $f (@functions) {
    my $str = $subs{$f} or croak("no such function $f");
    my $name = $item;
    unless($f eq 'get') {
      $name = ($opts{secret} ? '--' : '') . $f . '_' . $item;
      $opts{secret} and push(@ret, $name);
    }
    my $subref = eval($str);
    $@ and croak("oops $@");
    $package->install_sub($class, $name, $subref,
      ($opts{secret} ? 'private ' : '') .  "$f array");
  }
  return(@ret);
} # end subroutine make_array_method definition
########################################################################

=head2 _get_array_subs

  my %subs = $CAC->_get_array_subs($name);

=cut

sub _get_array_subs {
  my $package = shift;
  my ($item) = @_;

  my $s = '$_[0]';
  my %subs = (
    get   => "sub {$s\->{$item} or return; \@{$s\->{$item}}}",
    set   => "sub {my \$self = shift;
      \$self->{$item} ||= []; \@{\$self->{$item}} = (\@_)}",
    inner => "sub {$s\->{$item}}",
    add   => "sub {my \$self = shift;
      \$self->{$item} or Carp::croak(\"'$item' list is empty\");
      push(\@{\$self->{$item}}, \@_);}",
    'pop' => "sub {$s\->{$item} or
      Carp::croak(\"'$item' list is empty\");
      pop(\@{$s\->{$item}});}",
    'shift' => "sub {$s\->{$item} or
      Carp::croak(\"'$item' list is empty\");
      shift(\@{$s\->{$item}});}",
    'unshift' => "sub {my \$self = shift;
      \$self->{$item} or Carp::croak(\"'$item' list is empty\");
      unshift(\@{\$self->{$item}}, \@_);}",
  );
  return(%subs);
} # end subroutine _get_array_subs definition
########################################################################

=head1 Class Accessors

=head2 make_class_data

  $CAC->make_class_data($mode, $class, $key, $value);

If mode is 'rs', returns the secret setter name.

=cut

sub make_class_data {
  my $package = shift;
  my ($mode, $class, $key, $value) = @_;

  my $getsub = sub {
    my $self = shift;
    return($value);
  };
  my $setsub = sub { # TODO should be like C.D.Inheritable?
    my $self = shift;
    $value = shift;
  };
  $package->install_sub($class, $key, $getsub, 'class getter');
  if($mode eq 'rw') {
    $package->install_sub($class, 'set_' . $key, $setsub,
      'class setter');
  }
  elsif($mode eq 'rs') {
    my $name = '--set_' . $key;
    $package->install_sub($class, $name, $setsub,
      'private class setter');
    return($name);
  }
  else {
    ($mode eq 'ro') or die "no such mode '$mode'";
  }
  return;
} # end subroutine make_class_data definition
########################################################################

# TODO
# opt '+aliases';
# opts prefix => '_';
# $package->options

=head1 AUTHOR

Eric Wilhelm @

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2006-2007 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatseover.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vi:ts=2:sw=2:et:sta
1;