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

  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");

  ro qw(foo bar baz);

  rw qw(foo bar baz);

  lv qw(thing deal stuff);

  ri qw(foo bar baz);

  rs foo => \(my $set_foo);

  lo qw(foo bar baz);

  lw 'foo';

  ls foo => \(my $set_foo);

  this->some_class_method;

  constant foo => 7;

  rw_c foo => 9;

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

  in 'why_be_so_secretive';

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

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

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

  my %exports = $CAC->exports;

  $CAC->import;

  $CAC->unimport;

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

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

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

  my %notes = $CAC->get_notes;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

use warnings;
use strict;
use Carp;

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

{
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
########################################################################

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
########################################################################

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

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

{
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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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
########################################################################

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

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