Class-Accessor-Classy-v0.9.1000755000764000764 011226706656 16572 5ustar00ewilhelmewilhelm000000000000Build.PL000444000764000764 74011226706656 20125 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1 use strict; use warnings; use Module::Build; my $build_class = 'Module::Build'; my $builder = $build_class->new( module_name => 'Class::Accessor::Classy', license => 'perl', requires => { 'Module::Build' => 0.28, 'version' => 0, 'Test::More' => 0, }, add_to_cleanup => [ qw(Class-Accessor-Classy-* META.yml)], #create_makefile_pl => 'small', ); $builder->create_build_script(); # vi:syntax=perl:ts=2:sw=2:et:sta MANIFEST000444000764000764 26611226706656 17765 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1Build.PL Changes lib/Class/Accessor/Classy.pm MANIFEST This list of files META.yml README t/00-load.t t/01-basic.t t/02-report.t t/03-class.t t/04-list.t t/05-set-get.t t/lvalue.t README000444000764000764 45411226706656 17513 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1Class-Accessor-Classy INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Class::Accessor::Classy Changes000444000764000764 105311226706656 20142 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1Revision history for Class-Accessor-Classy v0.9.1 2009-07-13 * better lw() documentation * 'About' documentation v0.9.0 2008-02-18 * lv() lvalue accessor/mutator maker * documentation for the frontend 'maker' functions v0.1.3 2007-04-22 * ri() immutable accessor maker * play nice with Module::Refresh * getter/setter overrides for *some* types v0.1.2 2007-02-26 * dereferenced-list accessors * class accessors * reporting * introspection (experimental) v0.1.1 2006-11-01 * initial release # vim:ts=2:sw=2:et:sta META.yml000444000764000764 104411226706656 20120 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1--- name: Class-Accessor-Classy version: v0.9.1 author: - 'Eric Wilhelm @ ' abstract: accessors with minimal inheritance license: perl resources: license: http://dev.perl.org/licenses/ requires: Module::Build: 0.28 Test::More: 0 version: 0 configure_requires: Module::Build: 0.3401 provides: Class::Accessor::Classy: file: lib/Class/Accessor/Classy.pm version: v0.9.1 generated_by: Module::Build version 0.3401 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 t000755000764000764 011226706656 16756 5ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.100-load.t000444000764000764 52511226706656 20416 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/tuse Test::More tests => 3; my $package = 'Class::Accessor::Classy'; eval("use $package ();"); ok(! $@, 'use_ok') or BAIL_OUT("load failed: $@"); eval("use $package;"); ok($@); like($@, qr/^cannot have accessors on the main package/); eval {require version}; diag("Testing $package ", $package->VERSION); # vi:syntax=perl:ts=2:sw=2:et:sta lvalue.t000555000764000764 70011226706656 20550 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/t#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); { package bar; use Class::Accessor::Classy; with 'new'; lv 'foo'; no Class::Accessor::Classy; } { my $bar = bar->new(foo => 2); isa_ok($bar, 'bar'); can_ok($bar, 'foo'); is($bar->foo, 2); is($bar->foo = 3, 3); is($bar->foo, 3); } { my $bar = bar->new; isa_ok($bar, 'bar'); is($bar->foo, undef); is($bar->foo = 3, 3); is($bar->foo, 3); } # vim:ts=2:sw=2:et:sta 04-list.t000555000764000764 325711226706656 20506 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/t#!/usr/bin/perl use warnings; use strict; use Test::More 'no_plan'; my @exports; BEGIN { eval {require Class::Accessor::Classy}; ok(!$@); }; { { package Foo; use Class::Accessor::Classy; with 'new'; lo 'things'; no Class::Accessor::Classy; } ok(Foo->isa('Foo::--accessors'), 'isa Foo::--accessors'); can_ok('Foo', 'things'); my $foo = Foo->new(things => [qw(a b c)]); is_deeply([$foo->things], [qw(a b c)]); } { { package Deal; use Class::Accessor::Classy; with 'new'; lw 'these'; no Class::Accessor::Classy; } can_ok('Deal', 'these', map({$_ . '_these'} qw(set add)), ); my $deal = Deal->new; eval{$deal->add_these('foo')}; my $err = $@; ok($err, 'slap'); like($err, qr/list is empty/) or die $err; $deal->set_these(); is(scalar($deal->these), 0); ok($deal->add_these('foo')); is(scalar($deal->these), 1); is($deal->add_these(qw(bar baz)), 3); is_deeply([$deal->these], [qw(foo bar baz)]); is(scalar($deal->set_these(qw(baz bar foo))), 3); is_deeply([$deal->these], [qw(baz bar foo)]); } { my ($set_g, $set_h, $add_h); { package This; use Class::Accessor::Classy; with 'new'; ls g => \$set_g; ls h => \$set_h, add => \$add_h; no Class::Accessor::Classy; } is($set_g, '--set_g'); is($set_h, '--set_h'); is($add_h, '--add_h'); my $this = This->new; eval{$this->$add_h('foo')}; my $err = $@; ok($err, 'slap'); like($err, qr/list is empty/) or die $err; is(scalar($this->$set_g(qw(foo bar baz))), 3); is(scalar($this->$set_h(qw(bop boo bot))), 3); is_deeply([$this->g], [qw(foo bar baz)]); is_deeply([$this->h], [qw(bop boo bot)]); } # vi:ts=2:sw=2:et:sta 01-basic.t000555000764000764 573111226706656 20610 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/t#!/usr/bin/perl use warnings; use strict; use Test::More 'no_plan'; my @exports; BEGIN { eval {require Class::Accessor::Classy}; ok(!$@); can_ok('Class::Accessor::Classy', 'exports'); @exports = keys(%{{Class::Accessor::Classy->exports}}); ok(@exports); }; { package Bar; use Class::Accessor::Classy; } ok(! Bar->isa('Bar::--accessors'), 'safe to use()'); # basic usage: { package Foo; use Class::Accessor::Classy; ro qw(fee fie foe); rw qw(foo bar baz); no Class::Accessor::Classy; } ok(Foo->isa('Foo::--accessors'), 'isa Foo::--accessors'); can_ok('Foo', map({$_, 'get_' . $_} qw(fee fie foe foo bar baz)), map({'set_' . $_} qw(foo bar baz)) ); ok(! Foo->can("set_$_"), "do not want set_$_") for qw(fee fie foe); # "no" is compile-time BEGIN {ok(! Foo->can($_), "do not want $_") for(@exports)}; # later usage { package Deal; use Class::Accessor::Classy; ro qw(a b c); rw qw(d e f); } ok(Deal->isa('Deal::--accessors'), 'isa Deal::--accessors'); can_ok('Deal', map({$_, 'get_' . $_} qw(a b c d e f)), map({'set_' . $_} qw(d e f)) ); ok(! Deal->can("set_$_"), "do not want set_$_") for qw(a b c); # I didn't say "no" above" BEGIN {ok(Deal->can($_), "still have $_") for(@exports)}; # now check unimport { package Deal; no Class::Accessor::Classy; } BEGIN {ok(! Deal->can($_), "no more $_") for(@exports)}; { package Deal; use Class::Accessor::Classy; rs g => \(my $set_g); my $set_h = rs 'h'; my ($set_i, $set_j) = rs 'i', 'j'; no Class::Accessor::Classy; main::is($set_g, '--set_g'); main::is($set_h, '--set_h'); main::is($set_i, '--set_i'); main::is($set_j, '--set_j'); } { { package Make; use Class::Accessor::Classy; with 'new'; ro 'q'; rw 's'; no Class::Accessor::Classy; } can_ok('Make', 'new'); can_ok('Make', 'q'); can_ok('Make', 'get_q'); can_ok('Make', 's'); can_ok('Make', 'get_s'); can_ok('Make', 'set_s'); ok(! Make->can('set_q'), 'do not want set_q'); my $make = Make->new(q => 5, s => 2); is($make->q, 5, 'getter ok'); is($make->s, 2, 'getter ok'); is($make->set_s(3), 3); is($make->s, 3, 'setter ok'); is($make->get_s, 3, 'setter ok'); eval {Make->new({q => 4})}; ok($@, 'oops'); like($@, qr/odd number/, 'message'); } { { package Baz; use Class::Accessor::Classy; with 'new'; ro 'q'; ri 's'; no Class::Accessor::Classy; } can_ok('Baz', 'new'); can_ok('Baz', 'q'); can_ok('Baz', 'get_q'); can_ok('Baz', 's'); can_ok('Baz', 'get_s'); can_ok('Baz', 'set_s'); ok(! Baz->can('set_q'), 'do not want set_q'); my $baz = Baz->new(q => 5, s => 2); is($baz->q, 5, 'getter ok'); is($baz->s, 2, 'getter ok'); eval {$baz->set_s(3)}; my $err = $@; ok($err, 'slap'); like($err, qr/is immutable/, 'message'); is($baz->s, 2, 'immutable ok'); is($baz->get_s, 2, 'immutable ok'); delete($baz->{s}); is($baz->set_s(3), 3); is($baz->s, 3, 'setter ok'); is($baz->get_s, 3, 'setter ok'); } # vi:ts=2:sw=2:et:sta 03-class.t000555000764000764 263111226706656 20632 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/t#!/usr/bin/perl use warnings; use strict; use Test::More 'no_plan'; BEGIN { eval {require Class::Accessor::Classy}; ok(!$@); } { package Foo; use Class::Accessor::Classy; ro bip => 'bop'; ro_c fee => 'FEE'; ro_c fie => 'FIE'; ro_c foe => 'FOE'; rw_c foo => 'FOO'; rw_c bar => 'BAR'; rw_c baz => 'BAZ'; no Class::Accessor::Classy; } ok(Foo->isa('Foo::--accessors'), 'isa Foo::--accessors'); can_ok('Foo', map({$_} qw(fee fie foe foo bar baz)), map({'set_' . $_} qw(foo bar baz)) ); is(Foo->$_, uc($_), "look $_") for(qw(fee fie foe foo bar baz)); for my $n (qw(foo bar baz)) { my $setter = 'set_' . $n; Foo->$setter($n); is(Foo->$n, $n, "setter $n"); Foo->$setter(uc($n)); is(Foo->$n, uc($n), "setter $n"); } { package Deal; use Class::Accessor::Classy; rs_c g => \ (my $set_g) => 'g'; my $set_h = rs_c 'h' => 'h'; my ($set_i, $set_j) = rs_c i => 'i', j => 'j'; no Class::Accessor::Classy; package main; is($set_g, '--set_g'); is($set_h, '--set_h'); is($set_i, '--set_i'); is($set_j, '--set_j'); can_ok('Deal', map({$_, '--set_' . $_} qw(g h i j)) ); is(Deal->$_, $_, "look $_") for(qw(g h i j)); Deal->$set_g('G'); Deal->$set_h('H'); Deal->$set_j('J'); Deal->$set_i('I'); is($set_g, '--set_g'); is($set_h, '--set_h'); is($set_i, '--set_i'); is($set_j, '--set_j'); is(Deal->$_, uc($_), "set $_") for(qw(g h i j)); } # vi:ts=2:sw=2:et:sta 05-set-get.t000555000764000764 216711226706656 21103 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/t#!/usr/bin/perl use warnings; use strict; use Test::More 'no_plan'; { my %didget; my %didset; { package Foo; use Class::Accessor::Classy; with 'new'; getter { my $self = shift; my ($k) = @_; $didget{$k} ||= 0; $didget{$k}++; return($self->{$k}); }; setter { my $self = shift; my ($k, $v) = @_; $didset{$k} ||= 0; $didset{$k}++; $self->{$k} = $v; }; ro 'q'; rw 's'; no Class::Accessor::Classy; } can_ok('Foo', 'new'); can_ok('Foo', 'q'); can_ok('Foo', 'get_q'); can_ok('Foo', 's'); can_ok('Foo', 'get_s'); can_ok('Foo', 'set_s'); ok(! Foo->can('set_q'), 'do not want set_q'); my $make = Foo->new(q => 5, s => 2); is($make->q, 5, 'getter ok'); is($make->s, 2, 'getter ok'); is($make->set_s(3), 3); is($make->s, 3, 'setter ok'); is($make->get_s, 3, 'setter ok'); eval {Foo->new({q => 4})}; ok($@, 'oops'); like($@, qr/odd number/, 'message'); is_deeply(\%didget, { q => 1, s => 3, }, 'getter counts'); is_deeply(\%didset, { s => 1, }, 'getter counts'); } # vi:ts=2:sw=2:et:sta 02-report.t000444000764000764 61111226706656 21010 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/t#!/usr/bin/perl use warnings; use strict; use Test::More 'no_plan'; BEGIN { eval {require Class::Accessor::Classy}; ok(!$@); } # TODO require some kind of import('USE_NOTES') or something? my $p = 'Class::Accessor::Classy'; is($p->annotate('foo', 'thing', 'stuff'), 'stuff'); my %notes = $p->get_notes; is_deeply(\%notes, {foo => {thing => 'stuff'}}, 'notes'); # vi:ts=2:sw=2:et:sta lib000755000764000764 011226706656 17261 5ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1Class000755000764000764 011226706656 20326 5ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/libAccessor000755000764000764 011226706656 22070 5ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/lib/ClassClassy.pm000444000764000764 5671011226706656 24052 0ustar00ewilhelmewilhelm000000000000Class-Accessor-Classy-v0.9.1/lib/Class/Accessorpackage 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;