view release on metacpan or  search on metacpan

lib/Class/Accessor/Classy.pm  view on Meta::CPAN

=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 (@) {