dtRdr::Accessor - generate an accessor subclass

  use dtRdr::Accessor (
    package => 'Your::Subclass', # optional
    ro => [qw(foo bar baz)],
    rw => [qw(thing deal)],
    );

  dtRdr::Accessor->import(@list);

  my $package = dtRdr::Accessor->_create_package(
    'caller' => $caller,
    'package' => $package, # optional
    );

  dtRdr::Accessor->_mk_alias_get($package, $method);

  dtRdr::Accessor->ro(@list);

  dtRdr::Accessor->rw(@list);

  my $setter = dtRdr::Accessor->ro_w($name);

  dtRdr::Accessor->class_ro(name => $value, ...);

  dtRdr::Accessor->class_rw(name => $value, ...);

  my $setter = dtRdr::Accessor->class_ro_w(name => $value);
  $setter->($value);

  dtRdr::Accessor->_mk_class_accessors('ro'|'rw', $package, %data);

package dtRdr::Accessor;
$VERSION = eval{require version}?version::qv($_):$_ for(0.10.1);

use warnings;
use strict;

use Carp;
use Class::Accessor;

sub import {
  my $this_package = shift;
  (@_ % 2) and croak("odd number of elements in arguments");
  my (%options) = @_;

  @_ or return;

  my $caller = caller;

  my $package = $this_package->_create_package(
    'package' => $options{package},
    'caller'  => $caller
    );

  my @rw = @{ $options{rw} || [] };
  my @ro = @{ $options{ro} || [] };
  $package->mk_ro_accessors(@ro);
  $package->mk_accessors(@rw);

  # aliases
  $this_package->_mk_alias_get($package, @ro, @rw);
} # end subroutine import definition
########################################################################

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

  if(exists($package_map{$options{caller}})) {
    # check for attempt to change package (not allowed)
    if(exists($options{package})) {
      ($package_map{$options{caller}} eq $options{'package'}) or die;
    }
    return($package_map{$options{caller}});
  }

  # use a package that can't be stepped on unless they ask for one
  my $caller = $options{caller} or die;
  my $package = $options{package} || $caller . '::--accessors';
  $package_map{$caller} = $package;
  #warn "create $package";

  my $caller_isa;
  {
    no strict 'refs';
    # TODO hang this on a package that doesn't have a new()
    push(@{"${package}::ISA"}, 'Class::Accessor');
    $caller_isa = \@{"${caller}::ISA"};
  }
  push(@$caller_isa, $package)
    unless(grep({$_ eq $package} @$caller_isa));
  $package->follow_best_practice;
  return($package);
} # end subroutine _create_package definition
} # and closure
########################################################################

sub _mk_alias_get {
  my $this_package = shift;
  my ($package, @methods) = @_;
  foreach my $method (@methods) {
    # string-eval for speed (see Method::Alias)
    my $subref = eval("sub {\$_[0]->get_$method()}");
    $@ and croak("oops -- $@");
    # warn "$subref for $method";
    no strict 'refs';
    unless(defined(&{"${package}::$method"})) {
      *{"${package}::$method"} = $subref;
    }
    else {
      # hope we never hit that (I'm not solving all the world's problems here)
      warn "$package should probably overload 'get_$method' instead";
    }
  }
} # end subroutine _mk_alias_get definition
########################################################################

sub ro {
  my $this_package = shift;
  my (@list) = @_;
  my $caller = caller;
  $caller->isa(__PACKAGE__) and die;
  my $package = $this_package->_create_package('caller' => $caller);
  $package->mk_ro_accessors(@list);
  $this_package->_mk_alias_get($package, @list);
} # end subroutine ro definition
########################################################################

sub rw {
  my $this_package = shift;
  my (@list) = @_;
  my $caller = caller;
  $caller->isa(__PACKAGE__) and die;
  my $package = $this_package->_create_package('caller' => $caller);
  $package->mk_accessors(@list);
  $this_package->_mk_alias_get($package, @list);
} # end subroutine rw definition
########################################################################

sub ro_w {
  my $this_package = shift;
  my ($name) = @_;
  my $caller = caller;
  $caller->isa(__PACKAGE__) and die;
  my $package = $this_package->_create_package('caller' => $caller);

  # just make them as usual
  $package->mk_accessors($name);
  $this_package->_mk_alias_get($package, $name);

  # then delete and put it here
  my $new_name = '--set_' . $name;
  {
    no strict 'refs';
    *{$package.'::'.$new_name} = delete(${$package.'::'}{'set_'.$name});
  }
  return($new_name);
} # end subroutine ro_w definition
########################################################################

sub class_ro {
  my $this_package = shift;
  my (@list) = @_;
  (@list % 2) and croak("odd number of elements in arguments");
  my %data = @list;

  my $caller = caller;
  $caller->isa(__PACKAGE__) and die;
  my $package = $this_package->_create_package('caller' => $caller);
  $this_package->_mk_class_accessors('ro', $package, %data);
  $this_package->_mk_alias_get($package, keys(%data));
} # end subroutine class_ro definition
########################################################################

sub class_rw {
  my $this_package = shift;
  my (@list) = @_;
  (@list % 2) and croak("odd number of elements in arguments");
  my %data = @list;

  my $caller = caller;
  $caller->isa(__PACKAGE__) and die;
  my $package = $this_package->_create_package('caller' => $caller);
  $this_package->_mk_class_accessors('rw', $package, %data);
  $this_package->_mk_alias_get($package, keys(%data));
} # end subroutine class_rw definition
########################################################################

sub class_ro_w {
  my $this_package = shift;
  my (@list) = @_;
  (@list > 2) and croak("only one per call");

  my $caller = caller;
  $caller->isa(__PACKAGE__) and die;
  my $package = $this_package->_create_package('caller' => $caller);
  my $subref = $this_package->_mk_class_accessors('ro_w', $package, @list);
  $this_package->_mk_alias_get($package, $list[0]);
  return($subref);
} # end subroutine class_ro_w definition
########################################################################

sub _mk_class_accessors {
  my $this_package = shift;
  my ($type, $class, @data) = @_;
  (@data % 2) and croak("odd number of elements in arguments");

  my %data = @data;

  foreach my $item (keys(%data)) {

    my $value = $data{$item};

    my $getsub = sub {
      my $class = shift;
      return($value);
    };
    my $setsub = sub {
      my $self = shift;
      $value = shift;
    };
    {
      no strict 'refs';
      defined(&{$class.'::get_'.$item}) and die;
      *{$class.'::get_'.$item} = $getsub;
      if($type eq 'rw') {
        defined(&{$class.'::set_'.$item}) and die;
        *{$class.'::set_'.$item} = $setsub;
      }
      elsif($type eq 'ro_w') {
        # not exactly efficient this way, but ...
        return(sub {$setsub->(undef, @_)});
      }
    }
  }
} # end subroutine _mk_class_accessors definition
########################################################################

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