package dtRdr::Accessor;

use warnings;
use strict;

use Carp;
use Class::Accessor;

our $VERSION = '0.01';

=head1 NAME

dtRdr::Accessor - generate an accessor subclass

=head1 SYNOPSIS

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

=cut


=head2 import

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

=cut

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


=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 = dtRdr::Accessor->_create_package(
    'caller' => $caller,
    'package' => $package, # optional
    );

=cut

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


=head2 _mk_alias_get

Alias "$method"() to be a shortcut for "get_$method"().

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

=cut

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

=head2 ro

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

=cut

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

=head2 rw

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

=cut

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


=head2 ro_w

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

=cut

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

=head2 class_ro

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

=cut

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

=head2 class_rw

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

=cut

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

=head2 class_ro_w

Creates a getter and setter and hands you a reference to the setter
instead of installing it.

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

=cut

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

=head2 _mk_class_accessors

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

=cut

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

=head1 AUTHOR

Eric Wilhelm <ewilhelm at cpan dot org>

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<http://rt.cpan.org>.  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 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 whatsoever.  You
have been warned.

=head1 LICENSE

The dotReader(TM) is OSI Certified Open Source Software licensed under
the GNU General Public License (GPL) Version 2, June 1991. Non-encrypted
and encrypted packages are usable in connection with the dotReader(TM).
The ability to create, edit, or otherwise modify content of such
encrypted packages is self-contained within the packages, and NOT
provided by the dotReader(TM), and is addressed in a separate commercial
license.

You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=cut

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