Rose-Object-0.860/000750 000765 000120 00000000000 12223410706 013716 5ustar00johnadmin000000 000000 Rose-Object-0.860/Changes000755 000765 000120 00000010073 12223410643 015222 0ustar00johnadmin000000 000000 0.860 (10.03.2013) - John Siracusa * Fixed typos in the documentation. (RT 89241) 0.859 (10.17.2010) - John Siracusa * Eliminated non-numeric warning in Class::XSAccessor version check. * Update copyright date. 0.858 (02.10.2010) - John Siracusa * The CPAN shell in 5.10.1 (on Mac OS X, anyway) chokes on the t/debugger.t test. I've moved it to the xt directory. 0.857 (02.09.2010) - John Siracusa * Fixed a bug that caused methods to be created more than once, triggering a fatal error, when running under the debugger in perl 5.10.1 and up. (RT 54444, patch by Christopher Masto) 0.856 (10.16.2009) - John Siracusa * Updated eval blocks to avoid stomping on $@ from an outer scope. 0.855 (01.22.2009) - John Siracusa * Added Class::XSAccessor support. 0.854 (12.09.2008) - John Siracusa * Altered the default name for the adds_method and inherits_method method types in the inherited_hash class method maker. 0.853 (07.30.2008) - John Siracusa * Fixed a bug in the hash get_set_init method interface. (Reported by Bill Moseley) 0.852 (06.25.2008) - John Siracusa * Documented Rose::Object::MixIn->import()'s -target_class parameter. 0.851 (06.06.2008) - John Siracusa * Corrected mistakes in the Rose::Class::MakeMethods::Generic POD. 0.85 (05.28.2008) - John Siracusa * Added "inherited_hash" and "inheritable_boolean" class method types. * Documented shift, unshift, and pop array method maker method type. * Fixed a bug that prevented "--opt=0" options from being honored (Reported by Bill Moseley) 0.84 (05.17.2007) - John Siracusa * Fixed a bug in Rose::Object::MixIn that caused Rose::DB::Object's "helpers" setup() parameter to work incorrectly. 0.83 (05.04.2007) - John Siracusa * Moved Rose::Object::MixIn here from Rose::DB::Object. 0.821 (11.13.2006) - John Siracusa * Minor fix to the test suite. 0.82 (10.06.2006) - John Siracusa * Forcibly reloading a module that uses one of the method makers no longer causes a fatal "method redefined" error. * Added the allow_apparent_reload() class attribute to control the new ability described above. 0.81 (06.20.2006) - John Siracusa * Fixed a bug in the inheritable_set method maker that caused set values not to be inherited by subclasses more than one superclass away. (Reported by Michael Lackhoff) * Added more links to the documentation. 0.80 (03.07.2006) - John Siracusa * Fixed a typo in the documentation. * Big version number bump to reflect progress towards 1.0. 0.016 (10.26.2005) - John Siracusa * Fixed a bug in the inheritable class hash method maker's "delete" method type that could cause an extra key to be deleted under some rare circumstances. 0.015 (08.30.2005) - John Siracusa * Added "clear" method to inheritable and inherited sets. * Added ability to set inherited and inheritable sets using the list_method method type. 0.014 (08.18.2005) - John Siracusa * Added get_set_init_all interface to hash method maker. 0.013 (02.13.2005) - John Siracusa * Added hash and inheritable_hash class methods to method maker. 0.012 (12.07.2004) - John Siracusa * Renamed get_set_items array interface to get_set_item. * Added "ignore_existing" flag to method maker. * Renamed "override" and "ignore_existing" method maker flags to "override_existing" and "preserve_existing". 0.011 (11.14.2004) - John Siracusa * Added copyright info. Version 0.01 removed. 0.01 (11.13.2004) - John Siracusa * Initial release. Rose-Object-0.860/lib/000750 000765 000120 00000000000 12223410705 014463 5ustar00johnadmin000000 000000 Rose-Object-0.860/Makefile.PL000755 000765 000120 00000003315 11117655107 015711 0ustar00johnadmin000000 000000 require 5.006; use ExtUtils::MakeMaker; eval { require Rose::DateTime::Util }; if($@) { warn<<"EOF"; ## ## WARNING: You are missing Rose::DateTime ## ## There is a circular dependency between Rose::Object and Rose::DateTime. ## Rose::Object will simply skip all tests that require Rose::DateTime, but ## you should really re-run "make test" after installing Rose::DateTime ## just to make sure everything works correctly. ## EOF } my $MM_Version = $ExtUtils::MakeMaker::VERSION; if($MM_Version =~ /_/) # dev version { $MM_Version = eval $MM_Version; die $@ if($@); } WriteMakefile(NAME => 'Rose::Object', ABSTRACT_FROM => 'lib/Rose/Object.pm', VERSION_FROM => 'lib/Rose/Object.pm', ($^O =~ /darwin/i ? (dist => { DIST_CP => 'cp' }) : ()), # Avoid Mac OS X ._* files PREREQ_PM => { # This is a circular dependency... #Rose::DateTime => 0, Test::Simple => 0, Test::More => 0, }, AUTHOR => 'John Siracusa ', ($MM_Version >= 6.48 ? (MIN_PERL_VERSION => '5.6.0') : ()), ($MM_Version >= 6.31 ? (LICENSE => 'perl') : ()), ($MM_Version <= 6.44 ? () : (META_MERGE => { resources => { license => 'http://dev.perl.org/licenses/', homepage => 'http://rose.googlecode.com/', bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-Object', repository => 'http://rose.googlecode.com/svn/trunk/modules/Rose-Object', }, }))); Rose-Object-0.860/MANIFEST000660 000765 000120 00000001100 12223410706 015042 0ustar00johnadmin000000 000000 Changes lib/Rose/Class.pm lib/Rose/Class/MakeMethods/Generic.pm lib/Rose/Class/MakeMethods/Set.pm lib/Rose/Object.pm lib/Rose/Object/MakeMethods.pm lib/Rose/Object/MakeMethods/DateTime.pm lib/Rose/Object/MakeMethods/Generic.pm lib/Rose/Object/MixIn.pm Makefile.PL MANIFEST This list of files t/basic.t t/lib/Person1.pm t/lib/Person2.pm t/makemethods.t t/makemethods-xs.t t/pod.t t/redefine.t xt/debugger.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Rose-Object-0.860/META.json000660 000765 000120 00000002424 12223410706 015344 0ustar00johnadmin000000 000000 { "abstract" : "A simple object base class.", "author" : [ "John Siracusa " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Rose-Object", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0", "Test::Simple" : "0", "perl" : "5.006000" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-Object" }, "homepage" : "http://rose.googlecode.com/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://rose.googlecode.com/svn/trunk/modules/Rose-Object" } }, "version" : "0.860" } Rose-Object-0.860/META.yml000660 000765 000120 00000001362 12223410705 015173 0ustar00johnadmin000000 000000 --- abstract: 'A simple object base class.' author: - 'John Siracusa ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Rose-Object no_index: directory: - t - inc requires: Test::More: 0 Test::Simple: 0 perl: 5.006000 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-Object homepage: http://rose.googlecode.com/ license: http://dev.perl.org/licenses/ repository: http://rose.googlecode.com/svn/trunk/modules/Rose-Object version: 0.860 Rose-Object-0.860/t/000750 000765 000120 00000000000 12223410705 014160 5ustar00johnadmin000000 000000 Rose-Object-0.860/xt/000750 000765 000120 00000000000 12223410705 014350 5ustar00johnadmin000000 000000 Rose-Object-0.860/xt/debugger.t000644 000765 000120 00000001337 11334551420 016334 0ustar00johnadmin000000 000000 #!/usr/bin/perl -d use Test::More tests => 1; # XXX: Code taken from namespace::clean's t/07--debugger.t BEGIN { no warnings 'once'; # Apparently we can't just skip_all with -d, because the # debugger breaks at Test::Testers END block. if($] <= 5.010000) { pass; done_testing; } else { push(@DB::typeahead, 'c'); } push(@DB::typeahead, 'q'); open(my $out, '>', \my $out_buf) or warn "Could not open new out handle - $!"; $DB::OUT = $out; open(my $in, '<', \my $in_buf) or warn "Could not open new in handle - $!"; $DB::IN = $in; } use FindBin qw($Bin); use lib "$Bin/lib"; require Person1; delete $INC{'Person1.pm'}; eval { require Person1 }; ok(!$@, 'double load'); done_testing; Rose-Object-0.860/t/basic.t000755 000765 000120 00000003201 11031550117 015430 0ustar00johnadmin000000 000000 #!/usr/bin/perl use strict; use Test::More tests => 22; BEGIN { use_ok('Rose::Object'); use_ok('Rose::Class'); } my($p, $name, $age, $ok); $p = Person->new(); ok($p && $p->isa('Person'), 'new() 1'); is($p->name('John'), 'John', 'set 1'); is($p->age(26), 26, 'set 2'); is($p->name(), 'John', 'get 1'); is($p->age(), 26, 'get 2'); $p = Person->new(name => 'John2', age => 26); ok($p && $p->isa('Person'), 'new() 2'); is($p->name(), 'John2', 'get 3'); is($p->age(), 26, 'get 4'); is($p->name('Craig'), 'Craig', 'set 3'); is($p->age(50), 50, 'set 4'); is($p->name(), 'Craig', 'get 5'); is($p->age(), 50, 'get 6'); is(Person->error, undef, 'class get 1'); is(Person->error('foo'), 'foo', 'class set 1'); is(Person->error, 'foo', 'class get 2'); is($p->yippee, 'yip', 'mixin yip'); is($p->bark, 'bark', 'mixin bark'); is($p->roar, 'rawr', 'mixin rawr'); is($p->hiss, 'hiss', 'mixin hiss'); DogLike->import(qw(-target_class Nonesuch yip)); ok(Nonesuch->can('yip'), 'mixin -target_class yip'); BEGIN { use strict; package DogLike; use Rose::Object::MixIn(); our @ISA = qw(Rose::Object::MixIn); __PACKAGE__->export_tags(all => [ qw(bark yip) ]); sub bark { 'bark' } sub yip { 'yip' } package CatLike; use Rose::Object::MixIn(); our @ISA = qw(Rose::Object::MixIn); __PACKAGE__->export_tags(all => [ qw(rawr hiss) ], mean => [ 'hiss' ]); sub rawr { 'rawr' } sub hiss { 'hiss' } package Person; DogLike->import('bark', { yip => 'yippee' }); CatLike->import({ rawr => 'roar' }, ':mean'); @Person::ISA = qw(Rose::Class Rose::Object); use Rose::Object::MakeMethods::Generic ( scalar => [ qw(name age) ], ); } Rose-Object-0.860/t/lib/000750 000765 000120 00000000000 12223410705 014726 5ustar00johnadmin000000 000000 Rose-Object-0.860/t/makemethods-xs.t000755 000765 000120 00000000465 11136073074 017321 0ustar00johnadmin000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); BEGIN { eval { require Class::XSAccessor }; if($@) { require Test::More; Test::More->import(skip_all => 'Class::XSAccessor not installed'); } else { $ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'} = 0; do "$Bin/makemethods.t"; } } Rose-Object-0.860/t/makemethods.t000755 000765 000120 00000165454 11136073243 016701 0ustar00johnadmin000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 629; BEGIN { # Don't use Class::XSAccessor unless invoked from t/makemethods-xs.t # as indicated by magic (false) value 0, set in t/makemethods-xs.t unless(defined $ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'}) { $ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'} = 1; } use_ok('Rose::Object'); use_ok('Rose::Object::MakeMethods::Generic'); use_ok('Rose::Class'); use_ok('Rose::Class::MakeMethods::Generic'); use_ok('Rose::Class::MakeMethods::Set'); } my $p = Person->new() || ok(0); ok(ref $p eq 'Person', 'Construct object (no init)'); ## ## Object methods ## # # scalar # is($p->bar, undef, 'Get named attribute (scalar)'); is($p->bar('bar'), 'bar', 'Set named attribute 1 (scalar)'); is($p->bar, 'bar', 'Set named attribute 2 (scalar)'); # # scalar --get_set_init # is($p->type, 'default', 'Get named attribute (scalar --get_set_init)'); $p->type('foo'); is($p->type, 'foo', 'Set named attribute (scalar --get_set_init)'); # # boolean # $p->is_foo('foo'); is($p->is_foo, 1, 'Set named attribute (boolean) 1'); $p->is_foo(''); is($p->is_foo, 0, 'Set named attribute (boolean) 2'); $p->is_foo(0); is($p->is_foo, 0, 'Set named attribute (boolean) 3'); is($p->is_valid, 1, 'Default value (boolean)'); is($p->def0, 0, 'Default value (0) (boolean)'); # # boolean --get_set_init # is($p->is_def_foo, 1, 'Get named attribute (boolean --get_set_init)'); $p->is_def_foo(undef); is($p->is_def_foo, 0, 'Set named attribute (boolean --get_set_init)'); # # hash # ok(!defined $p->params, 'Get undefinied hash (hash)'); $p->params(a => 1, b => 2); is($p->param('b'), 2, 'Get hash key (hash)'); my $h = $p->params; ok(ref $h eq 'HASH' && $h->{'a'} == 1 && $h->{'b'} == 2, 'Get hash ref (hash --get-set_all)'); my %h = $p->params; ok($h{'a'} == 1 && $h{'b'} == 2, 'Get hash (hash --get-set_all)'); $p->params({ c => 3, d => 4 }); ok(!$p->param_exists('a'), 'Check for key existence (hash --exists)'); is(join(',', sort $p->param_names), 'c,d', 'Get key names (hash --keys)'); is(join(',', sort $p->param_values), '3,4', 'Get key values (hash --values)'); $p->delete_param('c'); is(join(',', sort $p->param_names), 'd', 'Delete param (hash --delete)'); $p->param(f => 7, g => 8); is(join(',', sort $p->param_values), '4,7,8', 'Add name/value pairs (hash)'); # # hash --get_set_init_all # $h = $p->fhash; ok(ref $h eq 'HASH' && $h->{'a'} == 1 && $h->{'b'} == 2, 'Get hash ref (hash --get-get_set_init_all)'); %h = $p->fhash; ok($h{'a'} == 1 && $h{'b'} == 2, 'Get hash (hash --get-set_all)'); $p->fhash(c => 3, d => 4); $h = $p->fhash; ok(ref $h eq 'HASH' && $h->{'c'} == 3 && $h->{'d'} == 4, 'Get hash ref 2 (hash --get-get_set_init_all)'); %h = $p->fhash; ok($h{'c'} == 3 && $h{'d'} == 4, 'Get hash 2 (hash --get-set_all)'); $p->fhash({ e => 5, f => 6 }); $h = $p->fhash; ok(ref $h eq 'HASH' && $h->{'e'} == 5 && $h->{'f'} == 6, 'Get hash ref 3 (hash --get-get_set_init_all)'); %h = $p->fhash; ok($h{'e'} == 5 && $h{'f'} == 6, 'Get hash 3 (hash --get-set_all)'); # # hash --get_set_init # my $ip = $p->iparams; ok(ref $ip eq 'HASH' && $ip->{'a'} == 1 && $ip->{'b'} == 2, 'Get default hash - hash ref (hash --get_set_init)'); $p->iparams({ c => 3, d => 4 }); my %ip = $p->iparams; ok(keys %ip == 2 && $ip{'c'} == 3 && $ip{'d'} == 4, 'Set hash - hash ref (hash --get_set_init)'); $p->clear_iparams(); %ip = $p->iparams; ok(!keys %ip, 'Clear hash (hash --get_set_init)'); $p->reset_iparams(); %ip = $p->iparams; ok(keys %ip == 2 && $ip{'a'} == 1 && $ip{'b'} == 2, 'Get default hash - hash (hash --get_set_init)'); $p->iparams(c => 3, d => 4); $ip = $p->iparams; ok(ref $ip eq 'HASH' && $ip->{'c'} == 3 && $ip->{'d'} == 4, 'Set hash - hash (hash --get_set_inited)'); my $p2 = Person->new(); is($p2->iparams('b'), 2, 'Init on key request (hash --get_set_inited)'); # # hash --get_set_inited # $ip = $p->idparams; ok(ref $ip eq 'HASH' && !keys %$ip, 'Get empty hash - scalar (hash --get_set_inited)'); $p->idparams({ c => 3, d => 4 }); %ip = $p->idparams; ok(keys %ip == 2 && $ip{'c'} == 3 && $ip{'d'} == 4, 'Set hash - hash ref (hash --get_set_inited)'); $p->clear_idparams(); %ip = $p->idparams; ok(!keys %ip, 'Get empty hash - list (hash --get_set_inited)'); $p->idparams(c => 3, d => 4); $ip = $p->idparams; ok(ref $ip eq 'HASH' && $ip->{'c'} == 3 && $ip->{'d'} == 4, 'Set hash - hash (hash --get_set_inited)'); # # array # ok(!defined $p->jobs, 'Get undefined array (array)'); $p->clear_jobs(); ok(@{$p->jobs} == 0, 'Clear array (array)'); $p->jobs('butcher', 'baker'); is(join(',', $p->jobs), 'butcher,baker', 'Set list - array (array)'); $p->jobs([ 'butcher', 'baker' ]); is(join(',', $p->jobs), 'butcher,baker', 'Set list - array ref (array)'); is(join(',', @{$p->jobs}), 'butcher,baker', 'Get list - array ref (array)'); $p->push_jobs('x'); is(join(',', $p->jobs), 'butcher,baker,x', 'push 1(array)'); $p->push_jobs('y', 'z'); is(join(',', $p->jobs), 'butcher,baker,x,y,z', 'push 2 (array)'); is($p->pop_jobs, 'z', 'pop 1 (array)'); is(join(',', $p->jobs), 'butcher,baker,x,y', 'pop 2 (array)'); is(join(',', $p->pop_jobs(2)), 'x,y', 'pop 3 (array)'); is(join(',', $p->jobs), 'butcher,baker', 'pop 4 (array)'); $p->push_jobs([ 1, 2 ]); is(join(',', $p->jobs), 'butcher,baker,1,2', 'pop 5 (array)'); is(join(',', $p->pop_jobs(2)), '1,2', 'pop 6 (array)'); $p->unshift_jobs('a'); is(join(',', $p->jobs), 'a,butcher,baker', 'unshift 1 (array)'); $p->unshift_jobs('b', 'c'); is(join(',', $p->jobs), 'b,c,a,butcher,baker', 'unshift 2 (array)'); $p->unshift_jobs([ 'd', 'e' ]); is(join(',', $p->jobs), 'd,e,b,c,a,butcher,baker', 'unshift 3 (array)'); is($p->shift_jobs, 'd', 'shift 1 (array)'); is(join(',', $p->shift_jobs(4)), 'e,b,c,a', 'shift 2 (array)'); # # array --get_set_item # $p->jobs([ 'xbutcher', 'xbaker' ]); is($p->job(0), 'xbutcher', 'Get item by index (array --get_set_item)'); $p->job(0 => 'mailman'); is($p->job(0), 'mailman', 'Set item by index (array --get_set_item)'); # # array --get_set_init # is(join(',', $p->nicknames), 'wiley,joe', 'Get default list - array (array --get_set_init)'); $p->nicknames('sam', 'moe'); is(join(',', $p->nicknames), 'sam,moe', 'Set list - array (array --get_set_init)'); $p->nicknames([ 'xsam', 'xmoe' ]); is(join(',', $p->nicknames), 'xsam,xmoe', 'Set list - array ref (array --get_set_init)'); is(join(',', @{$p->nicknames}), 'xsam,xmoe', 'Get list - array ref (array --get_set_init)'); # # array --get_set_inited # my $nicks = $p->idnicknames; ok(ref $nicks eq 'ARRAY' && !@$nicks, 'Get empty array - scalar (array --get_set_inited)'); my @nicks = $p->idnicknames; ok(@nicks == 0, 'Get empty array - list (array --get_set_inited)'); $p->idnicknames('sam', 'moe'); is(join(',', $p->idnicknames), 'sam,moe', 'Set list - array (array --get_set_inited)'); $p->idnicknames([ 'xsam', 'xmoe' ]); is(join(',', $p->idnicknames), 'xsam,xmoe', 'Set list - array ref (array --get_set_inited)'); is(join(',', @{$p->idnicknames}), 'xsam,xmoe', 'Get list - array ref (array --get_set_inited)'); # # datetime # eval { require Rose::DateTime::Util }; SKIP: { if($@) { skip("datetime tests: could not load Rose::DateTime::Util", 13); } $p = Person->new(birthday => '01/24/1984 1:00'); ok(ref $p eq 'Person', 'Construct object (date: with init)'); is($p->birthday(format => '%m/%d/%Y %H:%M:%S'), '01/24/1984 01:00:00', 'Get named attribute (datetime) 1'); $p->birthday('01/24/1984 1:00:01'); is($p->birthday(format => '%m/%d/%Y %H:%M:%S'), '01/24/1984 01:00:01', 'Set named attribute (datetime) 2'); $p->birthday('01/24/1984 1:00:01.1'); is($p->birthday(format => '%m/%d/%Y %H:%M:%S.%1N'), '01/24/1984 01:00:01.1', 'Set named attribute (datetime) 3'); is($p->birthday(format => '%m/%d/%Y %H:%M:%S'), '01/24/1984 01:00:01', 'Set named attribute (datetime) 4'); $p->birthday_floating('01/24/1984 1:00'); is(ref $p->birthday_floating->time_zone, 'DateTime::TimeZone::Floating', 'Check time zone 2'); eval { $p->birthday(foo => 1) }; ok($@, 'Invalid args (datetime)'); eval { $p->birthday(1, 2, 3) }; ok($@, 'Too many args (datetime)'); is($p->arrival(format => '%m/%d/%Y %t'), '01/24/1984 1:10:00 PM', 'Get named attribute (datetime --get_set_init) 1'); is($p->departure(format => '%m/%d/%Y'), '01/30/2000', 'Get named attribute (datetime --get_set_init) 2'); is(ref $p->departure->time_zone, 'DateTime::TimeZone::Floating', 'Check time zone (datetime --get_set_init) 2'); eval { $p->arrival(foo => 1) }; ok($@, 'Invalid args (datetime --get_set_init)'); eval { $p->arrival(1, 2, 3) }; ok($@, 'Too many args (datetime --get_set_init)'); } ## ## Class methods ## # # scalar # is(MyObject->flub('bar'), 'bar', 'Set named class attribute (scalar) 1'); is(MyObject->flub(), 'bar', 'Get named class attribute (scalar) 1'); is(MySubObject->flub(), undef, 'Get named class attribute (scalar) 2'); is(MySubObject->flub('baz'), 'baz', 'Set named class attribute (scalar) 2'); is(MySubObject->flub(), 'baz', 'Get named class attribute (scalar) 3'); # # scalar --get_set_init # is(MyObject->class_type(), 'wacky', 'Get named class attribute (scalar --get_set_init) 1'); is(MyObject->class_type('foob'), 'foob', 'Set named class attribute (scalar --get_set_init) 1'); is(MyObject->class_type(), 'foob', 'Get named class attribute (scalar --get_set_init) 1'); is(MySubObject->class_type(), 'subwacky', 'Get named class attribute (scalar --get_set_init) 2'); is(MySubObject->class_type('baz'), 'baz', 'Set named class attribute (scalar --get_set_init) 2'); is(MySubObject->class_type(), 'baz', 'Get named class attribute (scalar --get_set_init) 3'); # # inheritable_scalar # is(MyObject->name('John'), 'John', 'Set named inheritable class attribute 1'); is(MyObject->name(), 'John', 'Get named inheritable class attribute 1'); is(MySubObject4->name, 'John', 'Get named inheritable class attribute (inherited) 1'); is(MySubObject->name(), 'John', 'Get named inheritable class attribute (inherited) 2'); is(MySubObject2->name(), 'John', 'Get named inheritable class attribute (inherited) 3'); is(MySubObject3->name(), 'John', 'Get named inheritable class attribute (inherited) 4'); is(MySubObject->name('Craig'), 'Craig', 'Set named inheritable class attribute 2'); is(MyObject->name(), 'John', 'Get named inheritable class attribute 2'); is(MySubObject->name(), 'Craig', 'Get named inheritable class attribute (inherited) 5'); is(MySubObject2->name(), 'John', 'Get named inheritable class attribute (inherited) 6'); is(MySubObject3->name(), 'John', 'Get named inheritable class attribute (inherited) 7'); is(MySubObject2->name('Anne'), 'Anne', 'Set named inheritable class attribute 3'); is(MyObject->name(), 'John', 'Get named inheritable class attribute 3'); is(MySubObject->name(), 'Craig', 'Get named inheritable class attribute (inherited) 8'); is(MySubObject2->name(), 'Anne', 'Get named inheritable class attribute (not inherited) 1'); is(MySubObject3->name(), 'Anne', 'Get named inheritable class attribute (inherited) 9'); is(MySubObject4->name, 'Anne', 'Get named inheritable class attribute (inherited) 10'); # # inheritable_boolean # is(MyObject->bool('xxx'), 1, 'Set named inheritable class attribute 1'); is(MyObject->bool(), 1, 'Get named inheritable class attribute 1'); is(MySubObject4->bool, 1, 'Get named inheritable class attribute (inherited) 1'); is(MySubObject->bool(), 1, 'Get named inheritable class attribute (inherited) 2'); is(MySubObject2->bool(), 1, 'Get named inheritable class attribute (inherited) 3'); is(MySubObject3->bool(), 1, 'Get named inheritable class attribute (inherited) 4'); is(MySubObject->bool(''), 0, 'Set named inheritable class attribute 2'); is(MyObject->bool(), 1, 'Get named inheritable class attribute 2'); is(MySubObject->bool(), 0, 'Get named inheritable class attribute (inherited) 5'); is(MySubObject2->bool(), 1, 'Get named inheritable class attribute (inherited) 6'); is(MySubObject3->bool(), 1, 'Get named inheritable class attribute (inherited) 7'); is(MySubObject2->bool(1), 1, 'Set named inheritable class attribute 3'); is(MyObject->bool(), 1, 'Get named inheritable class attribute 3'); is(MySubObject->bool(), 0, 'Get named inheritable class attribute (inherited) 8'); is(MySubObject2->bool(), 1, 'Get named inheritable class attribute (not inherited) 1'); is(MySubObject3->bool(), 1, 'Get named inheritable class attribute (inherited) 9'); is(MySubObject4->bool, 1, 'Get named inheritable class attribute (inherited) 10'); # # POD tests for inheritable_boolean # package MyClass; use Rose::Class::MakeMethods::Generic ( inheritable_boolean => 'enabled', ); package MySubClass; our @ISA = qw(MyClass); package MySubSubClass; our @ISA = qw(MySubClass); package main; is(MyClass->enabled, undef, 'x'); is(MySubClass->enabled, undef, 'x'); is(MySubSubClass->enabled, undef, 'x'); is(MyClass->enabled(1), 1, 'x'); is(MyClass->enabled, 1, 'x'); is(MySubClass->enabled, 1, 'x'); is(MySubSubClass->enabled, 1, 'x'); is(MyClass->enabled(undef), 0, 'x'); is(MyClass->enabled, 0, 'x'); is(MySubClass->enabled, 0, 'x'); is(MySubSubClass->enabled, 0, 'x'); is(MySubClass->enabled(1), 1, 'x'); is(MyClass->enabled, 0, 'x'); is(MySubClass->enabled, 1, 'x'); is(MySubSubClass->enabled, 1, 'x'); is(MyClass->enabled('foo'), 1, 'x'); is(MySubClass->enabled(undef), 0, 'x'); is(MyClass->enabled, 1, 'x'); is(MySubClass->enabled, 0, 'x'); is(MySubSubClass->enabled, 0, 'x'); is(MySubSubClass->enabled(1), 1 , 'x'); is(MyClass->enabled, 1, 'x'); is(MySubClass->enabled, 0, 'x'); is(MySubSubClass->enabled, 1, 'x'); # # hash # ok(!defined MyObject->cparams, 'Get undefined class hash (hash)'); MyObject->cparams(a => 1, b => 2); is(MyObject->cparam('b'), 2, 'Get class hash key (hash)'); my $ch = MyObject->cparams; ok(ref $ch eq 'HASH' && $ch->{'a'} == 1 && $ch->{'b'} == 2, 'Get class hash ref (hash --get-set_all)'); my %ch = MyObject->cparams; ok($ch{'a'} == 1 && $ch{'b'} == 2, 'Get class hash (hash --get-set_all)'); MyObject->cparams({ c => 3, d => 4 }); ok(!MyObject->cparam_exists('a'), 'Check for class hash key existence (hash --exists)'); is(join(',', sort MyObject->cparam_names), 'c,d', 'Get class hash key names (hash --keys)'); is(join(',', sort MyObject->cparam_values), '3,4', 'Get class hash key values (hash --values)'); MyObject->delete_cparam('c'); is(join(',', sort MyObject->cparam_names), 'd', 'Delete cparam (hash --delete)'); MyObject->cparam(f => 7, g => 8); is(join(',', sort MyObject->cparam_values), '4,7,8', 'Add class hash name/value pairs (hash)'); # # inheritable_hash # ok(!defined MyObject->icparams, 'Get undefined inheritable class hash (hash)'); MyObject->icparams(a => 1, b => 2); is(MyObject->icparam('b'), 2, 'Get inheritable class hash key (hash)'); my $ich = MyObject->icparams; ok(ref $ich eq 'HASH' && $ich->{'a'} == 1 && $ich->{'b'} == 2, 'Get inheritable class hash ref (hash --get-set_all)'); my %ich = MyObject->icparams; ok($ich{'a'} == 1 && $ich{'b'} == 2, 'Get inheritable class hash (hash --get-set_all)'); MyObject->icparams({ c => 3, d => 4 }); ok(!MyObject->icparam_exists('a'), 'Check for inheritable class hash key existence (hash --exists)'); is(join(',', sort MyObject->icparam_names), 'c,d', 'Get inheritable class hash key names (hash --keys)'); is(join(',', sort MyObject->icparam_values), '3,4', 'Get inheritable class hash key values (hash --values)'); is(join(',', sort MySubObject->icparam_names), 'c,d', 'Inherited keys 1'); is(join(',', sort MySubObject->icparam_values), '3,4', 'Inherited values 1'); MyObject->delete_icparam('c'); is(join(',', sort MyObject->icparam_names), 'd', 'Delete icparam (hash --delete)'); MyObject->icparam(f => 7, g => 8); is(join(',', sort MyObject->icparam_values), '4,7,8', 'Add inheritable class hash name/value pairs (hash)'); is(join(',', sort MySubObject2->icparam_names), 'd,f,g', 'Inherited keys 2'); is(join(',', sort MySubObject2->icparam_values), '4,7,8', 'Inherited values 2'); is(join(',', sort MySubObject3->icparam_names), 'd,f,g', 'Inherited keys 3'); is(join(',', sort MySubObject3->icparam_values), '4,7,8', 'Inherited values 3'); is(join(',', sort MySubObject->icparam_names), 'c,d', 'Inherited keys 4'); is(join(',', sort MySubObject->icparam_values), '3,4', 'Inherited values 4'); ok(!MySubObject->icparam_exists('f'), 'Inherited exists 1'); ok(MySubObject2->icparam_exists('f'), 'Inherited exists 2'); ok(MySubObject3->icparam_exists('f'), 'Inherited exists 3'); MySubObject3->delete_icparam('f'); MySubObject3->icparam('d' => 9); is(join(',', sort MySubObject->icparam_names), 'c,d', 'Inherited keys 5'); is(join(',', sort MySubObject->icparam_values), '3,4', 'Inherited values 5'); is(join(',', sort MySubObject2->icparam_names), 'd,f,g', 'Inherited keys 6'); is(join(',', sort MySubObject2->icparam_values), '4,7,8', 'Inherited values 6'); is(join(',', sort MySubObject3->icparam_names), 'd,g', 'Inherited keys 7'); is(join(',', sort MySubObject3->icparam_values), '8,9', 'Inherited values 7'); is(join(',', sort MySubObject4->icparam_names), 'd,g', 'Inherited keys 8'); is(join(',', sort MySubObject4->icparam_values), '8,9', 'Inherited values 8'); MySubObject->reset_icparams; is(join(',', sort MySubObject->icparam_names), 'd,f,g', 'reset_icparams() 1'); is(join(',', sort MySubObject->icparam_values), '4,7,8', 'reset_icparams() 2'); MySubObject->clear_icparams; is(join(',', sort MySubObject->icparam_names), '', 'clear_icparams() 1'); is(join(',', sort MySubObject->icparam_values), '', 'clear_icparams() 2'); # # inheritable_set # is(MyObject->add_required_names(qw(foo bar baz)), 3, 'add_required_names() 1'); foreach my $attr (MyObject->required_names) { is(MyObject->name_is_required($attr), 1, "name_is_required() $attr"); is(MySubObject->name_is_valid($attr), 1, "name_is_valid() $attr"); } foreach my $attr (MyObject->required_names) { is(MySubObject2->name_is_required($attr), 1, "name_is_required() inherited $attr"); is(MySubObject2->name_is_valid($attr), 1, "name_is_valid() inherited $attr"); } is(MySubObject3->add_required_names(undef), 0, 'add_required_names() 2'); foreach my $attr (MyObject->required_names) { is(MySubObject3->name_is_required($attr), 1, "name_is_required() not inherited $attr"); is(MySubObject3->name_is_valid($attr), 1, "name_is_valid() not inherited $attr"); } is(MyObject->delete_required_name('foo'), 1, 'delete_required_name() 1'); is(MyObject->name_is_required('foo'), 0, 'delete_required_name() 2'); is(MyObject->name_is_valid('foo'), 1, 'delete_required_name() 3'); is(MySubObject2->name_is_valid('foo'), 1, 'delete_required_name() 4'); is(MySubObject3->name_is_valid('foo'), 1, 'delete_required_name() 5'); is(MyObject->required_name_value(foo => 5), undef, 'required_name_value() 1'); is(MyObject->name_is_required('foo'), 0, "name_is_required() not set foo"); is(MyObject->required_name_value(bar => 5), 5, 'required_name_value() 2'); is(MyObject->required_name_value('bar'), 5, 'required_name_value() 3'); MyObject->clear_required_names; my @names = MyObject->required_names; ok(@names == 0, 'clear_required_names()'); @names = MySubObject4->inheritable_items; is_deeply([ sort @names ], [ 'abase', 'bbase' ], 'inheritable_items() 1'); # # inherited_set # is(MyObject->add_valid_names(qw(foo bar baz)), 3, 'add_valid_names() 1'); foreach my $attr (MyObject->valid_names) { is(MySubObject->name_is_valid($attr), 1, "name_is_valid() inherited $attr"); } MyObject->add_valid_name('blargh'); is(MySubObject->name_is_valid('blargh'), 1, 'name_is_valid() inherited blargh 1'); is(MySubObject2->name_is_valid('blargh'), 1, 'name_is_valid() inherited blargh 2'); MyObject->delete_valid_name('blargh'); is(MySubObject->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 3'); is(MySubObject2->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 4'); MySubObject->add_valid_name('blargh'); is(MyObject->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 5'); is(MySubObject2->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 6'); MySubObject->delete_valid_name('blargh'); is(MySubObject->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 7'); is(MySubObject2->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 8'); is(MyObject->name_is_valid('blargh'), 0, 'name_is_valid() inherited blargh 9'); MyObject->add_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 1'); is(MySubObject2->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 2'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 3'); is(MyObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 4'); MySubObject->add_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 5'); is(MySubObject2->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 6'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 7'); is(MyObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 8'); MySubObject2->add_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 9'); is(MySubObject2->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 10'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 11'); is(MyObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 12'); MySubObject3->add_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 13'); is(MySubObject2->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 14'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 15'); is(MyObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 16'); MySubObject->delete_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 0, 'name_is_valid() inherited bloop 17'); is(MySubObject2->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 18'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 19'); is(MyObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 20'); MySubObject2->delete_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 0, 'name_is_valid() inherited bloop 21'); is(MySubObject2->name_is_valid('bloop'), 0, 'name_is_valid() inherited bloop 22'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 23'); is(MyObject->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 24'); MyObject->delete_valid_name('bloop'); is(MySubObject->name_is_valid('bloop'), 0, 'name_is_valid() inherited bloop 25'); is(MySubObject2->name_is_valid('bloop'), 0, 'name_is_valid() inherited bloop 26'); is(MySubObject3->name_is_valid('bloop'), 1, 'name_is_valid() inherited bloop 27'); is(MyObject->name_is_valid('bloop'), 0, 'name_is_valid() inherited bloop 28'); MyObject->add_valid_name('argh'); is(MySubObject->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 1'); is(MySubObject2->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 2'); is(MySubObject3->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 3'); is(MyObject->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 4'); MySubObject2->delete_valid_name('argh'); is(MySubObject->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 5'); is(MySubObject2->name_is_valid('argh'), 0, 'name_is_valid() inherited argh 6'); is(MySubObject3->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 7'); is(MyObject->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 8'); MySubObject->delete_valid_name('argh'); is(MySubObject->name_is_valid('argh'), 0, 'name_is_valid() inherited argh 9'); is(MySubObject2->name_is_valid('argh'), 0, 'name_is_valid() inherited argh 10'); is(MySubObject3->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 11'); is(MyObject->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 12'); MySubObject2->inherit_valid_name('argh'); is(MySubObject->name_is_valid('argh'), 0, 'name_is_valid() inherited argh 13'); is(MySubObject2->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 14'); is(MySubObject3->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 15'); is(MyObject->name_is_valid('argh'), 1, 'name_is_valid() inherited argh 16'); MyObject->clear_valid_names; @names = MyObject->valid_names; ok(@names == 0, 'clear_valid_names()'); # # Inherited set with add_implies # MyObject->add_happy_names(qw(whee splurt foop)); foreach my $attr (MyObject->happy_names) { is(MySubObject->name_is_happy($attr), 1, "name_is_happy() inherited $attr"); is(MySubObject->name_is_valid($attr), 1, "name_is_valid() inherited implied $attr"); } MyObject->add_happy_name('whee'); is(MySubObject->name_is_happy('whee'), 1, 'name_is_happy() inherited whee 1'); is(MySubObject2->name_is_happy('whee'), 1, 'name_is_happy() inherited whee 2'); MyObject->delete_happy_name('whee'); is(MySubObject->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 3'); is(MySubObject2->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 4'); MySubObject->add_happy_name('whee'); is(MyObject->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 5'); is(MySubObject2->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 6'); MySubObject->delete_happy_name('whee'); is(MySubObject->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 7'); is(MySubObject2->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 8'); is(MyObject->name_is_happy('whee'), 0, 'name_is_happy() inherited whee 9'); MyObject->add_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 1'); is(MySubObject2->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 2'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 3'); is(MyObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 4'); MySubObject->add_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 5'); is(MySubObject2->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 6'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 7'); is(MyObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 8'); MySubObject2->add_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 9'); is(MySubObject2->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 10'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 11'); is(MyObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 12'); MySubObject3->add_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 13'); is(MySubObject2->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 14'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 15'); is(MyObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 16'); MySubObject->delete_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 0, 'name_is_happy() inherited splurt 17'); is(MySubObject2->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 18'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 19'); is(MyObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 20'); MySubObject2->delete_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 0, 'name_is_happy() inherited splurt 21'); is(MySubObject2->name_is_happy('splurt'), 0, 'name_is_happy() inherited splurt 22'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 23'); is(MyObject->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 24'); MyObject->delete_happy_name('splurt'); is(MySubObject->name_is_happy('splurt'), 0, 'name_is_happy() inherited splurt 25'); is(MySubObject2->name_is_happy('splurt'), 0, 'name_is_happy() inherited splurt 26'); is(MySubObject3->name_is_happy('splurt'), 1, 'name_is_happy() inherited splurt 27'); is(MyObject->name_is_happy('splurt'), 0, 'name_is_happy() inherited splurt 28'); MyObject->add_happy_name('foop'); is(MySubObject->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 1'); is(MySubObject2->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 2'); is(MySubObject3->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 3'); is(MyObject->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 4'); MySubObject2->delete_happy_name('foop'); is(MySubObject->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 5'); is(MySubObject2->name_is_happy('foop'), 0, 'name_is_happy() inherited foop 6'); is(MySubObject3->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 7'); is(MyObject->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 8'); MySubObject->delete_happy_name('foop'); is(MySubObject->name_is_happy('foop'), 0, 'name_is_happy() inherited foop 9'); is(MySubObject2->name_is_happy('foop'), 0, 'name_is_happy() inherited foop 10'); is(MySubObject3->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 11'); is(MyObject->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 12'); MySubObject2->inherit_happy_name('foop'); is(MySubObject->name_is_happy('foop'), 0, 'name_is_happy() inherited foop 13'); is(MySubObject2->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 14'); is(MySubObject3->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 15'); is(MyObject->name_is_happy('foop'), 1, 'name_is_happy() inherited foop 16'); MyObject->delete_valid_name('foop'); is(MyObject->name_is_happy('foop'), 0, 'delete_implies 1'); # # Inherited set with inherit_implies # MyObject->add_happy_name('iip'); is(MySubObject->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 1'); is(MySubObject2->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 2'); is(MySubObject3->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 3'); is(MyObject->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 4'); is(MySubObject->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 1'); is(MySubObject2->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 2'); is(MySubObject3->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 3'); is(MyObject->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 4'); MySubObject->delete_valid_name('iip'); is(MySubObject->name_is_valid('iip'), 0, 'name_is_valid() inherited iip 5'); is(MySubObject2->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 6'); is(MySubObject3->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 7'); is(MyObject->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 8'); is(MySubObject->name_is_happy('iip'), 0, 'name_is_happy() inherited iip 5'); is(MySubObject2->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 6'); is(MySubObject3->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 7'); is(MyObject->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 8'); MySubObject->inherit_valid_name('iip'); is(MySubObject->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 9'); is(MySubObject2->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 10'); is(MySubObject3->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 11'); is(MyObject->name_is_valid('iip'), 1, 'name_is_valid() inherited iip 12'); is(MySubObject->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 9'); is(MySubObject2->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 10'); is(MySubObject3->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 11'); is(MyObject->name_is_happy('iip'), 1, 'name_is_happy() inherited iip 12'); # # inherited_hash # my %v = (foo => 1, bar => 2, baz => 3); is(MyObject->add_val_names(%v), 3, 'add_val_names() 1'); foreach my $attr (MyObject->val_name_keys) { is(MySubObject->val_name_exists($attr), 1, "val_name_exists() inherited $attr"); is(MySubObject->val_name($attr), $v{$attr}, "val_name() inherited $attr"); } is(MyObject->val_names(\%v), 3, 'add_val_names() 2'); foreach my $attr (MyObject->val_name_keys) { is(MySubObject->val_name_exists($attr), 1, "val_name_exists() 2 inherited $attr"); is(MySubObject->val_name($attr), $v{$attr}, "val_name() 2 inherited $attr"); } MyObject->add_val_name(blargh => 11); is(MySubObject->val_name_exists('blargh'), 1, 'val_name_exists() inherited blargh 1'); is(MySubObject2->val_name_exists('blargh'), 1, 'val_name_exists() inherited blargh 2'); is(MySubObject->val_name('blargh'), 11, 'val_name() inherited blargh 1'); is(MySubObject2->val_name('blargh'), 11, 'val_name() inherited blargh 2'); MyObject->delete_val_name('blargh'); is(MySubObject->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 3'); is(MySubObject2->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 4'); MySubObject->val_name(blargh => 22); is(MyObject->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 5'); is(MySubObject2->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 6'); is(MySubObject->val_name('blargh'), 22, 'val_name() inherited blargh 3'); is(MySubObject2->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 4'); MySubObject->delete_val_name('blargh'); is(MySubObject->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 7'); is(MySubObject2->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 8'); is(MyObject->val_name_exists('blargh'), 0, 'val_name_exists() inherited blargh 9'); MyObject->add_val_name(bloop => 33); is(MySubObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 1'); is(MySubObject->val_name('bloop'), 33, 'val_name() inherited bloop 1'); is(MySubObject2->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 2'); is(MySubObject2->val_name('bloop'), 33, 'val_name() inherited bloop 2'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 3'); is(MySubObject3->val_name('bloop'), 33, 'val_name() inherited bloop 3'); is(MyObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 4'); is(MyObject->val_name('bloop'), 33, 'val_name() inherited bloop 4'); MySubObject->add_val_name(bloop => 44); is(MySubObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 5'); is(MySubObject->val_name('bloop'), 44, 'val_name() inherited bloop 5'); is(MySubObject2->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 6'); is(MySubObject2->val_name('bloop'), 33, 'val_name() inherited bloop 6'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 7'); is(MySubObject3->val_name('bloop'), 33, 'val_name() inherited bloop 7'); is(MyObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 8'); is(MyObject->val_name('bloop'), 33, 'val_name() inherited bloop 8'); MySubObject2->val_name(bloop => 55); is(MySubObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 9'); is(MySubObject->val_name('bloop'), 44, 'val_name() inherited bloop 9'); is(MySubObject2->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 10'); is(MySubObject2->val_name('bloop'), 55, 'val_name() inherited bloop 10'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 11'); is(MySubObject3->val_name('bloop'), 55, 'val_name() inherited bloop 11'); is(MyObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 12'); is(MyObject->val_name('bloop'), 33, 'val_name() inherited bloop 12'); MySubObject3->add_val_name(bloop => 66); is(MySubObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 13'); is(MySubObject->val_name('bloop'), 44, 'val_name() inherited bloop 13'); is(MySubObject2->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 14'); is(MySubObject2->val_name('bloop'), 55, 'val_name() inherited bloop 14'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 15'); is(MySubObject3->val_name('bloop'), 66, 'val_name() inherited bloop 15'); is(MyObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 16'); is(MyObject->val_name('bloop'), 33, 'val_name() inherited bloop 16'); MySubObject->delete_val_name('bloop'); is(MySubObject->val_name_exists('bloop'), 0, 'val_name_exists() inherited bloop 17'); is(MySubObject2->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 18'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 19'); is(MyObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 20'); MySubObject2->delete_val_name('bloop'); is(MySubObject->val_name_exists('bloop'), 0, 'val_name_exists() inherited bloop 21'); is(MySubObject2->val_name_exists('bloop'), 0, 'val_name_exists() inherited bloop 22'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 23'); is(MyObject->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 24'); MyObject->delete_val_name('bloop'); is(MySubObject->val_name_exists('bloop'), 0, 'val_name_exists() inherited bloop 25'); is(MySubObject2->val_name_exists('bloop'), 0, 'val_name_exists() inherited bloop 26'); is(MySubObject3->val_name_exists('bloop'), 1, 'val_name_exists() inherited bloop 27'); is(MyObject->val_name_exists('bloop'), 0, 'val_name_exists() inherited bloop 28'); MyObject->val_name(argh => 100); is(MySubObject->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 1'); is(MySubObject->val_name('argh'), 100, 'val_name() inherited argh 1'); is(MySubObject2->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 2'); is(MySubObject2->val_name('argh'), 100, 'val_name() inherited argh 2'); is(MySubObject3->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 3'); is(MySubObject3->val_name('argh'), 100, 'val_name() inherited argh 3'); is(MyObject->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 4'); is(MyObject->val_name('argh'), 100, 'val_name() inherited argh 4'); MySubObject2->delete_val_name('argh'); is(MySubObject->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 5'); is(MySubObject->val_name('argh'), 100, 'val_name() inherited argh 5'); is(MySubObject2->val_name_exists('argh'), 0, 'val_name_exists() inherited argh 6'); is(MySubObject3->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 7'); is(MySubObject3->val_name('argh'), 100, 'val_name() inherited argh 7'); is(MyObject->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 8'); is(MyObject->val_name('argh'), 100, 'val_name() inherited argh 8'); MySubObject->delete_val_name('argh'); is(MySubObject->val_name_exists('argh'), 0, 'val_name_exists() inherited argh 9'); is(MySubObject2->val_name_exists('argh'), 0, 'val_name_exists() inherited argh 10'); is(MySubObject3->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 11'); is(MySubObject3->val_name('argh'), 100, 'val_name() inherited argh 11'); is(MyObject->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 12'); is(MyObject->val_name('argh'), 100, 'val_name() inherited argh 12'); MySubObject2->inherit_val_name('argh'); is(MySubObject->val_name_exists('argh'), 0, 'val_name_exists() inherited argh 13'); is(MySubObject2->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 14'); is(MySubObject2->val_name('argh'), 100, 'val_name() inherited argh 14'); is(MySubObject3->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 15'); is(MySubObject3->val_name('argh'), 100, 'val_name() inherited argh 15'); is(MyObject->val_name_exists('argh'), 1, 'val_name_exists() inherited argh 16'); is(MyObject->val_name('argh'), 100, 'val_name() inherited argh 16'); MyObject->clear_val_names; @names = MyObject->val_name_keys; ok(@names == 0, 'clear_val_names()'); # # Inherited set with add_implies # %v = (whee => 1, splurt => 2, foop => 3); MyObject->hval_names(%v); foreach my $attr (MyObject->hval_name_keys) { is(MySubObject->hval_name_exists($attr), 1, "hval_name_exists() inherited $attr"); is(MySubObject->val_name_exists($attr), 1, "val_name_exists() inherited implied $attr"); } MyObject->add_hval_name(whee => 1); is(MySubObject->hval_name_exists('whee'), 1, 'hval_name_exists() inherited whee 1'); is(MySubObject2->hval_name_exists('whee'), 1, 'hval_name_exists() inherited whee 2'); MyObject->delete_hval_name('whee'); is(MySubObject->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 3'); is(MySubObject->hval_name('whee'), undef, 'hval_name() inherited whee 3'); is(MySubObject2->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 4'); is(MySubObject2->hval_name('whee'), undef, 'hval_name() inherited whee 4'); MySubObject->hval_name(whee => 11); is(MyObject->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 5'); is(MyObject->hval_name('whee'), undef, 'hval_name() inherited whee 5'); is(MySubObject2->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 6'); is(MySubObject2->hval_name('whee'), undef, 'hval_name() inherited whee 6'); MySubObject->delete_hval_name('whee'); is(MySubObject->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 7'); is(MySubObject2->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 8'); is(MyObject->hval_name_exists('whee'), 0, 'hval_name_exists() inherited whee 9'); MyObject->hval_name(splurt => 2); is(MySubObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 1'); is(MySubObject->hval_name('splurt'), 2, 'hval_name() inherited splurt 1'); is(MySubObject2->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 2'); is(MySubObject2->hval_name('splurt'), 2, 'hval_name() inherited splurt 2'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 3'); is(MySubObject3->hval_name('splurt'), 2, 'hval_name() inherited splurt 3'); is(MyObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 4'); is(MyObject->hval_name('splurt'), 2, 'hval_name() inherited splurt 4'); MySubObject->add_hval_name(splurt => 2); is(MySubObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 5'); is(MySubObject->hval_name('splurt'), 2, 'hval_name() inherited splurt 5'); is(MySubObject2->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 6'); is(MySubObject2->hval_name('splurt'), 2, 'hval_name() inherited splurt 6'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 7'); is(MySubObject3->hval_name('splurt'), 2, 'hval_name() inherited splurt 7'); is(MyObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 8'); is(MyObject->hval_name('splurt'), 2, 'hval_name() inherited splurt 8'); MySubObject2->add_hval_name(splurt => 2); is(MySubObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 9'); is(MySubObject2->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 10'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 11'); is(MyObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 12'); MySubObject3->add_hval_name(splurt => 2); is(MySubObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 13'); is(MySubObject2->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 14'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 15'); is(MyObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 16'); MySubObject->delete_hval_name('splurt'); is(MySubObject->hval_name_exists('splurt'), 0, 'hval_name_exists() inherited splurt 17'); is(MySubObject->hval_name('splurt'), undef, 'hval_name() inherited splurt 17'); is(MySubObject2->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 18'); is(MySubObject2->hval_name('splurt'), 2, 'hval_name() inherited splurt 18'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 19'); is(MySubObject3->hval_name('splurt'), 2, 'hval_name() inherited splurt 19'); is(MyObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 20'); is(MyObject->hval_name('splurt'), 2, 'hval_name() inherited splurt 20'); MySubObject2->delete_hval_name('splurt'); is(MySubObject->hval_name_exists('splurt'), 0, 'hval_name_exists() inherited splurt 21'); is(MySubObject2->hval_name_exists('splurt'), 0, 'hval_name_exists() inherited splurt 22'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 23'); is(MyObject->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 24'); MyObject->delete_hval_name('splurt'); is(MySubObject->hval_name_exists('splurt'), 0, 'hval_name_exists() inherited splurt 25'); is(MySubObject2->hval_name_exists('splurt'), 0, 'hval_name_exists() inherited splurt 26'); is(MySubObject3->hval_name_exists('splurt'), 1, 'hval_name_exists() inherited splurt 27'); is(MyObject->hval_name_exists('splurt'), 0, 'hval_name_exists() inherited splurt 28'); MyObject->add_hval_name(foop => 3); is(MySubObject->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 1'); is(MySubObject->hval_name('foop'), 3, 'hval_name() inherited foop 1'); is(MySubObject2->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 2'); is(MySubObject2->hval_name('foop'), 3, 'hval_name() inherited foop 2'); is(MySubObject3->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 3'); is(MySubObject3->hval_name('foop'), 3, 'hval_name() inherited foop 3'); is(MyObject->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 4'); is(MyObject->hval_name('foop'), 3, 'hval_name() inherited foop 4'); MySubObject2->delete_hval_name('foop'); is(MySubObject->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 5'); is(MySubObject->hval_name('foop'), 3, 'hval_name() inherited foop 5'); is(MySubObject2->hval_name_exists('foop'), 0, 'hval_name_exists() inherited foop 6'); is(MySubObject2->hval_name('foop'), undef, 'hval_name() inherited foop 6'); is(MySubObject3->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 7'); is(MySubObject3->hval_name('foop'), 3, 'hval_name() inherited foop 7'); is(MyObject->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 8'); is(MyObject->hval_name('foop'), 3, 'hval_name() inherited foop 8'); MySubObject->delete_hval_name('foop'); is(MySubObject->hval_name_exists('foop'), 0, 'hval_name_exists() inherited foop 9'); is(MySubObject->hval_name('foop'), undef, 'hval_name() inherited foop 9'); is(MySubObject2->hval_name_exists('foop'), 0, 'hval_name_exists() inherited foop 10'); is(MySubObject2->hval_name('foop'), undef, 'hval_name() inherited foop 10'); is(MySubObject3->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 11'); is(MySubObject3->hval_name('foop'), 3, 'hval_name() inherited foop 11'); is(MyObject->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 12'); is(MyObject->hval_name('foop'), 3, 'hval_name() inherited foop 12'); MySubObject2->inherit_hval_name('foop'); is(MySubObject->hval_name_exists('foop'), 0, 'hval_name_exists() inherited foop 13'); is(MySubObject->hval_name('foop'), undef, 'hval_name() inherited foop 13'); is(MySubObject2->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 14'); is(MySubObject2->hval_name('foop'), 3, 'hval_name() inherited foop 14'); is(MySubObject3->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 15'); is(MySubObject3->hval_name('foop'), 3, 'hval_name() inherited foop 15'); is(MyObject->hval_name_exists('foop'), 1, 'hval_name_exists() inherited foop 16'); is(MyObject->hval_name('foop'), 3, 'hval_name() inherited foop 16'); MyObject->delete_hval_name('foop'); is(MyObject->hval_name_exists('foop'), 0, 'delete_implies 1'); # # Inherited set with inherit_implies # MyObject->add_hval_name(iip => 227); is(MySubObject->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject->val_name('iip'), 227, 'val_name() inherited iip 1'); is(MySubObject2->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject2->val_name('iip'), 227, 'val_name() inherited iip 2'); is(MySubObject3->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject3->val_name('iip'), 227, 'val_name() inherited iip 3'); is(MyObject->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MyObject->val_name('iip'), 227, 'val_name() inherited iip 4'); is(MySubObject->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 1'); is(MySubObject->hval_name('iip'), 227, 'hval_name() inherited iip 1'); is(MySubObject2->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 2'); is(MySubObject2->hval_name('iip'), 227, 'hval_name() inherited iip 2'); is(MySubObject3->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MySubObject3->hval_name('iip'), 227, 'hval_name() inherited iip 3'); is(MyObject->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 4'); is(MyObject->hval_name('iip'), 227, 'hval_name() inherited iip 4'); MySubObject->delete_val_name('iip'); is(MySubObject->val_name_exists('iip'), 0, 'val_name_exists() inherited iip 3'); is(MySubObject->val_name('iip'), undef, 'val_name() inherited iip 5'); is(MySubObject2->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject2->val_name('iip'), 227, 'val_name() inherited iip 6'); is(MySubObject3->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject3->val_name('iip'), 227, 'val_name() inherited iip 7'); is(MyObject->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MyObject->val_name('iip'), 227, 'val_name() inherited iip 8'); is(MySubObject->hval_name_exists('iip'), 0, 'hval_name_exists() inherited iip 3'); is(MySubObject->hval_name('iip'), undef, 'hval_name() inherited iip 5'); is(MySubObject2->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MySubObject2->hval_name('iip'), 227, 'hval_name() inherited iip 6'); is(MySubObject3->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MySubObject3->hval_name('iip'), 227, 'hval_name() inherited iip 7'); is(MyObject->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MyObject->hval_name('iip'), 227, 'hval_name() inherited iip 8'); MySubObject->inherit_val_name('iip'); is(MySubObject->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject->val_name('iip'), 227, 'val_name() inherited iip 9'); is(MySubObject2->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject2->val_name('iip'), 227, 'val_name() inherited iip 10'); is(MySubObject3->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MySubObject3->val_name('iip'), 227, 'val_name() inherited iip 11'); is(MyObject->val_name_exists('iip'), 1, 'val_name_exists() inherited iip 3'); is(MyObject->val_name('iip'), 227, 'val_name() inherited iip 12'); is(MySubObject->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MySubObject->hval_name('iip'), 227, 'hval_name() inherited iip 9'); is(MySubObject2->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MySubObject2->hval_name('iip'), 227, 'hval_name() inherited iip 10'); is(MySubObject3->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MySubObject3->hval_name('iip'), 227, 'hval_name() inherited iip 11'); is(MyObject->hval_name_exists('iip'), 1, 'hval_name_exists() inherited iip 3'); is(MyObject->hval_name('iip'), 227, 'hval_name() inherited iip 12'); INHERITED_HASH_POD_CHECK: { package MyClass; use Rose::Class::MakeMethods::Generic ( inherited_hash => [ pet_color => { keys_method => 'pets', delete_implies => 'delete_special_pet_color', inherit_implies => 'inherit_special_pet_color', }, special_pet_color => { keys_method => 'special_pets', add_implies => 'add_pet_color', }, ], ); package main; my $i = 1; MyClass->pet_colors(Fido => 'white', Max => 'black', Spot => 'yellow'); MyClass->special_pet_color(Toby => 'tan'); is(join(', ', sort MyClass->pets), 'Fido, Max, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MyClass->special_pets), 'Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->pets), 'Fido, Max, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MyClass->pet_color('Toby')), 'tan', 'inherited_hash pod ' . $i++); MySubClass->special_pet_color(Toby => 'gold'); is(join(', ', sort MyClass->pet_color('Toby')), 'tan', 'inherited_hash pod ' . $i++); is(join(', ', sort MyClass->special_pet_color('Toby')), 'tan', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->pet_color('Toby')), 'gold', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->special_pet_color('Toby')), 'gold', 'inherited_hash pod ' . $i++); MySubClass->inherit_pet_color('Toby'); is(join(', ', sort MySubClass->pet_color('Toby')), 'tan', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->special_pet_color('Toby')), 'tan', 'inherited_hash pod ' . $i++); MyClass->delete_pet_color('Max'); is(join(', ', sort MyClass->pets), 'Fido, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->pets), 'Fido, Spot, Toby', 'inherited_hash pod ' . $i++); MyClass->special_pet_color(Max => 'mauve'); is(join(', ', sort MyClass->pets), 'Fido, Max, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->pets), 'Fido, Max, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MyClass->special_pets), 'Max, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->special_pets), 'Max, Toby', 'inherited_hash pod ' . $i++); MySubClass->delete_special_pet_color('Max'); is(join(', ', sort MyClass->pets), 'Fido, Max, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->pets), 'Fido, Max, Spot, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MyClass->special_pets), 'Max, Toby', 'inherited_hash pod ' . $i++); is(join(', ', sort MySubClass->special_pets), 'Toby', 'inherited_hash pod ' . $i++); } BEGIN { use Test::More(); package Person; use strict; @Person::ISA = qw(Rose::Object); use Rose::Object::MakeMethods::Generic ( 'boolean' => 'is_foo', 'boolean --get_set_init' => [ 'is_def_foo', ], 'boolean' => [ is_valid => { default => 1 }, ], 'boolean --default=0' => 'def0', 'scalar' => 'bar', 'scalar --get_set_init' => [ qw(type) ], hash => [ param => { hash_key => 'params' }, params => { interface => 'get_set_all' }, param_names => { interface => 'keys', hash_key => 'params' }, param_values => { interface => 'values', hash_key => 'params' }, param_exists => { interface => 'exists', hash_key => 'params' }, delete_param => { interface => 'delete', hash_key => 'params' }, clear_params => { interface => 'clear', hash_key => 'params' }, reset_params => { interface => 'reset', hash_key => 'params' }, iparams => { interface => 'get_set_init' }, reset_iparams => { interface => 'reset', hash_key => 'iparams' }, clear_iparams => { interface => 'clear', hash_key => 'iparams' }, idparams => { interface => 'get_set_inited' }, clear_idparams => { interface => 'clear', hash_key => 'idparams' }, reset_idparams => { interface => 'reset', hash_key => 'idparams' }, fhash => { interface => 'get_set_init_all' }, ], array => 'jobs', array => [ job => { interface => 'get_set_item', hash_key => 'jobs' }, clear_jobs => { interface => 'clear', hash_key => 'jobs' }, push_jobs => { interface => 'push', hash_key => 'jobs' }, pop_jobs => { interface => 'pop', hash_key => 'jobs' }, unshift_jobs => { interface => 'unshift', hash_key => 'jobs' }, shift_jobs => { interface => 'shift', hash_key => 'jobs' }, ], array => [ nicknames => { interface => 'get_set_init' }, idnicknames => { interface => 'get_set_inited' }, ], ); SKIP: { eval { require Rose::DateTime::Util }; if($@) { Test::More::skip('loading Rose::Object::MakeMethods::DateTime', 1); } else { Test::More::use_ok('Rose::Object::MakeMethods::DateTime'); eval " use Rose::Object::MakeMethods::DateTime ( datetime => [ 'birthday' ], datetime => [ birthday_floating => { tz => 'floating' } ], 'datetime --get_set_init' => 'arrival', 'datetime --get_set_init' => [ 'departure' => { tz => 'floating' } ], ); "; } } sub init_fhash { { a => 1, b => 2 } } sub init_arrival { '1/24/1984 1:10pm' } sub init_departure { DateTime->new(month => 1, day => 30, year => 2000, time_zone => 'UTC') } sub init_is_def_foo { 123 } sub init_type { 'default' } sub init_nicknames { [ qw(wiley joe) ] } sub init_iparams { { a => 1, b => 2 } } package MyObject; use Rose::Class::MakeMethods::Generic ( 'inheritable_scalar' => 'name', 'inheritable_boolean' => 'bool', scalar => [ 'flub', 'class_type' => { interface => 'get_set_init' }, ], hash => [ cparam => { hash_key => 'cparams' }, cparams => { interface => 'get_set_all' }, cparam_names => { interface => 'keys', hash_key => 'cparams' }, cparam_values => { interface => 'values', hash_key => 'cparams' }, cparam_exists => { interface => 'exists', hash_key => 'cparams' }, delete_cparam => { interface => 'delete', hash_key => 'cparams' }, clear_cparams => { interface => 'clear', hash_key => 'cparams' }, ], inheritable_hash => [ icparam => { hash_key => 'icparams' }, icparams => { interface => 'get_set_all' }, icparam_names => { interface => 'keys', hash_key => 'icparams' }, icparam_values => { interface => 'values', hash_key => 'icparams' }, icparam_exists => { interface => 'exists', hash_key => 'icparams' }, delete_icparam => { interface => 'delete', hash_key => 'icparams' }, clear_icparams => { interface => 'clear', hash_key => 'icparams' }, reset_icparams => { interface => 'reset', hash_key => 'icparams' }, ], inherited_hash => [ val_name => { exists_method => 'val_name_exists', delete_implies => 'delete_hval_name', inherit_implies => 'inherit_hval_name', }, hval_name => { add_implies => 'add_val_name', exists_method => 'hval_name_exists', }, ], ); sub init_class_type { 'wacky' } use Rose::Class::MakeMethods::Set ( 'inheritable_set --add_implies=nonesuch' => [ required_name => { add_implies => 'add_valid_name', test_method => 'name_is_required', }, ], inheritable_set => 'inheritable_item', inherited_set => [ valid_name => { test_method => 'name_is_valid', delete_implies => 'delete_happy_name', inherit_implies => 'inherit_happy_name', }, happy_name => { add_implies => 'add_valid_name', test_method => 'name_is_happy', }, ], ); MyObject->add_inheritable_items(qw(abase bbase)); package MySubObject; our @ISA = qw(MyObject); sub init_class_type { 'subwacky' } package MySubObject2; our @ISA = qw(MyObject); package MySubObject3; our @ISA = qw(MySubObject2); package MySubObject4; our @ISA = qw(MySubObject3); } Rose-Object-0.860/t/pod.t000755 000765 000120 00000000253 11065306641 015145 0ustar00johnadmin000000 000000 #!/usr/bin/perl -w use strict; use Test::More; eval 'use Test::Pod 1.00'; plan(skip_all => 'Test::Pod 1.00 required for testing POD') if($@); all_pod_files_ok(); Rose-Object-0.860/t/redefine.t000755 000765 000120 00000000723 10760063556 016154 0ustar00johnadmin000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 2; use FindBin qw($Bin); use lib "t/lib"; use Person1; delete $INC{'Person1.pm'}; eval { require Person1 }; print $@ if($@); ok(!$@, 'redefine 1'); eval { require Rose::DateTime::Util }; SKIP: { if($@) { skip("datetime tests: could not load Rose::DateTime::Util", 1); } require Person2; delete $INC{'Person2.pm'}; eval { require Person2 }; print $@ if($@); ok(!$@, 'redefine 2'); } Rose-Object-0.860/t/lib/Person1.pm000755 000765 000120 00000000222 10760063556 016633 0ustar00johnadmin000000 000000 package Person; use strict; use Rose::Object; our @ISA = qw(Rose::Object); use Rose::Object::MakeMethods::Generic ( scalar => 'name', ); 1; Rose-Object-0.860/t/lib/Person2.pm000755 000765 000120 00000000225 10760063556 016637 0ustar00johnadmin000000 000000 package Person; use strict; use Rose::Object; our @ISA = qw(Rose::Object); use Rose::Object::MakeMethods::DateTime ( datetime => 'bday', ); 1; Rose-Object-0.860/lib/Rose/000750 000765 000120 00000000000 12223410705 015373 5ustar00johnadmin000000 000000 Rose-Object-0.860/lib/Rose/Class/000750 000765 000120 00000000000 12223410705 016440 5ustar00johnadmin000000 000000 Rose-Object-0.860/lib/Rose/Class.pm000755 000765 000120 00000002512 11456611342 017015 0ustar00johnadmin000000 000000 package Rose::Class; use strict; our $VERSION = '0.81'; use Rose::Class::MakeMethods::Generic ( scalar => 'error', ); 1; __END__ =head1 NAME Rose::Class - A very simple class base class. =head1 SYNOPSIS package MyClass; use Rose::Class; our @ISA = qw(Rose::Class); sub foo { ... } ... MyClass->foo(...) or die MyClass->error; ... =head1 DESCRIPTION L is a generic base class for classes. It provides a single class method (C), but may be expanded further in the future. A class that inherits from L is not expected to allow objects of that class to be instantiated, since the namespace for class and object methods is shared. For example, it is common for L-derived classes to have C methods, but this would conflict with the L method of the same name. =head1 CLASS METHODS =over 4 =item B Get or set the class-wide error. By convention, this should be a scalar that stringifies to an error message. A simple scalar containing a string is the most commonly used value. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Object/000750 000765 000120 00000000000 12223410705 016601 5ustar00johnadmin000000 000000 Rose-Object-0.860/lib/Rose/Object.pm000755 000765 000120 00000002720 12223410576 017156 0ustar00johnadmin000000 000000 package Rose::Object; use strict; our $VERSION = '0.860'; sub new { my($class) = shift; my $self = bless {}, $class; $self->init(@_); return $self; } sub init { my($self) = shift; while(@_) { my $method = shift; $self->$method(shift); } } 1; __END__ =head1 NAME Rose::Object - A simple object base class. =head1 SYNOPSIS package MyObject; use Rose::Object; our @ISA = qw(Rose::Object); sub foo { ... } sub bar { ... } ... my $o = MyObject->new(foo => 'abc', bar => 5); ... =head1 DESCRIPTION L is a generic object base class. It provides very little functionality, but a healthy dose of convention. =head1 METHODS =over 4 =item B Constructs a new, empty, hash-based object based on PARAMS, where PARAMS are name/value pairs, and then calls L (see below), passing PARAMS to it unmodified. =item B Given a list of name/value pairs in PARAMS, calls the object method of each name, passing the corresponding value as an argument. The methods are called in the order that they appear in PARAMS. For example: $o->init(foo => 1, bar => 2); is equivalent to the sequence: $o->foo(1); $o->bar(2); =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Object/MakeMethods/000750 000765 000120 00000000000 12223410705 021002 5ustar00johnadmin000000 000000 Rose-Object-0.860/lib/Rose/Object/MakeMethods.pm000755 000765 000120 00000051554 11467037742 021401 0ustar00johnadmin000000 000000 package Rose::Object::MakeMethods; use strict; use Carp(); our $VERSION = '0.856'; __PACKAGE__->allow_apparent_reload(1); our %Made_Method_Custom; sub import { my($class) = shift; return 1 unless(@_); my($options, $args) = $class->_normalize_args(@_); $options->{'target_class'} ||= (caller)[0]; $class->make_methods($options, $args); return 1; } sub make_methods { my($class) = shift; my($options, $args) = $class->_normalize_args(@_); $options->{'target_class'} ||= (caller)[0]; #use Data::Dumper; #print STDERR Dumper($options); #print STDERR Dumper($args); while(@$args) { $class->__make_methods($options, shift(@$args), shift(@$args)); } return 1; } # Can't use the class method maker easily here due to a chicken/egg # situation, so this code is manually inlined. my %Inheritable_Scalar; sub allow_apparent_reload { my($class) = ref($_[0]) ? ref(shift) : shift; if(@_) { return $Inheritable_Scalar{$class}{'allow_apparent_reload'} = shift; } return $Inheritable_Scalar{$class}{'allow_apparent_reload'} if(exists $Inheritable_Scalar{$class}{'allow_apparent_reload'}); my @parents = ($class); while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $subclass (@{$parent . '::ISA'}) { push(@parents, $subclass); if(exists $Inheritable_Scalar{$subclass}{'allow_apparent_reload'}) { return $Inheritable_Scalar{$subclass}{'allow_apparent_reload'} } } } return undef; } # XXX: This nasty hack should be unneeded now and will probably # XXX: be removed some time in the future. our $Preserve_Existing = 0; sub __make_methods { my($class) = shift; #my $options; #if(ref $_[0] eq 'HASH') #{ # $options = shift; #} #else { $options = {} } #$options->{'target_class'} ||= (caller)[0]; my $options = shift; my $method_type = shift; my $methods = shift; my $target_class = $options->{'target_class'}; while(@$methods) { my $method_name = shift(@$methods); my $method_args = shift(@$methods); my $make = $class->$method_type($method_name => $method_args, $options ||= {}); Carp::croak "${class}::method_type(...) didn't return a hash ref!" unless(ref $make eq 'HASH'); no strict 'refs'; METHOD: while(my($name, $code) = each(%$make)) { Carp::croak "${class}::method_type(...) - key for $name is not a code ref!" unless(ref $code eq 'CODE' || (ref $code eq 'HASH' && $code->{'make_method'})); if(my $code = $target_class->can($name)) { if($options->{'preserve_existing'} || $Preserve_Existing) { next METHOD; } unless($options->{'override_existing'}) { if($class->allow_apparent_reload && $class->apparently_made_method($code)) { next METHOD; } Carp::croak "Cannot create method ${target_class}::$name - method already exists"; } } no warnings; if(ref $code eq 'CODE') { *{"${target_class}::$name"} = $code; } else { # XXX: Must track these separately because they do not show up as # XXX: being named __ANON__ when fetching the sub_identity() $Made_Method_Custom{$target_class}{$name}++; $code->{'make_method'}($name, $target_class, $options); } } } return 1; } sub apparently_made_method { my($class, $code) = @_; my($mm_class, $name) = $class->sub_identity($code); return 0 unless($class && $name); # XXX: RT 54444 - The formerly constant "__ANON__" sub name looks # XXX: like this in newer versions of perl when running under the # XXX: debugger: "__ANON__[/usr/lib/perl5/.../Some/Module.pm:123]" return (($mm_class eq $class && $name =~ /^__ANON__/) || $Made_Method_Custom{$mm_class}{$name}) ? 1 : 0; } # Code from Sub::Identify sub sub_identity { my($class, $code) = @_; my @id; TRY: { local $@; eval # if this fails, the identity is undefined { require B; my $cv = B::svref_2object($code); return unless($cv->isa('B::CV')); @id = ($cv->GV->STASH->NAME, $cv->GV->NAME); }; # Ignore errors } return @id; } # Given the example method types "bitfield" and "scalar", _normalize_args() # takes args in any of these forms: # # { ... }, # Class options (optionally) go here # # scalar => 'foo', # # 'bitfield --opt' => [ 'a', 'b' ], # # 'scalar --opt2=blah' => [ 'foo' => { opt => 4, opt2 => 'blee' } ], # # scalar => [ 'a' => { default => 5 }, 'b' ], # # bitfield => # [ # bar => { size => 8 }, # baz => { size => 5, default => '00011' }, # ], # # and returns an options hashref (possibly empty) and a reference # to an array that is normalized to look like this: # # [ # [ # 'scalar' => [ 'foo' => {} ], # # 'bitfield' => # [ # 'a' => { opt => 1 }, # 'b' => { opt => 1 } # ], # # 'scalar' => [ 'foo' => { 'opt' => 4, 'opt2' => 'blee' } ], # # 'scalar'=> # [ # 'a' => { 'default' => 5 }, # 'b' => {} # ], # # 'bitfield' => # [ # 'bar' => { 'size' => 8 }, # 'baz' => { 'default' => '00011', 'size' => 5 } # ] # ] # ] sub _normalize_args { my($class) = shift; my $i = 0; my(@normalized_args, $options); while(@_) { my $method_type = shift || last; if(ref $method_type) { if(ref $method_type eq 'HASH') { Carp::croak "Options hash ref provided more than once" if($options); $options = $method_type; next; } elsif(ref $method_type eq 'ARRAY') { unshift(@_, @$method_type); next; } } my %method_options; my $i = 0; while($method_type =~ s/\s+--(\w+)(?:=(\w+))?//) { if($i++ || defined $2) { $method_options{$1} = $2; } else { $method_options{'interface'} = $1; } } push(@normalized_args, $method_type); my $args = shift; if(!ref $args) { $args = [ $args ]; } elsif(ref $args ne 'ARRAY') { Carp::croak "Bad invocation of Rose::Object::MakeMethods"; } my @method_args; while(@$args) { my $method_name = shift(@$args); if(ref $args->[0]) { unless(ref $args->[0] eq 'HASH') { Carp::croak "Expected hash ref or scalar after method name, but found $args->[0]"; } push(@method_args, $method_name => { %method_options, %{shift(@$args)} }); } else { push(@method_args, $method_name => { %method_options }); } } push(@normalized_args, \@method_args); } return($options || {}, \@normalized_args); } 1; __END__ =head1 NAME Rose::Object::MakeMethods - A simple method maker base class. =head1 SYNOPSIS package MyMethodMaker; use Rose::Object::MakeMethods; our @ISA = qw(Rose::Object::MakeMethods); sub widget { my($class, $name, $args) = @_; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; my %methods; if($interface =~ /^get_set/) { $methods{$name} = sub { my($self) = shift; if(@_) { ... } ... return $self->{$key}; }; } if($interface eq 'get_set_delete') { $methods{"delete_$name"} = sub { ... }; ) return \%methods; } ... package MyObject; sub new { ... } use MyMethodMaker ( 'widget --get_set_delete' => 'foo', 'widget' => [ 'bar', 'baz', ] ); ... $o = MyObject->new; $o->foo($bar); $o->delete_foo(); print $o->bar . $o->baz; ... =head1 DESCRIPTION L is the base class for a family of method makers. A method maker is a module that's used to define methods in other packages. The actual method makers are subclasses of L that define the names and options of the different kinds of methods that they can make. There are method makers that make both object methods and class methods. The object method makers are in the C namespace. The class method makers are in the C namespace for the sake of clarity, but still inherit from L and therefore share the same method making interface. Several useful method makers are included under the C and C namespaces, mostly for use by other C objects and classes. This family of modules is not as powerful or flexible as the one that inspired it: L. I found that I was only using a tiny corner of the functionality provided by L, so I wrote this as a simple, smaller replacement. The fact that many C modules use L subclasses to make their methods should be considered an implementation detail that can change at any time. =head1 CLASS METHODS =over 4 =item B Get or set an attribute that determines whether or not to allow an attempt to re-make the same method using the same class that made it earlier. The default is true. This issue comes up when a module is forcibly reloaded, e.g., by L or L. When this happens, all the "make methods" actions will be attempted again. In the absence of the C or C options, the L attribute will be consulted. If it's true, and if it appears that the method in question was made by this method-maker class, then it behaves as if the C option had been passed. If it is false, then a fatal "method redefined" error will occur. =item B The C class method is mean to be called implicitly as a result of a C statement. For example: use Rose::Object::MakeMethods::Generic ( SPEC ); is roughly equivalent to: require Rose::Object::MakeMethods::Generic; Rose::Object::MakeMethods::Generic->import(SPEC); where SPEC is a series of specifications for the methods to be created. (But don't call L explicitly; use L instead.) In response to each method specification, one or more methods are created. The first part of the SPEC argument is an optional hash reference whose contents are intended to modify the behavior of the method maker class itself, rather than the individual methods being made. There are currently only two valid arguments for this hash: =over 4 =item B Specifies that class that the methods will be added to. Defaults to the class from which the call was made. For example, this: use Rose::Object::MakeMethods::Generic ( { target_class => 'Foo' }, ... ); Is equivalent to this: package Foo; use Rose::Object::MakeMethods::Generic ( ... ); In general, the C argument is omitted since methods are usually indented to end up in the class of the caller. =item B By default, attempting to create a method that already exists will result in a fatal error. But if the C option is set to a true value, the existing method will be replaced with the generated method. =item B By default, attempting to create a method that already exists will result in a fatal error. But if the C option is set to a true value, the existing method will be left unmodified. This option takes precedence over the C option. =back After the optional hash reference full off options intended for the method maker class itself, a series of method specifications should be provided. Each method specification defines one or more named methods. The components of such a specification are: =over 4 =item * The Method Type This is the name of the subroutine that will be called in order to generated the methods (see SUBCLASSING for more information). It describes the nature of the generated method. For example, "scalar", "array", "bitfield", "object" =item * Method Type Arguments Name/value pairs that are passed to the method maker of the specified type in order to modify its behavior. =item * Method Names One or more names for the methods that are to be created. Note that a method maker of a particular type may choose to modify or ignore these names. In the common case, for each method name argument, a single method is created with the same name as the method name argument. =back Given the method type C and the method arguments C and C, the following examples show all valid forms for method specifications, with equivalent forms grouped together. Create a bitfield method named C: bitfield => 'my_bits' bitfield => [ 'my_bits' ], bitfield => [ 'my_bits' => {} ], Create a bitfield method named C, passing the C argument with a value of 2. 'bitfield --opt1=2' => 'my_bits' 'bitfield --opt1=2' => [ 'my_bits' ] bitfield => [ 'my_bits' => { opt1 => 2 } ] Create a bitfield method named C, passing the C argument with a value of 2 and the C argument with a value of 7. 'bitfield --opt1=2 --opt2=7' => 'my_bits' 'bitfield --opt1=2 --opt2=7' => [ 'my_bits' ] bitfield => [ 'my_bits' => { opt1 => 2, opt2 => 7 } ] 'bitfield --opt2=7' => [ 'my_bits' => { opt1 => 2 } ] In the case of a conflict between the options specified with the C<--name=value> syntax and those provided in the hash reference, the ones in the hash reference take precedence. For example, these are equivalent: 'bitfield --opt1=99' => 'my_bits' 'bitfield --opt1=5' => [ 'my_bits' => { opt1 => 99 } ] If no value is provided for the first option, and if it is specified using the C<--name> syntax, then it is taken as the I of the C option. That is, this: 'bitfield --foobar' => 'my_bits' is equivalent to these: 'bitfield --interface=foobar' => 'my_bits' bitfield => [ my_bits => { interface => 'foobar' } ] This shortcut supports the convention that the C option is used to decide which set of methods to create. But it's just a convention; the C option is no different from any of the other options when it is eventually passed to the method maker of a given type. Any option other than the very first that is specified using the C<--name> form and that lacks an explicit value is simply set to 1. That is, this: 'bitfield --foobar --baz' => 'my_bits' is equivalent to these: 'bitfield --interface=foobar --baz=1' => 'my_bits' bitfield => [ my_bits => { interface => 'foobar', baz => 1 } ] Multiple method names can be specified simultaneously for a given method type and set of options. For example, to create methods named C, all of the same type and with the same options, any of these would work: 'bitfield --opt1=2' => [ 'my_bits1', 'my_bits2', 'my_bits3', ] bitfield => [ 'my_bits1' => { opt1 => 2 }, 'my_bits2' => { opt1 => 2 }, 'my_bits3' => { opt1 => 2 }, ] When options are provided using the C<--name=value> format, they apply to all methods listed inside the array reference, unless overridden. Here's an example of an override: 'bitfield --opt1=2' => [ 'my_bits1', 'my_bits2', 'my_bits3' => { opt1 => 999 }, ] In this case, C and C use C values of 2, but C uses an C value of 999. Also note that it's okay to mix bare method names (C and C) with method names that have associated hash reference options (C), all inside the same array reference. Finally, putting it all together, here's a full example using several different formats. use Rose::Object::MakeMethods::Generic ( { override_existing => 1 }, 'bitfield' => [ qw(my_bits other_bits) ], 'bitfield --opt1=5' => [ 'a', 'b', ], 'bitfield' => [ 'c', 'd' => { opt2 => 7 }, 'e' => { opt1 => 1 }, 'f' => { }, # empty is okay too ] ); In the documentation for the various L subclasses, any of the valid forms may be used in the examples. =item B This method is equivalent to the C method, but makes the intent of the code clearer when it is called explicitly. (The C method is only meant to be called implicitly by C.) =back =head1 SUBCLASSING In order to make a L subclass that can actually make some methods, simply subclass L and define one subroutine for each method type you want to support. The subroutine will be passed three arguments when it is called: =over 4 =item * The class of the method maker as a string. This argument is usually ignored unless you are going to call some other class method. =item * The method name. In the common case, a single method with this name is defined, but you are free to do whatever you want with it, including ignoring it. =item * A reference to a hash containing the options for the method. =back The subroutine is expected to return a reference to a hash containing name/code reference pairs. Note that the subroutine does not actually install the methods. It simple returns the name of each method that is to be installed, along with references to the closures that contain the code for those methods. This subroutine is called for each I in the method specifier. For example, this would result in three separate calls to the C subroutine of the C class: use MyMethodMaker ( bitfield => [ 'my_bits', 'your_bits' => { size => 32 }, 'other_bits' => { size => 128 }, ] ); So why not have the subroutine return a single code reference rather than a reference to a hash of name.code reference pairs? There are two reasons. First, remember that the name argument ("my_bits", "your_bits", "other_bits") may be modified or ignored by the method maker. The actual names of the methods created are determined by the keys of the hash reference returned by the subroutine. Second, a single call with a single method name argument may result in the creation more than one method--usually a "family" of methods. For example: package MyObject; use MyMethodMaker ( # creates add_book(), delete_book(), and books() methods 'hash --manip' => 'book', ); ... $o = MyObject->new(...); $o->add_book($book); print join("\n", map { $_->title } $o->books); $o->delete_book($book); Here, the C method type elected to create three methods by prepending C and C and appending C to the supplied method name argument, C. Anything not specified in this documentation is simply a matter of convention. For example, the L subclasses all use a common set of method options: C, C, etc. As you read their documentation, this will become apparent. Finally, here's an example of a subclass that makes scalar accessors: package Rose::Object::MakeMethods::Generic; use strict; use Carp(); use Rose::Object::MakeMethods; our @ISA = qw(Rose::Object::MakeMethods); sub scalar { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { return $_[0]->{$key} = $_[1] if(@_ > 1); return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = $_[0]->$init_method()); } } elsif($interface eq 'get_set') { $methods{$name} = sub { return $_[0]->{$key} = $_[1] if(@_ > 1); return $_[0]->{$key}; } } else { Carp::croak "Unknown interface: $interface" } return \%methods; } It can be used like this: package MyObject; use Rose::Object::MakeMethods::Generic ( scalar => [ 'power', 'error', ], 'scalar --get_set_init' => 'name', ); sub init_name { 'Fred' } ... $o = MyObject->new(power => 5); print $o->name; # Fred $o->power(99) or die $o->error; This is actually a subset of the code in the actual L module. See the rest of the C and C modules for more examples. =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Object/MixIn.pm000755 000765 000120 00000020720 11365606265 020212 0ustar00johnadmin000000 000000 package Rose::Object::MixIn; use strict; use Carp; our $Debug = 0; our $VERSION = '0.856'; use Rose::Class::MakeMethods::Set ( inheritable_set => [ '_export_tag' => { list_method => '_export_tags', clear_method => 'clear_export_tags', add_method => '_add_export_tag', delete_method => 'delete_export_tag', deletes_method => 'delete_export_tags', }, '_pre_import_hook', { clear_method => 'clear_pre_import_hooks', add_method => 'add_pre_import_hook', adds_method => 'add_pre_import_hooks', delete_method => 'delete_pre_import_hook', deletes_method => 'delete_pre_import_hooks', }, ], ); sub import { my($class) = shift; my $target_class = (caller)[0]; my($force, @methods, %import_as); foreach my $arg (@_) { if(!defined $target_class && $arg !~ /^-/) { $target_class = $arg; next; } if($arg =~ /^-?-force$/) { $force = 1; } elsif($arg =~ /^-?-target[-_]class$/) { $target_class = undef; # set on next iteration...lame next; } elsif($arg =~ /^:(.+)/) { my $methods = $class->export_tag($1) or croak "Unknown export tag - '$arg'"; push(@methods, @$methods); } elsif(ref $arg eq 'HASH') { while(my($method, $name) = each(%$arg)) { push(@methods, $method); $import_as{$method} = $name; } } else { push(@methods, $arg); } } foreach my $method (@methods) { my $code = $class->can($method) or croak "Could not import method '$method' from $class - no such method"; my $import_as = $import_as{$method} || $method; if($target_class->can($import_as) && !$force) { croak "Could not import method '$import_as' from $class into ", "$target_class - a method by that name already exists. ", "Pass a '-force' argument to import() to override ", "existing methods." } if(my $hooks = $class->pre_import_hooks($method)) { foreach my $code (@$hooks) { my $error; TRY: { local $@; eval { $code->($class, $method, $target_class, $import_as) }; $error = $@; } if($error) { croak "Could not import method '$import_as' from $class into ", "$target_class - $error"; } } } no strict 'refs'; $Debug && warn "${target_class}::$import_as = ${class}->$method\n"; *{$target_class . '::' . $import_as} = $code; } } sub export_tag { my($class, $tag) = (shift, shift); if(index($tag, ':') == 0) { croak 'Tag name arguments to export_tag() should not begin with ":"'; } if(@_ && !$class->_export_tag_value($tag)) { $class->_add_export_tag($tag); } if(@_ && (@_ > 1 || (ref $_[0] || '') ne 'ARRAY')) { croak 'export_tag() expects either a single tag name argument, ', 'or a tag name and a reference to an array of method names'; } my $ret = $class->_export_tag_value($tag, @_); croak "No such tag: $tag" unless($ret); return wantarray ? @$ret : $ret; } sub export_tags { my($class) = shift; return $class->_export_tags unless(@_); $class->clear_export_tags; $class->add_export_tags(@_); } sub add_export_tags { my($class) = shift; while(@_) { my($tag, $arg) = (shift, shift); $class->export_tag($tag, $arg); } } sub pre_import_hook { my($class, $method) = (shift, shift); if(@_ && !$class->_pre_import_hook_value($method)) { $class->add_pre_import_hook($method); } if(@_ && (@_ > 1 || (ref $_[0] && (ref $_[0] || '') !~ /\A(?:ARRAY|CODE)\z/))) { croak 'pre_import_hook() expects either a single method name argument, ', 'or a method name and a code reference or a reference to an array ', 'of code references'; } if(@_) { unless(ref $_[0] eq 'ARRAY') { $_[0] = [ $_[0] ]; } } my $ret = $class->_pre_import_hook_value($method, @_) || []; return wantarray ? @$ret : $ret; } sub pre_import_hooks { shift->pre_import_hook(shift) } 1; __END__ =head1 NAME Rose::Object::MixIn - A base class for mix-ins. =head1 SYNOPSIS package MyMixInClass; use Rose::Object::MixIn(); # Use empty parentheses here our @ISA = qw(Rose::Object::MixIn); __PACKAGE__->export_tag(all => [ qw(my_cool_method my_other_method) ]); sub my_cool_method { ... } sub my_other_method { ... } ... package MyClass; # Import methods my_cool_method() and my_other_method() use MyMixInClass qw(:all); ... package MyOtherClass; # Import just my_cool_method() use MyMixInClass qw(my_cool_method); ... package YetAnotherClass; # Import just my_cool_method() as cool() use MyMixInClass { my_cool_method => 'cool' } =head1 DESCRIPTION L is a base class for mix-ins. A mix-in is a class that exports methods into another class. This export process is controlled with an L-like interface, but L does not inherit from L. When you L a L-derived class, its L method is called at compile time. In other words, this: use Rose::Object::MixIn 'a', 'b', { c => 'd' }; is the same thing as this: BEGIN { Rose::Object::MixIn->import('a', 'b', { c => 'd' }) } To prevent the L method from being run, put empty parentheses "()" after the package name instead of a list of arguments. use Rose::Object::MixIn(); See the L for an example of when this is handy: using L from within a subclass. Note that the empty parenthesis are important. The following is I equivalent: # This is not the same thing as the example above! use Rose::Object::MixIn; See the documentation for the L method below to learn what arguments it accepts. =head1 CLASS METHODS =over 4 =item B Import the methods specified by ARGS into the package from which this method was called. If the current class L already perform one of these methods, a fatal error will occur. To override an existing method, you must use the C<-force> argument (see below). Valid formats for ARGS are as follows: =over 4 =item * B Literal method names will be imported as-is. =item * B Tags names are indicated with a leading colon. For example, ":all" specifies the "all" tag. A tag is a stand-in for a list of methods. See the L method to learn how to create tags. =item * B Each key/value pair in this hash contains a method name and the name that it will be imported as. Use this feature to import methods under different names in order to avoid conflicts with existing methods. =item * C<-force> The special literal argument C<-force> will cause the specified methods to be imported even if the calling class L already perform one or more of those methods. =item * C<-target_class CLASS> The special literal argument C<-target-class> followed by a class name will cause the specified methods to be imported into CLASS rather than into the calling class. =back See the L for several examples of the L method in action. (Remember, it's called implicitly when you L a L-derived class with anything other than an empty set of parenthesis "()" as an argument.) =item B Delete the entire list of L. =item B Get or set the list of method names associated with a tag. The tag name should I begin with a colon. If ARRAYREF is passed, then the list of methods associated with the specific tag is set. Returns a list (in list context) or a reference to an array (in scalar context) of method names. The array reference return value should be treated as read-only. If no such tag exists, and if an ARRAYREF is not passed, then a fatal error will occur. =item B Returns a list (in list context) and a reference to an array (in scalar context) containing the complete list of export tags. The array reference return value should be treated as read-only. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Object/MakeMethods/DateTime.pm000755 000765 000120 00000021313 11456611342 023053 0ustar00johnadmin000000 000000 package Rose::Object::MakeMethods::DateTime; use strict; use Carp(); our $VERSION = '0.81'; use Rose::Object::MakeMethods; our @ISA = qw(Rose::Object::MakeMethods); use Rose::DateTime::Util(); sub datetime { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; my $tz = $args->{'tz'}; if($interface eq 'get_set') { $methods{$name} = sub { my($self) = shift; if(@_) { if(@_ == 2) { if($_[0] eq 'format') { return Rose::DateTime::Util::format_date($self->{$key}, ((ref $_[1]) ? @{$_[1]} : $_[1])); } elsif($_[0] eq 'truncate') { return undef unless($self->{$key}); return $self->{$key} unless(ref $self->{$key}); return $self->{$key}->clone->truncate(to => $_[1]); } else { Carp::croak "Invalid arguments for $name attribute: @_" } } elsif(@_ > 1) { Carp::croak "Too many arguments for $name attribute: @_"; } $self->{$key} = Rose::DateTime::Util::parse_date($_[0], $tz || ()) or Carp::croak("Invalid date: '$_[0]'"); } return $self->{$key}; } } elsif($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { my($self) = shift; if(@_) { if(@_ == 2) { my $arg = $self->$init_method(); $self->{$key} = Rose::DateTime::Util::parse_date($arg, $tz || ()) or Carp::croak("Invalid date: '$arg'"); if($_[0] eq 'format') { return Rose::DateTime::Util::format_date($self->{$key}, ((ref $_[1]) ? @{$_[1]} : $_[1])); } elsif($_[0] eq 'truncate') { return undef unless($self->{$key}); return $self->{$key} unless(ref $self->{$key}); return $self->{$key}->clone->truncate(to => $_[1]); } else { Carp::croak "Invalid arguments for $name attribute: @_" } } elsif(@_ > 1) { Carp::croak "Too many arguments for $name attribute: @_"; } $self->{$key} = Rose::DateTime::Util::parse_date($_[0], $tz || ()) or Carp::croak("Invalid date: '$_[0]'"); } return $self->{$key} if(defined $self->{$key}); my $arg = $self->$init_method(); $self->{$key} = Rose::DateTime::Util::parse_date($arg, $tz || ()) or Carp::croak("Invalid date: '$arg'"); return $self->{$key}; } } else { Carp::croak "Unknown interface: $interface" } return \%methods; } 1; __END__ =head1 NAME Rose::Object::MakeMethods::DateTime - Create methods that store DateTime objects. =head1 SYNOPSIS package MyObject; use Rose::Object::MakeMethods::DateTime ( datetime => [ 'birthday', 'arrival' => { tz => 'UTC' } ], ); ... $obj = MyObject->new(birthday => '1/24/1984 1am'); $dt = $obj->birthday; # DateTime object $bday = $obj->birthday(format => '%B %E'); # 'January 24th' # Shortcut for $obj->birthday->clone->truncate(to => 'month'); $month = $obj->birthday(truncate => 'month'); $obj->birthday('blah'); # croaks - invalid date! $obj->birthday('1999-04-31'); # croaks - invalid date! =head1 DESCRIPTION L is a method maker that inherits from L. See the L documentation to learn about the interface. The method types provided by this module are described below. All methods work only with hash-based objects. =head1 METHODS TYPES =over 4 =item B Create get/set methods for scalar attributes that store L objects. =over 4 =item Options =over 4 =item C The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method. =item C The name of the method to call when initializing the value of an undefined attribute. This option is only applicable when using the C interface. Defaults to the method name with the prefix C added. This method should return a value that can be parsed by L's the L function. If the return value is a L object, it will have its time zone set (see the C option below) using L's L method. =item C Chooses one of the two possible interfaces. Defaults to C. =item C The time zone of the L object to be stored. If present, this value will be passed as the second argument to L's the L function when creating L objects for storage. If absent, L objects will use the default time zone of the L class, which is set by L's L class method. See the L documentation for more information. =back =item Interfaces =over 4 =item C Creates a get/set accessor method for an object attribute that stores a L object. When called with a single argument, the argument is passed through L's L function in order to create the L object that is stored. The current value of the attribute is returned. Passing a value that is not understood by L's L function causes a fatal error. When called with two arguments and the first argument is the string 'format', then the second argument is taken as a format specifier which is passed to L's L function. The formatted string is returned. In other words, this: $obj->birthday(format => '%m/%d/%Y'); Is just a shortcut for this: Rose::DateTime::Util::format_date($obj->birthday, '%m/%d/%Y'); When called with two arguments and the first argument is the string 'truncate', then the second argument is taken as a truncation specifier which is passed to L's L method called on a clone of the existing L object. The cloned, truncated L object is returned. In other words, this: $obj->birthday(truncate => 'month'); Is just a shortcut for this: $obj->birthday->clone->truncate(to => 'month'); Passing more than two arguments or passing two arguments where the first argument is not 'format' or 'truncate' will cause a fatal error. =item C Behaves like the C interface unless the value of the attribute is undefined. In that case, the method specified by the C option is called, the return value is passed through L's L function, and the attribute is set to the return value. An init method that returns a value that is not understood by L's L function will cause a fatal error. =back =back Example: package MyObject; use Rose::Object::MakeMethods::DateTime ( datetime => [ 'birthday', 'arrival' => { tz => 'UTC' } ], 'datetime --get_set_init' => [ 'departure' => { tz => 'UTC' } ], ); sub init_departure { DateTime->new(month => 1, day => 10, year => 2000, time_zone => 'America/Chicago'); } ... $obj = MyObject->new(birthday => '1/24/1984 1am'); $dt = $obj->birthday; # DateTime object $bday = $obj->birthday(format => '%B %E'); # 'January 24th' # Shortcut for $obj->birthday->clone->truncate(to => 'month'); $month = $obj->birthday(truncate => 'month'); $obj->birthday('blah'); # croaks - invalid date! $obj->birthday('1999-04-31'); # croaks - invalid date! # DateTime object with time zone set to UTC $dt = $obj->arrival('2005-21-01 4pm'); # DateTime object with time zone set to UTC, not America/Chicago! # Start with 2000-01-10T00:00:00 America/Chicago, # then set_time_zone('UTC'), # which results in: 2000-01-10T06:00:00 UTC $dt = $obj->departure; print $dt; # "2000-01-10T06:00:00" =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Object/MakeMethods/Generic.pm000755 000765 000120 00000070507 12223410563 022737 0ustar00johnadmin000000 000000 package Rose::Object::MakeMethods::Generic; use strict; use Carp(); our $VERSION = '0.859'; use Rose::Object::MakeMethods; our @ISA = qw(Rose::Object::MakeMethods); our $Have_CXSA; TRY: { local $@; eval { require Class::XSAccessor; (my $version = $Class::XSAccessor::VERSION) =~ s/_//g; unless($version >= 0.14) { die "Class::XSAccessor $Class::XSAccessor::VERSION is too old"; } }; $Have_CXSA = $@ ? 0 : 1; } our $Debug = 0; sub scalar { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { return $_[0]->{$key} = $_[1] if(@_ > 1); return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = $_[0]->$init_method()); } } elsif($interface eq 'get_set') { if($Have_CXSA && !$ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'}) { $methods{$name} = { make_method => sub { my($name, $target_class, $options) = @_; $Debug && warn "Class::XSAccessor make method ($name => $key) in $target_class\n"; Class::XSAccessor->import( accessors => { $name => $key }, class => $target_class, replace => $options->{'override_existing'} ? 1 : 0); }, }; } else { $methods{$name} = sub { return $_[0]->{$key} = $_[1] if(@_ > 1); return $_[0]->{$key}; } } } else { Carp::croak "Unknown interface: $interface" } return \%methods; } sub boolean { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { return $_[0]->{$key} = $_[1] ? 1 : 0 if(@_ > 1); return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = $_[0]->$init_method() ? 1 : 0); } } elsif($interface eq 'get_set') { if(exists $args->{'default'}) { if($args->{'default'}) { $methods{$name} = sub { return $_[0]->{$key} = $_[1] ? 1 : 0 if(@_ > 1); return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = 1) } } else { $methods{$name} = sub { return $_[0]->{$key} = $_[1] ? 1 : 0 if(@_ > 1); return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = 0) } } } else { $methods{$name} = sub { return $_[0]->{$key} = $_[1] ? 1 : 0 if(@_ > 1); return $_[0]->{$key}; } } } else { Carp::croak "Unknown interface: $interface" } return \%methods; } sub hash { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { my($self) = shift; # If called with no arguments, return hash contents unless(@_) { $self->{$key} = $self->$init_method() unless(defined $self->{$key}); return wantarray ? %{$self->{$key}} : $self->{$key}; } # If called with a hash ref, set value if(@_ == 1 && ref $_[0] eq 'HASH') { $self->{$key} = $_[0]; } else { # If called with an index, get that value, or a slice for array refs if(@_ == 1) { # Initialize hash if undefined $self->{$key} = $self->$init_method() unless(defined $self->{$key}); return ref $_[0] eq 'ARRAY' ? @{$self->{$key}}{@{$_[0]}} : $self->{$key}{$_[0]}; } # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $self->{$key}{$_} = shift; } } return wantarray ? %{$self->{$key}} : $self->{$key}; } } elsif($interface eq 'get_set_inited') { $methods{$name} = sub { my($self) = shift; # If called with no arguments, return hash contents unless(@_) { $self->{$key} = {} unless(defined $self->{$key}); return wantarray ? %{$self->{$key}} : $self->{$key}; } # If called with a hash ref, set value if(@_ == 1 && ref $_[0] eq 'HASH') { $self->{$key} = $_[0]; } else { # If called with an index, get that value, or a slice for array refs if(@_ == 1) { return ref $_[0] eq 'ARRAY' ? @{$self->{$key}}{@{$_[0]}} : $self->{$key}{$_[0]}; } # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $self->{$key}{$_} = shift; } } return wantarray ? %{$self->{$key}} : $self->{$key}; } } elsif($interface eq 'get_set_all') { $methods{$name} = sub { my($self) = shift; # If called with no arguments, return hash contents return wantarray ? %{$self->{$key}} : $self->{$key} unless(@_); # Set hash to arguments if(@_ == 1 && ref $_[0] eq 'HASH') { $self->{$key} = $_[0]; } else { # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); $self->{$key} = {}; while(@_) { local $_ = shift; $self->{$key}{$_} = shift; } } return wantarray ? %{$self->{$key}} : $self->{$key}; } } elsif($interface eq 'get_set_init_all') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { my($self) = shift; # If called with no arguments, return hash contents unless(@_) { $self->{$key} = $self->$init_method() unless(defined $self->{$key}); return wantarray ? %{$self->{$key}} : $self->{$key}; } # If called with no arguments, return hash contents return wantarray ? %{$self->{$key}} : $self->{$key} unless(@_); # Set hash to arguments if(@_ == 1 && ref $_[0] eq 'HASH') { $self->{$key} = $_[0]; } else { # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); $self->{$key} = {}; while(@_) { local $_ = shift; $self->{$key}{$_} = shift; } } return wantarray ? %{$self->{$key}} : $self->{$key}; } } elsif($interface eq 'clear') { $methods{$name} = sub { $_[0]->{$key} = {} } } elsif($interface eq 'reset') { $methods{$name} = sub { $_[0]->{$key} = undef; } } elsif($interface eq 'delete') { $methods{($interface eq 'manip' ? 'delete_' : '') . $name} = sub { Carp::croak "Missing key(s) to delete" unless(@_ > 1); delete @{shift->{$key}}{@_}; } } elsif($interface eq 'exists') { $methods{$name . ($interface eq 'manip' ? '_exists' : '')} = sub { Carp::croak "Missing key argument" unless(@_ == 2); defined $_[0]->{$key} ? exists $_[0]->{$key}{$_[1]} : undef; } } elsif($interface =~ /^(?:keys|names)$/) { $methods{$name} = sub { wantarray ? (defined $_[0]->{$key} ? keys %{$_[0]->{$key}} : ()) : (defined $_[0]->{$key} ? [ keys %{$_[0]->{$key}} ] : []); } } elsif($interface eq 'values') { $methods{$name} = sub { wantarray ? (defined $_[0]->{$key} ? values %{$_[0]->{$key}} : ()) : (defined $_[0]->{$key} ? [ values %{$_[0]->{$key}} ] : []); } } elsif($interface eq 'get_set') { $methods{$name} = sub { my($self) = shift; # If called with no arguments, return hash contents unless(@_) { return wantarray ? (defined $self->{$key} ? %{$self->{$key}} : ()) : $self->{$key} } # If called with a hash ref, set value if(@_ == 1 && ref $_[0] eq 'HASH') { $self->{$key} = $_[0]; } else { # If called with an index, get that value, or a slice for array refs if(@_ == 1) { return ref $_[0] eq 'ARRAY' ? @{$self->{$key}}{@{$_[0]}} : $self->{$key}{$_[0]}; } # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $self->{$key}{$_} = shift; } } return wantarray ? %{$self->{$key}} : $self->{$key}; }; } else { Carp::croak "Unknown interface: $interface" } return \%methods; } sub array { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { my($self) = shift; # If called with no arguments, return array contents unless(@_) { $self->{$key} = $self->$init_method() unless(defined $self->{$key}); return wantarray ? @{$self->{$key}} : $self->{$key}; } # If called with a array ref, set new value if(@_ == 1 && ref $_[0] eq 'ARRAY') { $self->{$key} = $_[0]; } else { $self->{$key} = [ @_ ]; } return wantarray ? @{$self->{$key}} : $self->{$key}; } } elsif($interface eq 'get_set_inited') { $methods{$name} = sub { my($self) = shift; # If called with no arguments, return array contents unless(@_) { $self->{$key} = [] unless(defined $self->{$key}); return wantarray ? @{$self->{$key}} : $self->{$key}; } # If called with a array ref, set new value if(@_ == 1 && ref $_[0] eq 'ARRAY') { $self->{$key} = $_[0]; } else { $self->{$key} = [ @_ ]; } return wantarray ? @{$self->{$key}} : $self->{$key}; } } elsif($interface eq 'get_set_item') { $methods{$name} = sub { my($self) = shift; Carp::croak "Missing array index" unless(@_); if(@_ == 2) { return $self->{$key}[$_[0]] = $_[1]; } else { return $self->{$key}[$_[0]] } } } elsif($interface eq 'unshift') { $methods{$name} = sub { my($self) = shift; Carp::croak "Missing value(s) to add" unless(@_); unshift(@{$self->{$key}}, (@_ == 1 && ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_); } } elsif($interface eq 'shift') { $methods{$name} = sub { my($self) = shift; return splice(@{$self->{$key}}, 0, $_[0]) if(@_); return shift(@{$self->{$key}}) } } elsif($interface eq 'clear') { $methods{$name} = sub { $_[0]->{$key} = [] } } elsif($interface eq 'reset') { $methods{$name} = sub { $_[0]->{$key} = undef; } } elsif($interface =~ /^(?:push|add)$/) { if(my $init_method = $args->{'init_method'}) { $methods{$name} = sub { my($self) = shift; Carp::croak "Missing value(s) to add" unless(@_); $self->{$key} = $self->$init_method() unless(defined $self->{$key}); push(@{$self->{$key}}, (@_ == 1 && ref $_[0] && ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_); } } else { $methods{$name} = sub { my($self) = shift; Carp::croak "Missing value(s) to add" unless(@_); push(@{$self->{$key}}, (@_ == 1 && ref $_[0] && ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_); } } } elsif($interface eq 'pop') { $methods{$name} = sub { my($self) = shift; return splice(@{$self->{$key}}, -$_[0]) if(@_); return pop(@{$self->{$key}}) } } elsif($interface eq 'get_set') { $methods{$name} = sub { my($self) = shift; # If called with no arguments, return array contents unless(@_) { return wantarray ? (defined $self->{$key} ? @{$self->{$key}} : ()) : $self->{$key} } # If called with a array ref, set new value if(@_ == 1 && ref $_[0] eq 'ARRAY') { $self->{$key} = $_[0]; } else { $self->{$key} = [ @_ ]; } return wantarray ? @{$self->{$key}} : $self->{$key}; } } else { Carp::croak "Unknown interface: $interface" } return \%methods; } 1; __END__ =head1 NAME Rose::Object::MakeMethods::Generic - Create simple object methods. =head1 SYNOPSIS package MyObject; use Rose::Object::MakeMethods::Generic ( scalar => [ 'power', 'error', ], 'scalar --get_set_init' => 'name', 'boolean --get_set_init' => 'is_tall', boolean => [ 'is_red', 'is_happy' => { default => 1 }, ], array => [ jobs => {}, job => { interface => 'get_set_item', hash_key => 'jobs' }, clear_jobs => { interface => 'clear', hash_key => 'jobs' }, reset_jobs => { interface => 'reset', hash_key => 'jobs' }, ], hash => [ param => { hash_key => 'params' }, params => { interface => 'get_set_all' }, param_names => { interface => 'keys', hash_key => 'params' }, param_values => { interface => 'values', hash_key => 'params' }, param_exists => { interface => 'exists', hash_key => 'params' }, delete_param => { interface => 'delete', hash_key => 'params' }, clear_params => { interface => 'clear', hash_key => 'params' }, reset_params => { interface => 'reset', hash_key => 'params' }, ], ); sub init_name { 'Fred' } sub init_is_tall { 1 } ... $obj = MyObject->new(power => 5); print $obj->name; # Fred $obj->do_something or die $obj->error; $obj->is_tall; # true $obj->is_tall(undef); # false (but defined) $obj->is_tall; # false (but defined) $obj->is_red; # undef $obj->is_red(1234); # true $obj->is_red(''); # false (but defined) $obj->is_red; # false (but defined) $obj->is_happy; # true $obj->params(a => 1, b => 2); # add pairs $val = $obj->param('b'); # 2 $obj->param_exists('x'); # false $obj->jobs('butcher', 'baker'); # add values $obj->job(0 => 'sailor'); # set value $job = $obj->job(0); # 'sailor' =head1 DESCRIPTION L is a method maker that inherits from L. See the L documentation to learn about the interface. The method types provided by this module are described below. All methods work only with hash-based objects. =head1 METHODS TYPES =over 4 =item B Create get/set methods for scalar attributes. =over 4 =item Options =over 4 =item C The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method. =item C The name of the method to call when initializing the value of an undefined attribute. This option is only applicable when using the C interface. Defaults to the method name with the prefix C added. =item C Choose one of the two possible interfaces. Defaults to C. =back =item Interfaces =over 4 =item C Creates a simple get/set accessor method for an object attribute. When called with an argument, the value of the attribute is set. The current value of the attribute is returned. =item C Behaves like the C interface unless the value of the attribute is undefined. In that case, the method specified by the C option is called and the attribute is set to the return value of that method. =back =back Example: package MyObject; use Rose::Object::MakeMethods::Generic ( scalar => 'power', 'scalar --get_set_init' => 'name', ); sub init_name { 'Fred' } ... $obj->power(99); # returns 99 $obj->name; # returns "Fred" $obj->name('Bill'); # returns "Bill" =item B Create get/set methods for boolean attributes. For each argument to these methods, the only thing that matters is whether it evaluates to true or false. The return value is either, true, false (but defined), or undef if the value has never been set. =over 4 =item Options =over 4 =item C Determines the default value of the attribute. This option is only applicable when using the C interface. =item C The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method. =item C The name of the method to call when initializing the value of an undefined attribute. Again, the only thing that matters about the return value of this method is whether or not it is true or false. This option is only applicable when using the C interface. Defaults to the method name with the prefix C added. =item C Choose one of the two possible interfaces. Defaults to C. =back =item Interfaces =over 4 =item C Creates a simple get/set accessor method for a boolean object attribute. When called with an argument, the value of the attribute is set to true if the argument evaluates to true, false (but defined) otherwise. The current value of the attribute is returned. If L version 0.14 or later is installed and the C environment variable is not set to a true value, then L will be used to generated the method. =item C Behaves like the C interface unless the value of the attribute is undefined. In that case, the method specified by the C option is called and the attribute is set based on the boolean value of the return value of that method. =back =back Example: package MyObject; use Rose::Object::MakeMethods::Generic ( 'boolean --get_set_init' => 'is_tall', boolean => [ 'is_red', 'is_happy' => { default => 1 }, ], ); sub init_is_tall { 'blah' } ... $obj->is_tall; # returns true $obj->is_tall(undef); # returns false (but defined) $obj->is_tall; # returns false (but defined) $obj->is_red; # returns undef $obj->is_red(1234); # returns true $obj->is_red(''); # returns false (but defined) $obj->is_red; # returns false (but defined) $obj->is_happy; # returns true =item B Create methods to manipulate hash attributes. =over 4 =item Options =over 4 =item C The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method. =item C The name of the method to call when initializing the value of an undefined hash attribute. This method should return a reference to a hash, and is only applicable when using the C interface. Defaults to the method name with the prefix C added. =item C Choose which interface to use. Defaults to C. =back =item Interfaces =over 4 =item C If called with no arguments, returns a list of key/value pairs in list context or a reference to the actual hash stored by the object in scalar context. If called with one argument, and that argument is a reference to a hash, that hash reference is used as the new value for the attribute. Returns a list of key/value pairs in list context or a reference to the actual hash stored by the object in scalar context. If called with one argument, and that argument is a reference to an array, then a list of the hash values for each key in the array is returned. If called with one argument, and it is not a reference to a hash or an array, then the hash value for that key is returned. If called with an even number of arguments, they are taken as name/value pairs and are added to the hash. It then returns a list of key/value pairs in list context or a reference to the actual hash stored by the object in scalar context. Passing an odd number of arguments greater than 1 causes a fatal error. =item C Behaves like the C interface unless the attribute is undefined. In that case, the method specified by the C option is called and the attribute is set to the return value of that method, which should be a reference to a hash. =item C Behaves like the C interface unless the attribute is undefined. In that case, it is initialized to an empty hash before proceeding as usual. =item C If called with no arguments, returns a list of key/value pairs in list context or a reference to the actual hash stored by the object in scalar context. If called with one argument, and that argument is a reference to a hash, that hash reference is used as the new value for the attribute. Returns a list of key/value pairs in list context or a reference to the actual hash stored by the object in scalar context. Otherwise, the hash is emptied and the arguments are taken as name/value pairs that are then added to the hash. It then returns a list of key/value pairs in list context or a reference to the actual hash stored by the object in scalar context. =item C Behaves like the C interface unless the attribute is undefined. In that case, the method specified by the C option is called and the attribute is set to the return value of that method, which should be a reference to a hash. =item C Sets the attribute to an empty hash. =item C Sets the attribute to undef. =item C Deletes the key(s) passed as arguments. Failure to pass any arguments causes a fatal error. =item C Returns true of the argument exists in the hash, false otherwise. Failure to pass an argument or passing more than one argument causes a fatal error. =item C Returns the keys of the hash in list context, or a reference to an array of the keys of the hash in scalar context. The keys are not sorted. =item C An alias for the C interface. =item C Returns the values of the hash in list context, or a reference to an array of the values of the hash in scalar context. The values are not sorted. =back =back Example: package MyObject; use Rose::Object::MakeMethods::Generic ( hash => [ param => { hash_key =>'params' }, params => { interface=>'get_set_all' }, param_names => { interface=>'keys', hash_key=>'params' }, param_values => { interface=>'values', hash_key=>'params' }, param_exists => { interface=>'exists', hash_key=>'params' }, delete_param => { interface=>'delete', hash_key=>'params' }, clear_params => { interface=>'clear', hash_key=>'params' }, reset_params => { interface=>'reset', hash_key=>'params' }, ], ); ... $obj = MyObject->new; $obj->params; # undef $obj->params(a => 1, b => 2); # add pairs $val = $obj->param('b'); # 2 %params = $obj->params; # copy hash keys and values $params = $obj->params; # get hash ref $obj->params({ c => 3, d => 4 }); # replace contents $obj->param_exists('a'); # false $keys = join(',', sort $obj->param_names); # 'c,d' $vals = join(',', sort $obj->param_values); # '3,4' $obj->delete_param('c'); $obj->param(f => 7, g => 8); $vals = join(',', sort $obj->param_values); # '4,7,8' $obj->clear_params; $params = $obj->params; # empty hash $obj->reset_params; $params = $obj->params; # undef =item B Create methods to manipulate array attributes. =over 4 =item Options =over 4 =item C The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method. =item C The name of the method to call when initializing the value of an undefined array attribute. This method should return a reference to an array. This option is only applicable when using the C, C, and C interfaces. When using the C interface, C defaults to the method name with the prefix C added. =item C Choose which interface to use. Defaults to C. =back =item Interfaces =over 4 =item C If called with no arguments, returns the array contents in list context or a reference to the actual array stored by the object in scalar context. If called with one argument, and that argument is a reference to an array, that array reference is used as the new value for the attribute. Returns the array contents in list context or a reference to the actual array stored by the object in scalar context. If called with one argument, and that argument is not a reference to an array, or if called with more than one argument, then the array contents are replaced by the arguments. Returns the array contents in list context or a reference to the actual array stored by the object in scalar context. =item C Behaves like the C interface unless the attribute is undefined. In that case, the method specified by the C option is called and the attribute is set to the return value of that method, which should be a reference to an array. =item C Behaves like the C interface unless the attribute is undefined. In that case, it is initialized to an empty array before proceeding as usual. =item C If called with one argument, returns the item at that array index. If called with two arguments, sets the item at the array index specified by the first argument to the value specified by the second argument. Failure to pass any arguments causes a fatal error. =item C Returns true of the argument exists in the hash, false otherwise. Failure to pass an argument or passing more than one argument causes a fatal error. =item C An alias for the C interface. =item C If called with a list or a reference to an array, the contents of the list or referenced array are added to the end of the array. If called with no arguments, a fatal error will occur. =item C Remove an item from the end of the array and returns it. If an integer argument is passed, then that number of items is removed and returned. Otherwise, just one is removed and returned. =item C Remove an item from the start of the array and returns it. If an integer argument is passed, then that number of items is removed and returned. Otherwise, just one is removed and returned. =item C If called with a list or a reference to an array, the contents of the list or referenced array are added to the start of the array. If called with no arguments, a fatal error will occur. =item C Sets the attribute to an empty array. =item C Sets the attribute to undef. =back =back Example: package MyObject; use Rose::Object::MakeMethods::Generic ( array => [ jobs => {}, job => { interface => 'get_set_item', hash_key => 'jobs' }, clear_jobs => { interface => 'clear', hash_key => 'jobs' }, reset_jobs => { interface => 'reset', hash_key => 'jobs' }, ], ); ... $obj = MyObject->new; $jobs = $obj->jobs; # undef $obj->clear_jobs(); $jobs = $obj->jobs; # ref to empty array $obj->jobs('butcher', 'baker'); # add values $vals = join(',', $obj->jobs); # 'butcher,baker' $obj->jobs([ 'candlestick', 'maker' ]); # replace values $vals = join(',', $obj->jobs); # 'candlestick,maker' $job = $obj->job(0); # 'candlestick' $obj->job(0 => 'sailor'); # set value $job = $obj->job(0); # 'sailor' $obj->reset_jobs; $jobs = $obj->jobs; # undef =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Class/MakeMethods/000750 000765 000120 00000000000 12223410705 020641 5ustar00johnadmin000000 000000 Rose-Object-0.860/lib/Rose/Class/MakeMethods/Generic.pm000755 000765 000120 00000126005 12223410532 022565 0ustar00johnadmin000000 000000 package Rose::Class::MakeMethods::Generic; use strict; use Carp(); our $VERSION = '0.854'; use Rose::Object::MakeMethods; our @ISA = qw(Rose::Object::MakeMethods); our %Scalar; # ( # class_name => # { # some_attr_name1 => ..., # some_attr_name2 => ..., # ... # }, # ... # ); sub scalar { my($class, $name, $args, $options) = @_; my %methods; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set') { $methods{$name} = sub { return $Scalar{$_[0]}{$name} = $_[1] if(@_ > 1); return $Scalar{$_[0]}{$name}; }; } elsif($interface eq 'get_set_init') { my $init_method = $args->{'init_method'} || "init_$name"; $methods{$name} = sub { return $Scalar{$_[0]}{$name} = $_[1] if(@_ > 1); return defined $Scalar{$_[0]}{$name} ? $Scalar{$_[0]}{$name} : ($Scalar{$_[0]}{$name} = $_[0]->$init_method()) }; } return \%methods; } our %Inheritable_Scalar; # ( # class_name => # { # some_attr_name1 => ..., # some_attr_name2 => ..., # ... # }, # ... # ); sub inheritable_scalar { my($class, $name, $args, $options) = @_; my %methods; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set') { $methods{$name} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; if(@_) { return $Inheritable_Scalar{$class}{$name} = shift; } return $Inheritable_Scalar{$class}{$name} if(exists $Inheritable_Scalar{$class}{$name}); my @parents = ($class); while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $subclass (@{$parent . '::ISA'}) { push(@parents, $subclass); if(exists $Inheritable_Scalar{$subclass}{$name}) { return $Inheritable_Scalar{$subclass}{$name} } } } return undef; }; } else { Carp::croak "Unknown interface: $interface" } return \%methods; } our %Inheritable_Boolean; sub inheritable_boolean { my($class, $name, $args, $options) = @_; my %methods; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set') { $methods{$name} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; if(@_) { return $Inheritable_Boolean{$class}{$name} = $_[0] ? 1 : 0; } return $Inheritable_Boolean{$class}{$name} if(exists $Inheritable_Boolean{$class}{$name}); my @parents = ($class); while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $subclass (@{$parent . '::ISA'}) { push(@parents, $subclass); if(exists $Inheritable_Boolean{$subclass}{$name}) { return $Inheritable_Boolean{$subclass}{$name} } } } return undef; }; } else { Carp::croak "Unknown interface: $interface" } return \%methods; } our %Hash; # ( # class_name => # { # key => # { # some_attr_name1 => ..., # some_attr_name2 => ..., # ... # }, # ... # }, # ... # ); sub hash { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; if($interface eq 'get_set_all') { $methods{$name} = sub { my($class) = ref $_[0] ? ref shift : shift; # If called with no arguments, return hash contents return wantarray ? %{$Hash{$class}{$key} || {}} : $Hash{$class}{$key} unless(@_); # Set hash to arguments if(@_ == 1 && ref $_[0] eq 'HASH') { $Hash{$class}{$key} = $_[0]; } else { # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $Hash{$class}{$key}{$_} = shift; } } return wantarray ? %{$Hash{$class}{$key} || {}} : $Hash{$class}{$key}; } } elsif($interface eq 'clear') { $methods{$name} = sub { $Hash{$_[0]}{$key} = {} } } elsif($interface eq 'reset') { $methods{$name} = sub { $Hash{$_[0]}{$key} = undef } } elsif($interface eq 'delete') { $methods{($interface eq 'manip' ? 'delete_' : '') . $name} = sub { Carp::croak "Missing key(s) to delete" unless(@_ > 1); delete @{$Hash{$_[0]}{$key}}{@_[1 .. $#_]}; } } elsif($interface eq 'exists') { $methods{$name . ($interface eq 'manip' ? '_exists' : '')} = sub { Carp::croak "Missing key argument" unless(@_ == 2); defined $Hash{$_[0]}{$key} ? exists $Hash{$_[0]}{$key}{$_[1]} : undef; } } elsif($interface =~ /^(?:keys|names)$/) { $methods{$name} = sub { wantarray ? (defined $Hash{$_[0]}{$key} ? keys %{$Hash{$_[0]}{$key}} : ()) : (defined $Hash{$_[0]}{$key} ? [ keys %{$Hash{$_[0]}{$key}} ] : []); } } elsif($interface eq 'values') { $methods{$name} = sub { wantarray ? (defined $Hash{$_[0]}{$key} ? values %{$Hash{$_[0]}{$key}} : ()) : (defined $Hash{$_[0]}{$key} ? [ values %{$Hash{$_[0]}{$key}} ] : []); } } elsif($interface eq 'get_set') { $methods{$name} = sub { my($class) = ref $_[0] ? ref shift : shift; # If called with no arguments, return hash contents unless(@_) { return wantarray ? (defined $Hash{$class}{$key} ? %{$Hash{$class}{$key}} : ()) : $Hash{$class}{$key} } # If called with a hash ref, set value if(@_ == 1 && ref $_[0] eq 'HASH') { $Hash{$class}{$key} = $_[0]; } else { # If called with an index, get that value, or a slice for array refs if(@_ == 1) { return ref $_[0] eq 'ARRAY' ? @{$Hash{$class}{$key}}{@{$_[0]}} : $Hash{$class}{$key}{$_[0]}; } # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $Hash{$class}{$key}{$_} = shift; } } return wantarray ? %{$Hash{$class}{$key} || {}} : $Hash{$class}{$key}; }; } else { Carp::croak "Unknown interface: $interface" } return \%methods; } our %Inheritable_Hash; # ( # class_name => # { # key => # { # some_attr_name1 => ..., # some_attr_name2 => ..., # ... # }, # ... # }, # ... # ); sub inheritable_hash { my($class, $name, $args) = @_; my %methods; my $key = $args->{'hash_key'} || $name; my $interface = $args->{'interface'} || 'get_set'; my $init_method = sub { my($class) = ref $_[0] ? ref shift : shift; # Inherit shallow copy from subclass my @parents = ($class); SEARCH: while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $subclass (@{$parent . '::ISA'}) { push(@parents, $subclass); if(exists $Inheritable_Hash{$subclass}{$key}) { $Inheritable_Hash{$class}{$key} = { %{$Inheritable_Hash{$subclass}{$key}} }; last SEARCH; } } } }; if($interface eq 'get_set_all') { $methods{$name} = sub { my($class) = ref $_[0] ? ref shift : shift; defined $Inheritable_Hash{$class}{$key} || $init_method->($class); # If called with no arguments, return hash contents return wantarray ? %{$Inheritable_Hash{$class}{$key} || {}} : $Inheritable_Hash{$class}{$key} unless(@_); # Set hash to arguments if(@_ == 1 && ref $_[0] eq 'HASH') { $Inheritable_Hash{$class}{$key} = $_[0]; } else { # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $Inheritable_Hash{$class}{$key}{$_} = shift; } } return wantarray ? %{$Inheritable_Hash{$class}{$key} || {}} : $Inheritable_Hash{$class}{$key}; } } elsif($interface eq 'clear') { $methods{$name} = sub { $Inheritable_Hash{$_[0]}{$key} = {} } } elsif($interface eq 'reset') { $methods{$name} = sub { $Inheritable_Hash{$_[0]}{$key} = undef; } } elsif($interface eq 'delete') { $methods{($interface eq 'manip' ? 'delete_' : '') . $name} = sub { Carp::croak "Missing key(s) to delete" unless(@_ > 1); defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]); delete @{$Inheritable_Hash{$_[0]}{$key}}{@_[1 .. $#_]}; } } elsif($interface eq 'exists') { $methods{$name . ($interface eq 'manip' ? '_exists' : '')} = sub { Carp::croak "Missing key argument" unless(@_ == 2); defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]); defined $Inheritable_Hash{$_[0]}{$key} ? exists $Inheritable_Hash{$_[0]}{$key}{$_[1]} : undef; } } elsif($interface =~ /^(?:keys|names)$/) { $methods{$name} = sub { defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]); wantarray ? (defined $Inheritable_Hash{$_[0]}{$key} ? keys %{$Inheritable_Hash{$_[0]}{$key} || {}} : ()) : (defined $Inheritable_Hash{$_[0]}{$key} ? [ keys %{$Inheritable_Hash{$_[0]}{$key} || {}} ] : []); } } elsif($interface eq 'values') { $methods{$name} = sub { defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]); wantarray ? (defined $Inheritable_Hash{$_[0]}{$key} ? values %{$Inheritable_Hash{$_[0]}{$key} || {}} : ()) : (defined $Inheritable_Hash{$_[0]}{$key} ? [ values %{$Inheritable_Hash{$_[0]}{$key} || {}} ] : []); } } elsif($interface eq 'get_set') { $methods{$name} = sub { my($class) = ref $_[0] ? ref shift : shift; defined $Inheritable_Hash{$class}{$key} || $init_method->($class); # If called with no arguments, return hash contents unless(@_) { return wantarray ? (defined $Inheritable_Hash{$class}{$key} ? %{$Inheritable_Hash{$class}{$key} || {}} : ()) : $Inheritable_Hash{$class}{$key} } # If called with a hash ref, set value if(@_ == 1 && ref $_[0] eq 'HASH') { $Inheritable_Hash{$class}{$key} = $_[0]; } else { # If called with an index, get that value, or a slice for array refs if(@_ == 1) { return ref $_[0] eq 'ARRAY' ? @{$Inheritable_Hash{$class}{$key}}{@{$_[0]}} : $Inheritable_Hash{$class}{$key}{$_[0]}; } # Push on new values and return complete set Carp::croak "Odd number of items in assigment to $name" if(@_ % 2); while(@_) { local $_ = shift; $Inheritable_Hash{$class}{$key}{$_} = shift; } } return wantarray ? %{$Inheritable_Hash{$class}{$key} || {}} : $Inheritable_Hash{$class}{$key}; }; } else { Carp::croak "Unknown interface: $interface" } return \%methods; } use constant CLASS_VALUE => 1; use constant INHERITED_VALUE => 2; use constant DELETED_VALUE => 3; our %Inherited_Hash; # ( # some_name => # { # class1 => # { # meta => { ... }, # cache => # { # meta => # { # attr1 => CLASS_VALUE, # attr2 => DELETED_VALUE, # ... # }, # attrs => # { # attr1 => value1, # attr2 => value2, # ... # }, # }, # }, # class2 => ..., # ... # }, # ... # ); # Used as array indexes to replace {'meta'}, {'attrs'}, and {'cache'} use constant META => 0; use constant CACHE => 1; use constant ATTRS => 1; # XXX: This implementation is space-inefficient and pretty silly sub inherited_hash { my($class, $name, $args) = @_; my %methods; # Interface example: # name: object_type_class # plural_name: object_type_classes # # get_set: object_type_class # get_set_all_method: object_type_classes # keys_method: object_type_class_keys # cache_method: object_type_classes_cache # exists_method: object_type_class_exists # add_method: add_object_type_class # adds_method: add_object_type_classes # delete_method: delete_object_type_class # deletes_method: delete_object_type_classes # clear_method clear_object_type_classes # inherit_method: inherit_object_type_class # inherits_method: inherit_object_type_classes my $plural_name = $args->{'plural_name'} || $name . 's'; my $get_set_method = $name; my $get_set_all_method = $args->{'get_set_all_method'} || $args->{'hash_method'} || $plural_name; my $keys_method = $args->{'keys_method'} || $name . '_keys'; my $cache_method = $args->{'cache_method'} || $plural_name . '_cache'; my $exists_method = $args->{'exists_method'} || $args->{'exists_method'} || $name . '_exists'; my $add_method = $args->{'add_method'} || 'add_' . $name; my $adds_method = $args->{'adds_method'} || 'add_' . $plural_name; my $delete_method = $args->{'delete_method'} || 'delete_' . $name; my $deletes_method = $args->{'deletes_method'} || 'delete_' . $plural_name; my $clear_method = $args->{'clear_method'} || 'clear_' . $plural_name; my $inherit_method = $args->{'inherit_method'} || 'inherit_' . $name; my $inherits_method = $args->{'inherits_method'} || 'inherit_' . $plural_name; my $interface = $args->{'interface'} || 'all'; my $add_implies = $args->{'add_implies'}; my $delete_implies = $args->{'delete_implies'}; my $inherit_implies = $args->{'inherit_implies'}; $add_implies = [ $add_implies ] if(defined $add_implies && !ref $add_implies); $delete_implies = [ $delete_implies ] if(defined $delete_implies && !ref $delete_implies); $inherit_implies = [ $inherit_implies ] if(defined $inherit_implies && !ref $inherit_implies); $methods{$cache_method} = sub { my($class) = ref($_[0]) || $_[0]; if($Inherited_Hash{$name}{$class}[META]{'cache_is_valid'}) { return wantarray ? (%{$Inherited_Hash{$name}{$class}[CACHE] ||= []}) : ($Inherited_Hash{$name}{$class}[CACHE] ||= []); } my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= []; my @parents = ($class); while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $superclass (@{$parent . '::ISA'}) { push(@parents, $superclass); if($superclass->can($cache_method)) { my $supercache = $superclass->$cache_method(); while(my($attr, $state) = each %{$supercache->[META] || {}}) { next if($state == DELETED_VALUE); no warnings 'uninitialized'; unless(exists $cache->[ATTRS]{$attr}) { $cache->[ATTRS]{$attr} = $supercache->[ATTRS]{$attr}; $cache->[META]{$attr} = INHERITED_VALUE; } } } # Slower method for superclasses that don't want to implement the # cache method (which is not strictly part of the public API) elsif($superclass->can($keys_method)) { foreach my $attr ($superclass->$keys_method()) { unless(exists $Inherited_Hash{$name}{$class}[CACHE][ATTRS]{$attr}) { $Inherited_Hash{$name}{$class}[CACHE][META]{$attr} = INHERITED_VALUE; $Inherited_Hash{$name}{$class}[CACHE][ATTRS]{$attr} = $Inherited_Hash{$name}{$superclass}[CACHE][ATTRS]{$attr}; } } } } } $Inherited_Hash{$name}{$class}[META]{'cache_is_valid'} = 1; my $want = wantarray; return unless(defined $want); $want ? (%{$Inherited_Hash{$name}{$class}[CACHE] ||= []}) : ($Inherited_Hash{$name}{$class}[CACHE] ||= []); }; $methods{$get_set_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; return 0 unless(defined $_[0]); my $key = shift; if(@_) { Carp::croak "More than one value passed to $get_set_method()" if(@_ > 1); $class->$adds_method($key, @_); } else { if($Inherited_Hash{$name}{$class}[META]{'cache_is_valid'}) { my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= []; no warnings 'uninitialized'; return $cache->[ATTRS]{$key} unless($cache->[META]{$key} == DELETED_VALUE); return undef; } my $cache = $class->$cache_method(); no warnings 'uninitialized'; return $cache->[ATTRS]{$key} unless($cache->[META]{$key} == DELETED_VALUE); return undef; } }; $methods{$keys_method} = sub { my($class) = shift; $class = ref $class if(ref $class); return wantarray ? keys %{$class->$get_set_all_method()} : [ keys %{$class->$get_set_all_method()} ]; }; $methods{$get_set_all_method} = sub { my($class) = shift; $class = ref $class if(ref $class); if(@_) { $class->$clear_method(); return $class->$adds_method(@_); } my $cache = $class->$cache_method(); my %hash = %{$cache->[ATTRS] || {}}; foreach my $k (keys %hash) { delete $hash{$k} if($Inherited_Hash{$name}{$class}[CACHE][META]{$k} == DELETED_VALUE); } return wantarray ? %hash : \%hash; }; $methods{$exists_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; my $key = shift; return 0 unless(defined $key); if($Inherited_Hash{$name}{$class}[META]{'cache_is_valid'}) { my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= []; return (exists $cache->[ATTRS]{$key} && $cache->[META]{$key} != DELETED_VALUE) ? 1 : 0; } my $cache = $class->$cache_method(); return (exists $cache->[ATTRS]{$key} && $cache->[META]{$key} != DELETED_VALUE) ? 1 : 0; }; $methods{$add_method} = sub { shift->$adds_method(@_) }; $methods{$adds_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing name/value pair(s) to add") unless(@_); my @attrs; my $count = 0; my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= []; # XXX: Lame duplication to avoid copying the hash if(@_ == 1 && ref $_[0] eq 'HASH') { while(my($attr, $value) = each(%{$_[0]})) { next unless(defined $attr); push(@attrs, $attr); $cache->[ATTRS]{$attr} = $value; $cache->[META]{$attr} = CLASS_VALUE; if($add_implies) { foreach my $method (@$add_implies) { $class->$method($attr => $value); } } $count++; } } else { Carp::croak("Odd number of arguments passed to $adds_method") if(@_ % 2); while(@_) { my($attr, $value) = (shift, shift); push(@attrs, $attr); no strict 'refs'; next unless(defined $attr); $cache->[ATTRS]{$attr} = $value; $cache->[META]{$attr} = CLASS_VALUE; if($add_implies) { foreach my $method (@$add_implies) { $class->$method($attr => $value); } } $count++; } } if($count) { foreach my $test_class (keys %{$Inherited_Hash{$name}}) { if($test_class->isa($class) && $test_class ne $class) { $Inherited_Hash{$name}{$test_class}[META]{'cache_is_valid'} = 0; foreach my $attr (@attrs) { delete $Inherited_Hash{$name}{$test_class}[CACHE][ATTRS]{$attr}; } } } } return $count; }; $methods{$clear_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; my @keys = $class->$keys_method(); return unless(@keys); $class->$deletes_method(@keys); }; $methods{$delete_method} = sub { shift->$deletes_method(@_) }; $methods{$deletes_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to delete") unless(@_); # Init set if it doesn't exist unless(exists $Inherited_Hash{$name}{$class}) { $class->$cache_method(); } my $count = 0; my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= []; foreach my $attr (@_) { no strict 'refs'; next unless(defined $attr); if(exists $cache->[ATTRS]{$attr} && $cache->[META]{$attr} != DELETED_VALUE) { $cache->[META]{$attr} = DELETED_VALUE; $count++; if($delete_implies) { foreach my $method (@$delete_implies) { $class->$method($attr); } } foreach my $test_class (keys %{$Inherited_Hash{$name}}) { next if($class eq $test_class); my $test_cache = $Inherited_Hash{$name}{$test_class}[CACHE] ||= []; if($test_class->isa($class) && exists $test_cache->[ATTRS]{$attr} && $test_cache->[META]{$attr} == INHERITED_VALUE) { delete $test_cache->[ATTRS]{$attr}; delete $test_cache->[META]{$attr}; $Inherited_Hash{$name}{$test_class}[META]{'cache_is_valid'} = 0; } } } } return $count; }; $methods{$inherit_method} = sub { shift->$inherits_method(@_) }; $methods{$inherits_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to inherit") unless(@_); my $count = 0; my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= []; foreach my $attr (@_) { if(exists $cache->[ATTRS]{$attr}) { delete $cache->[ATTRS]{$attr}; delete $cache->[META]{$attr}; $Inherited_Hash{$name}{$class}[META]{'cache_is_valid'} = 0; $count++; } if($inherit_implies) { foreach my $method (@$inherit_implies) { $class->$method($attr); } } } return $count; }; if($interface ne 'all') { Carp::croak "Unknown interface: $interface"; } return \%methods; } 1; __END__ =head1 NAME Rose::Class::MakeMethods::Generic - Create simple class methods. =head1 SYNOPSIS package MyClass; use Rose::Class::MakeMethods::Generic ( scalar => [ 'error', 'type' => { interface => 'get_set_init' }, ], inheritable_scalar => 'name', ); sub init_type { 'special' } ... package MySubClass; our @ISA = qw(MyClass); ... MyClass->error(123); print MyClass->type; # 'special' MyClass->name('Fred'); print MySubClass->name; # 'Fred' MyClass->name('Wilma'); print MySubClass->name; # 'Wilma' MySubClass->name('Bam'); print MyClass->name; # 'Wilma' print MySubClass->name; # 'Bam' =head1 DESCRIPTION L is a method maker that inherits from L. See the L documentation to learn about the interface. The method types provided by this module are described below. All methods work only with classes, not objects. =head1 METHODS TYPES =over 4 =item B Create get/set methods for scalar class attributes. =over 4 =item Options =over 4 =item C The name of the class method to call when initializing the value of an undefined attribute. This option is only applicable when using the C interface. Defaults to the method name with the prefix C added. =item C Choose one of the two possible interfaces. Defaults to C. =back =item Interfaces =over 4 =item C Creates a simple get/set accessor method for a class attribute. When called with an argument, the value of the attribute is set. The current value of the attribute is returned. =item C Behaves like the C interface unless the value of the attribute is undefined. In that case, the class method specified by the C option is called and the attribute is set to the return value of that method. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Generic ( scalar => 'power', 'scalar --get_set_init' => 'name', ); sub init_name { 'Fred' } ... MyClass->power(99); # returns 99 MyClass->name; # returns "Fred" MyClass->name('Bill'); # returns "Bill" =item B Create get/set methods for boolean class attributes that are inherited by subclasses until/unless their values are changed. =over 4 =item Options =over 4 =item C Choose the interface. This is kind of pointless since there is only one interface right now. Defaults to C, obviously. =back =item Interfaces =over 4 =item C Creates a get/set accessor method for a class attribute. When called with an argument, the value of the attribute is set to 1 if that argument is true or 0 if it is false. The value of the attribute is then returned. If called with no arguments, and if the attribute was never set for this class, then a left-most, breadth-first search of the parent classes is initiated. The value returned is taken from first parent class encountered that has ever had this attribute set. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Generic ( inheritable_boolean => 'enabled', ); ... package MySubClass; our @ISA = qw(MyClass); ... package MySubSubClass; our @ISA = qw(MySubClass); ... $x = MyClass->enabled; # undef $y = MySubClass->enabled; # undef $z = MySubSubClass->enabled; # undef MyClass->enabled(1); $x = MyClass->enabled; # 1 $y = MySubClass->enabled; # 1 $z = MySubSubClass->enabled; # 1 MyClass->enabled(0); $x = MyClass->enabled; # 0 $y = MySubClass->enabled; # 0 $z = MySubSubClass->enabled; # 0 MySubClass->enabled(1); $x = MyClass->enabled; # 0 $y = MySubClass->enabled; # 1 $z = MySubSubClass->enabled; # 1 MyClass->enabled(1); MySubClass->enabled(undef); $x = MyClass->enabled; # 1 $y = MySubClass->enabled; # 0 $z = MySubSubClass->enabled; # 0 MySubSubClass->enabled(1); $x = MyClass->enabled; # 1 $y = MySubClass->enabled; # 0 $z = MySubSubClass->enabled; # 0 =item B Create get/set methods for scalar class attributes that are inherited by subclasses until/unless their values are changed. =over 4 =item Options =over 4 =item C Choose the interface. This is kind of pointless since there is only one interface right now. Defaults to C, obviously. =back =item Interfaces =over 4 =item C Creates a get/set accessor method for a class attribute. When called with an argument, the value of the attribute is set and then returned. If called with no arguments, and if the attribute was never set for this class, then a left-most, breadth-first search of the parent classes is initiated. The value returned is taken from first parent class encountered that has ever had this attribute set. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Generic ( inheritable_scalar => 'name', ); ... package MySubClass; our @ISA = qw(MyClass); ... package MySubSubClass; our @ISA = qw(MySubClass); ... $x = MyClass->name; # undef $y = MySubClass->name; # undef $z = MySubSubClass->name; # undef MyClass->name('Fred'); $x = MyClass->name; # 'Fred' $y = MySubClass->name; # 'Fred' $z = MySubSubClass->name; # 'Fred' MyClass->name('Wilma'); $x = MyClass->name; # 'Wilma' $y = MySubClass->name; # 'Wilma' $z = MySubSubClass->name; # 'Wilma' MySubClass->name('Bam'); $x = MyClass->name; # 'Wilma' $y = MySubClass->name; # 'Bam' $z = MySubSubClass->name; # 'Bam' MyClass->name('Koop'); MySubClass->name(undef); $x = MyClass->name; # 'Koop' $y = MySubClass->name; # undef $z = MySubSubClass->name; # undef MySubSubClass->name('Sam'); $x = MyClass->name; # 'Koop' $y = MySubClass->name; # undef $z = MySubSubClass->name; # 'Sam' =item B Create methods to manipulate a hash of class attributes. =over 4 =item Options =over 4 =item C The key to use for the storage of this attribute. Defaults to the name of the method. =item C Choose which interface to use. Defaults to C. =back =item Interfaces =over 4 =item C If called with no arguments, returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. If called with one argument, and that argument is a reference to a hash, that hash reference is used as the new value for the attribute. Returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. If called with one argument, and that argument is a reference to an array, then a list of the hash values for each key in the array is returned. If called with one argument, and it is not a reference to a hash or an array, then the hash value for that key is returned. If called with an even number of arguments, they are taken as name/value pairs and are added to the hash. It then returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. Passing an odd number of arguments greater than 1 causes a fatal error. =item C If called with no arguments, returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. If called with one argument, and that argument is a reference to a hash, that hash reference is used as the new value for the attribute. Returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. Otherwise, the hash is emptied and the arguments are taken as name/value pairs that are then added to the hash. It then returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. =item C Sets the attribute to an empty hash. =item C Sets the attribute to undef. =item C Deletes the key(s) passed as arguments. Failure to pass any arguments causes a fatal error. =item C Returns true of the argument exists in the hash, false otherwise. Failure to pass an argument or passing more than one argument causes a fatal error. =item C Returns the keys of the hash in list context, or a reference to an array of the keys of the hash in scalar context. The keys are not sorted. =item C An alias for the C interface. =item C Returns the values of the hash in list context, or a reference to an array of the values of the hash in scalar context. The values are not sorted. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Generic ( hash => [ param => { hash_key =>'params' }, params => { interface=>'get_set_all' }, param_names => { interface=>'keys', hash_key=>'params' }, param_values => { interface=>'values', hash_key=>'params' }, param_exists => { interface=>'exists', hash_key=>'params' }, delete_param => { interface=>'delete', hash_key=>'params' }, clear_params => { interface=>'clear', hash_key=>'params' }, reset_params => { interface=>'reset', hash_key=>'params' }, ], ); ... MyClass->params; # undef MyClass->params(a => 1, b => 2); # add pairs $val = MyClass->param('b'); # 2 %params = MyClass->params; # copy hash keys and values $params = MyClass->params; # get hash ref MyClass->params({ c => 3, d => 4 }); # replace contents MyClass->param_exists('a'); # false $keys = join(',', sort MyClass->param_names); # 'c,d' $vals = join(',', sort MyClass->param_values); # '3,4' MyClass->delete_param('c'); MyClass->param(f => 7, g => 8); $vals = join(',', sort MyClass->param_values); # '4,7,8' MyClass->clear_params; $params = MyClass->params; # empty hash MyClass->reset_params; $params = MyClass->params; # undef =item B Create methods to manipulate a hash of class attributes that can be inherited by subclasses. The hash of attributes is inherited by subclasses using a one-time copy. Any subclass that accesses or manipulates the hash in any way will immediately get its own private copy of the hash I. The superclass from which the hash is copied is the closest ("least super") class that has ever accessed or manipulated this hash. The copy is a "shallow" copy, duplicating only the keys and values. Reference values are not recursively copied. Setting to hash to undef (using the 'reset' interface) will cause it to be re-copied from a superclass the next time it is accessed. =over 4 =item Options =over 4 =item C The key to use for the storage of this attribute. Defaults to the name of the method. =item C Choose which interface to use. Defaults to C. =back =item Interfaces =over 4 =item C If called with no arguments, returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. If called with one argument, and that argument is a reference to a hash, that hash reference is used as the new value for the attribute. Returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. If called with one argument, and that argument is a reference to an array, then a list of the hash values for each key in the array is returned. If called with one argument, and it is not a reference to a hash or an array, then the hash value for that key is returned. If called with an even number of arguments, they are taken as name/value pairs and are added to the hash. It then returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. Passing an odd number of arguments greater than 1 causes a fatal error. =item C If called with no arguments, returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. If called with one argument, and that argument is a reference to a hash, that hash reference is used as the new value for the attribute. Returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. Otherwise, the hash is emptied and the arguments are taken as name/value pairs that are then added to the hash. It then returns a list of key/value pairs in list context or a reference to the actual hash used to store values in scalar context. =item C Sets the attribute to an empty hash. =item C Sets the attribute to undef. =item C Deletes the key(s) passed as arguments. Failure to pass any arguments causes a fatal error. =item C Returns true of the argument exists in the hash, false otherwise. Failure to pass an argument or passing more than one argument causes a fatal error. =item C Returns the keys of the hash in list context, or a reference to an array of the keys of the hash in scalar context. The keys are not sorted. =item C An alias for the C interface. =item C Returns the values of the hash in list context, or a reference to an array of the values of the hash in scalar context. The values are not sorted. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Generic ( inheritable_hash => [ param => { hash_key =>'params' }, params => { interface=>'get_set_all' }, param_names => { interface=>'keys', hash_key=>'params' }, param_values => { interface=>'values', hash_key=>'params' }, param_exists => { interface=>'exists', hash_key=>'params' }, delete_param => { interface=>'delete', hash_key=>'params' }, clear_params => { interface=>'clear', hash_key=>'params' }, reset_params => { interface=>'reset', hash_key=>'params' }, ], ); ... package MySubClass; our @ISA = qw(MyClass); ... MyClass->params; # undef MyClass->params(a => 1, b => 2); # add pairs $val = MyClass->param('b'); # 2 %params = MyClass->params; # copy hash keys and values $params = MyClass->params; # get hash ref # Inherit a copy of params from MyClass $params = MySubClass->params; # { a => 1, b => 2 } MyClass->params({ c => 3, d => 4 }); # replace contents # MySubClass params are still as the existed at the time # they were originally copied from MyClass $params = MySubClass->params; # { a => 1, b => 2 } # MySubClass can manipulate its own params as it wishes MySubClass->param(z => 9); $params = MySubClass->params; # { a => 1, b => 2, z => 9 } MyClass->param_exists('a'); # false $keys = join(',', sort MyClass->param_names); # 'c,d' $vals = join(',', sort MyClass->param_values); # '3,4' # Reset params (set to undef) so that they will be re-copied # from MyClass the next time they're accessed MySubClass->reset_params; MyClass->delete_param('c'); MyClass->param(f => 7, g => 8); $vals = join(',', sort MyClass->param_values); # '4,7,8' # Inherit a copy of params from MyClass $params = MySubClass->params; # { d => 4, f => 7, g => 8 } =item B Create a family of class methods for managing an inherited hash. An inherited hash is made up of the union of the hashes of all superclasses, minus any keys that are explicitly deleted in the current class. =over 4 =item Options =over 4 =item C A method name, or reference to a list of method names, to call when a key is added to the hash. Each added name/value pair is passed to each method in the C list, one pair at a time. =item C The name of the class method used to add a single name/value pair to the hash. Defaults to the method name with the prefix C added. =item C The name of the class method used to add one or more name/value pairs to the hash. Defaults to C with the prefix C added. =item C The name of the class method used to retrieve (or generate, if it doesn't exist) the internal cache for the hash. This should be considered a private method, but it is listed here because it does take up a spot in the method namespace. Defaults to C with C<_cache> added to the end. =item C The name of the class method used to clear the contents of the hash. Defaults to C with a C prefix added. =item C A method name, or reference to a list of method names, to call when a key is removed from the hash. Each deleted key is passed as an argument to each method in the C list, one key per call. =item C The name of the class method used to remove a single key from the hash. Defaults to the method name with the prefix C added. =item C The name of the class method used to remove one or more keys from the hash. Defaults to C with a C prefix added. =item C The name of the class method that tests for the existence of a key in the hash. Defaults to the method name with the suffix C<_exists> added. =item C The name of the class method use to set or fetch the entire hash. The hash may be passed as a reference to a hash or as a list of name/value pairs. Returns the hash (in list context) or a reference to a hash (in scalar context). Defaults to C. =item C This is an alias for the C parameter. =item C The name of the class method used to indicate that an inherited key that was previously deleted from the hash should return to being inherited. Defaults to the method name with the prefix C added. =item C The name of the class method used to indicate that one or more inherited keys that were previously deleted from the hash should return to being inherited. Defaults to the C with the prefix C added. =item C Choose the interface. This is kind of pointless since there is only one interface right now. Defaults to C, obviously. =item C The name of the class method that returns a reference to a list of keys in scalar context, or a list of keys in list context. Defaults to C with "_keys" added to the end. =item C The plural version of the method name, used to construct the default names for some other methods. Defaults to the method name with C added. =back =item Interfaces =over 4 =item C Creates the entire family of methods described above. The example below illustrates their use. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Generic ( inherited_hash => [ pet_color => { keys_method => 'pets', delete_implies => 'delete_special_pet_color', inherit_implies => 'inherit_special_pet_color', }, special_pet_color => { keys_method => 'special_pets', add_implies => 'add_pet_color', }, ], ); ... package MySubClass; our @ISA = qw(MyClass); ... MyClass->pet_colors(Fido => 'white', Max => 'black', Spot => 'yellow'); MyClass->special_pet_color(Toby => 'tan'); MyClass->pets; # Fido, Max, Spot, Toby MyClass->special_pets; # Toby MySubClass->pets; # Fido, Max, Spot, Toby MyClass->pet_color('Toby'); # tan MySubClass->special_pet_color(Toby => 'gold'); MyClass->pet_color('Toby'); # tan MyClass->special_pet_color('Toby'); # tan MySubClass->pet_color('Toby'); # gold MySubClass->special_pet_color('Toby'); # gold MySubClass->inherit_pet_color('Toby'); MySubClass->pet_color('Toby'); # tan MySubClass->special_pet_color('Toby'); # tan MyClass->delete_pet_color('Max'); MyClass->pets; # Fido, Spot, Toby MySubClass->pets; # Fido, Spot, Toby MyClass->special_pet_color(Max => 'mauve'); MyClass->pets; # Fido, Max, Spot, Toby MySubClass->pets; # Fido, Max, Spot, Toby MyClass->special_pets; # Max, Toby MySubClass->special_pets; # Max, Toby MySubClass->delete_special_pet_color('Max'); MyClass->pets; # Fido, Max, Spot, Toby MySubClass->pets; # Fido, Max, Spot, Toby MyClass->special_pets; # Max, Toby MySubClass->special_pets; # Toby =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-Object-0.860/lib/Rose/Class/MakeMethods/Set.pm000755 000765 000120 00000070776 11456611342 021772 0ustar00johnadmin000000 000000 package Rose::Class::MakeMethods::Set; use strict; use Carp(); our $VERSION = '0.81'; use Rose::Object::MakeMethods; our @ISA = qw(Rose::Object::MakeMethods); our %Inheritable_Set; # ( # some_attr_name => # { # class1 => # { # meta => { ... }, # cache => { ... }, # }, # class2 => ..., # ... # }, # ... # ); sub inheritable_set { my($class, $name, $args) = @_; my %methods; # Interface example: # name: required_html_attr # plural_name: required_html_attrs # list_method: required_html_attrs # hash_method: required_html_attrs_hash # test_method: is_required_html_attr (or html_attr_is_required) # add_method: add_required_html_attr # adds_method: add_required_html_attrs # delete_method: delete_required_html_attr # deletes_method: delete_required_html_attrs # clear_method: clear_required_html_attrs my $plural_name = $args->{'plural_name'} || $name . 's'; my $list_method = $args->{'list_method'} || $plural_name; my $hash_method = $args->{'hash_method'} || $plural_name . '_hash'; my $test_method = $args->{'test_method'} || $args->{'test_method'} || 'is_' . $name; my $add_method = $args->{'add_method'} || 'add_' . $name; my $adds_method = $args->{'adds_method'} || $add_method . 's'; my $delete_method = $args->{'delete_method'} || 'delete_' . $name; my $deletes_method = $args->{'deletes_method'} || 'delete_' . $plural_name; my $clear_method = $args->{'clear_method'} || 'clear_' . $plural_name; my $value_method = $args->{'value_method'} || $name . '_value'; my $interface = $args->{'interface'} || 'all'; my $add_implies = $args->{'add_implies'}; my $delete_implies = $args->{'delete_implies'}; $add_implies = [ $add_implies ] if(defined $add_implies && !ref $add_implies); $delete_implies = [ $delete_implies ] if(defined $delete_implies && !ref $delete_implies); $methods{$test_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; return 0 unless(defined $_[0]); no strict 'refs'; return 1 if(exists $class->$hash_method()->{$_[0]}); return 0; }; $methods{$hash_method} = sub { my($class) = ref($_[0]) || $_[0]; unless(exists $Inheritable_Set{$name}{$class}) { no strict 'refs'; my @parents = ($class); while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $subclass (@{$parent . '::ISA'}) { push(@parents, $subclass); if(exists $Inheritable_Set{$name}{$subclass}) { while(my($k, $v) = each(%{$Inheritable_Set{$name}{$subclass}})) { next if(exists $Inheritable_Set{$name}{$class}{$k}); $Inheritable_Set{$name}{$class}{$k} = $v; } } } } } $Inheritable_Set{$name}{$class} ||= {}; return wantarray ? %{$Inheritable_Set{$name}{$class}} : $Inheritable_Set{$name}{$class}; }; $methods{$list_method} = sub { my($class) = shift; $class = ref $class if(ref $class); if(@_) { $class->$clear_method(); $class->$adds_method(@_); return unless(defined wantarray); } return wantarray ? sort keys %{$class->$hash_method()} : [ sort keys %{$class->$hash_method()} ]; }; $methods{$add_method} = sub { shift->$adds_method(@_) }; $methods{$adds_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to add") unless(@_); my $count = 0; my $req_hash = $class->$hash_method(); return 0 unless(defined $_[0]); my %attrs; foreach my $arg (grep { defined } @_) { if(ref $arg eq 'HASH') { $attrs{$_} = $arg->{$_} for(keys %$arg); } else { $attrs{$arg} = undef; } } while(my($attr, $val) = each(%attrs)) { no strict 'refs'; next unless(defined $attr); $req_hash->{$attr} = $val; if($add_implies) { foreach my $method (@$add_implies) { $class->$method($attr); } } $count++; } return $count; }; $methods{$clear_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; my @values = $class->$list_method(); return unless(@values); $class->$deletes_method(@values); }; $methods{$delete_method} = sub { shift->$deletes_method(@_) }; $methods{$deletes_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to delete") unless(@_); my $count = 0; my $req_hash = $class->$hash_method(); foreach my $attr (@_) { no strict 'refs'; next unless(defined $attr); next unless(exists $req_hash->{$attr}); delete $req_hash->{$attr}; $count++; if($delete_implies) { foreach my $method (@$delete_implies) { $class->$method($attr); } } } return $count; }; $methods{$value_method} = sub { my($class) = ref($_[0]) || $_[0]; my $hash = $class->$hash_method(); return undef unless($_[1] && exists $hash->{$_[1]}); return $hash->{$_[1]} = $_[2] if(@_ > 2); return $hash->{$_[1]}; }; if($interface ne 'all') { Carp::croak "Unknown interface: $interface"; } return \%methods; } use constant CLASS_VALUE => 1; use constant INHERITED_VALUE => 2; use constant DELETED_VALUE => 3; our %Inherited_Set; # ( # some_attr_name => # { # class1 => # { # meta => { ... }, # cache => { ... }, # }, # class2 => ..., # ... # }, # ... # ); sub inherited_set { my($class, $name, $args) = @_; my %methods; # Interface example: # name: valid_html_attr # plural_name: valid_html_attrs # list_method: valid_html_attrs # cache_method: valid_html_attrs_cache # hash_method: valid_html_attrs_hash # test_method: is_valid_html_attr (or html_attr_is_valid) # add_method: add_valid_html_attr # adds_method: add_valid_html_attrs # delete_method: delete_valid_html_attr # deletes_method: delete_valid_html_attrs # clear_method clear_valid_html_attrs # inherit_method: inherit_valid_html_attr # inherits_method: inherit_valid_html_attrs my $plural_name = $args->{'plural_name'} || $name . 's'; my $list_method = $args->{'list_method'} || $plural_name; my $cache_method = $args->{'cache_method'} || $plural_name . '_cache'; my $hash_method = $args->{'hash_method'} || $plural_name . '_hash'; my $test_method = $args->{'test_method'} || $args->{'test_method'} || 'is_' . $name; my $add_method = $args->{'add_method'} || 'add_' . $name; my $adds_method = $args->{'adds_method'} || $add_method . 's'; my $delete_method = $args->{'delete_method'} || 'delete_' . $name; my $deletes_method = $args->{'deletes_method'} || 'delete_' . $plural_name; my $clear_method = $args->{'clear_method'} || 'clear_' . $plural_name; my $inherit_method = $args->{'inherit_method'} || 'inherit_' . $name; my $inherits_method = $args->{'inherits_method'} || $inherit_method . 's'; my $interface = $args->{'interface'} || 'all'; my $add_implies = $args->{'add_implies'}; my $delete_implies = $args->{'delete_implies'}; my $inherit_implies = $args->{'inherit_implies'}; $add_implies = [ $add_implies ] if(defined $add_implies && !ref $add_implies); $delete_implies = [ $delete_implies ] if(defined $delete_implies && !ref $delete_implies); $inherit_implies = [ $inherit_implies ] if(defined $inherit_implies && !ref $inherit_implies); $methods{$cache_method} = sub { my($class) = ref($_[0]) || $_[0]; if($Inherited_Set{$name}{$class}{'meta'}{'cache_is_valid'}) { return wantarray ? (%{$Inherited_Set{$name}{$class}{'cache'} ||= {}}) : ($Inherited_Set{$name}{$class}{'cache'} ||= {}); } my @parents = ($class); while(my $parent = shift(@parents)) { no strict 'refs'; foreach my $subclass (@{$parent . '::ISA'}) { push(@parents, $subclass); if($subclass->can($cache_method)) { my $cache = $subclass->$cache_method(); while(my($attr, $val) = each %$cache) { next if($val == DELETED_VALUE); $Inherited_Set{$name}{$class}{'cache'}{$attr} = INHERITED_VALUE unless(exists $Inherited_Set{$name}{$class}{'cache'}{$attr}); } } # Slower method for subclasses that don't want to implement the # cache method (which is not strictly part of the public API) elsif($subclass->can($list_method)) { foreach my $attr ($subclass->$list_method()) { $Inherited_Set{$name}{$class}{'cache'}{$attr} = INHERITED_VALUE unless(exists $Inherited_Set{$name}{$class}{'cache'}{$attr}); } } } } $Inherited_Set{$name}{$class}{'meta'}{'cache_is_valid'} = 1; my $want = wantarray; return unless(defined $want); $want ? (%{$Inherited_Set{$name}{$class}{'cache'} ||= {}}) : ($Inherited_Set{$name}{$class}{'cache'} ||= {}); }; $methods{$hash_method} = sub { my($class) = ref($_[0]) || $_[0]; my %hash = $class->$cache_method(); while(my($k, $v) = each %hash) { delete $hash{$k} if($v == DELETED_VALUE); } return wantarray ? %hash : \%hash; }; $methods{$list_method} = sub { my($class) = shift; $class = ref $class if(ref $class); if(@_) { $class->$clear_method(); $class->$adds_method(@_); return unless(defined wantarray); } return wantarray ? sort keys %{$class->$hash_method()} : [ sort keys %{$class->$hash_method()} ]; }; $methods{$test_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; return 0 unless(defined $_[0]); if($Inherited_Set{$name}{$class}{'meta'}{'cache_is_valid'}) { return (exists $Inherited_Set{$name}{$class}{'cache'}{$_[0]} && $Inherited_Set{$name}{$class}{'cache'}{$_[0]} != DELETED_VALUE) ? 1 : 0; } my $cache = $class->$cache_method(); return (exists $cache->{$_[0]} && $cache->{$_[0]} != DELETED_VALUE) ? 1 : 0; }; $methods{$add_method} = sub { shift->$adds_method(@_) }; $methods{$adds_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to add") unless(@_); my $count = 0; foreach my $attr (@_) { no strict 'refs'; next unless(defined $attr); $Inherited_Set{$name}{$class}{'cache'}{$attr} = CLASS_VALUE; if($add_implies) { foreach my $method (@$add_implies) { $class->$method($attr); } } $count++; } # _invalidate_inherited_set_caches($class, $name) if($count); # Inlined since it is private and only called once if($count) { foreach my $test_class (keys %{$Inherited_Set{$name}}) { if($test_class->isa($class) && $test_class ne $class) { $Inherited_Set{$name}{$test_class}{'meta'}{'cache_is_valid'} = 0; } } } return $count; }; $methods{$clear_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; my @values = $class->$list_method(); return unless(@values); $class->$deletes_method(@values); }; $methods{$delete_method} = sub { shift->$deletes_method(@_) }; $methods{$deletes_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to delete") unless(@_); # Init set if it doesn't exist unless(exists $Inherited_Set{$name}{$class}) { $class->$cache_method(); } my $count = 0; foreach my $attr (@_) { no strict 'refs'; next unless(defined $attr); if(exists $Inherited_Set{$name}{$class}{'cache'}{$attr} && $Inherited_Set{$name}{$class}{'cache'}{$attr} != DELETED_VALUE) { $Inherited_Set{$name}{$class}{'cache'}{$attr} = DELETED_VALUE; $count++; if($delete_implies) { foreach my $method (@$delete_implies) { $class->$method($attr); } } foreach my $test_class (keys %{$Inherited_Set{$name}}) { next if($class eq $test_class); if($test_class->isa($class) && exists $Inherited_Set{$name}{$test_class}{'cache'}{$attr} && $Inherited_Set{$name}{$test_class}{'cache'}{$attr} == INHERITED_VALUE) { delete $Inherited_Set{$name}{$test_class}{'cache'}{$attr}; $Inherited_Set{$name}{$test_class}{'meta'}{'cache_is_valid'} = 0; } } } } # Not required #_invalidate_inherited_set_caches($class, $name) if($count); return $count; }; $methods{$inherit_method} = sub { shift->$inherits_method(@_) }; $methods{$inherits_method} = sub { my($class) = ref($_[0]) ? ref(shift) : shift; Carp::croak("Missing value(s) to inherit") unless(@_); my $count = 0; foreach my $attr (@_) { if(exists $Inherited_Set{$name}{$class}{'cache'}{$attr} && $Inherited_Set{$name}{$class}{'cache'}{$attr} == DELETED_VALUE) { delete $Inherited_Set{$name}{$class}{'cache'}{$attr}; $Inherited_Set{$name}{$class}{'meta'}{'cache_is_valid'} = 0; $count++; } if($inherit_implies) { foreach my $method (@$inherit_implies) { $class->$method($attr); } } } return $count; }; if($interface ne 'all') { Carp::croak "Unknown interface: $interface"; } return \%methods; } # Inlined above since it is private and only called once # sub _invalidate_inherited_set_caches # { # my($class, $name) = @_; # # foreach my $test_class (keys %{$Inherited_Set{$name}}) # { # if($test_class->isa($class) && $test_class ne $class) # { # $Inherited_Set{$name}{$test_class}{'meta'}{'cache_is_valid'} = 0; # } # } # } 1; __END__ =head1 NAME Rose::Class::MakeMethods::Set - Create class methods to manage sets. =head1 SYNOPSIS package MyClass; use Rose::Class::MakeMethods::Set ( inheritable_set => [ required_name => { add_implies => 'add_valid_name', test_method => 'name_is_required', }, ], inherited_set => [ valid_name => { test_method => 'name_is_valid', }, ], ); ... package MySubClass; our @ISA = qw(MyClass); ... MyClass->add_valid_names('A', 'B', 'C'); MyClass->add_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,B,C,D'; $r2 = join(',', MySubClass->required_names); # 'D' MySubClass->add_required_names('X', 'Y'); $v2 = join(',', MySubClass->valid_names); # 'A,B,C,D,X,Y'; $r2 = join(',', MySubClass->required_names); # 'D,X,Y' MySubClass->delete_valid_names('B', 'X'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'D,X,Y' MySubClass->delete_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'X,Y' =head1 DESCRIPTION L is a method maker that inherits from L. See the L documentation to learn about the interface. The method types provided by this module are described below. All methods work only with classes, not objects. =head1 METHODS TYPES =over 4 =item B Create a family of class methods for managing an inheritable set of items, each with an optional associated value. Each item must be a string, or must stringify to a unique string value, since a hash is used internally to store the set. The set is inherited by subclasses, but any subclass that accesses or manipulates the set in any way will immediately get its own private copy of the set I. The superclass from which the set is copied is the closest ("least super") class that has ever accessed or manipulated this set. These may sound like wacky rules, but it may help to know that this family of methods was created for use in the L family of modules to manage the set of required HTML attributes (and their optional default values) for various HTML tags. =over 4 =item Options =over 4 =item C A method name, or reference to a list of method names, to call when an item is added to the set. Each added attribute is passed as an argument to each method in the C list. =item C The name of the class method used to add a single item to the set. Defaults to the method name with the prefix C added. =item C The name of the class method used to add one or more items to the set. Defaults to C with C added to the end. =item C The name of the class method used to clear the contents of the set. Defaults to C with a C prefix added. =item C A method name, or reference to a list of method names, to call when an item is removed from the set. Each deleted attribute is passed as an argument to each method in the C list. =item C The name of the class method used to remove a single item from the set. Defaults to the method name with the prefix C added. =item C The name of the class method used to remove one or more items from the set. Defaults to C with a C prefix added. =item C The name of the class method that returns a reference to the actual hash that contains the set of items in scalar context, and a shallow copy of the hash in list context. Defaults to C with C<_hash> added to the end. =item C Choose the interface. This is kind of pointless since there is only one interface right now. Defaults to C, obviously. =item C The name of the class method that returns a reference to a sorted list of items in scalar context, or a sorted list in list context. If called with any arguments, the set is cleared with a call to C, then the set is repopulated by passing all of the arguments to a call to C. The method name defaults to C. =item C The plural name of the items, used to construct the default names for some other methods. Defaults to the method name with C added. =item C The name of the class method that tests for the existence of an item in the set. Defaults to the method name with the prefix C added. =item C The name of the class method used to get and set the (optional) value associated with each item in the set. Defaults to the method name with C<_value> added to the end. =back =item Interfaces =over 4 =item C Creates the entire family of methods described above. The example below illustrates their use. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Set ( inheritable_set => [ valid_name => { test_method => 'name_is_valid', delete_implies => 'delete_required_name', }, required_name => { add_implies => 'add_valid_name', test_method => 'name_is_required', }, ], ); package MySubClass; our @ISA = qw(MyClass); ... MyClass->add_valid_names('A', 'B', 'C'); MyClass->add_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,B,C,D'; $r2 = join(',', MySubClass->required_names); # 'D' MySubClass->add_required_names('X', 'Y'); $v2 = join(',', MySubClass->valid_names); # 'A,B,C,D,X,Y'; $r2 = join(',', MySubClass->required_names); # 'D,X,Y' MySubClass->delete_valid_names('B', 'X'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'D,Y' MySubClass->delete_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'Y' MyClass->name_is_required('D'); # true MySubClass->name_is_required('D'); # false $h = MyClass->valid_names_hash; # Careful! This is the actual hash used for set storage! # You should use delete_valid_name() instead! delete $h->{'C'}; MySubClass->required_name_value(Y => 'xval'); print MySubClass->required_name_value('Y'); # 'xval' %r = MySubClass->required_names_hash; print $r{'Y'}; # 'xval' # Okay: %r is a (shallow) copy, not the actual hash delete $r{'Y'}; =item B Create a family of class methods for managing an inherited set of items. Each item must be a string, or must stringify to a unique string value, since a hash is used internally to store the set. An inherited set is made up of the union of the sets of all superclasses, minus any items that are explicitly deleted in the current class. =over 4 =item Options =over 4 =item C A method name, or reference to a list of method names, to call when an item is added to the set. Each added attribute is passed as an argument to each method in the C list. =item C The name of the class method used to add a single item to the set. Defaults to the method name with the prefix C added. =item C The name of the class method used to add one or more items to the set. Defaults to C with C added to the end. =item C The name of the class method used to retrieve (or generate, if it doesn't exist) the internal cache for the set. This should be considered a private method, but it is listed here because it does take up a spot in the method namespace. Defaults to C with C<_cache> added to the end. =item C The name of the class method used to clear the contents of the set. Defaults to C with a C prefix added. =item C A method name, or reference to a list of method names, to call when an item is removed from the set. Each deleted attribute is passed as an argument to each method in the C list. =item C The name of the class method used to remove a single item from the set. Defaults to the method name with the prefix C added. =item C The name of the class method used to remove one or more items from the set. Defaults to C with a C prefix added. =item C The name of the class method that returns a hash (in list context) or a reference to a hash (in scalar context) that contains the set of items. The existence of a key in the hash indicates its existence in the set. Defaults to C with C<_hash> added to the end. =item C The name of the class method used to indicate that an inherited value that was previously deleted from the set should return to being inherited. Defaults to the method name with the prefix C added. =item C The name of the class method used to indicate that one or more inherited values that were previously deleted from the set should return to being inherited. Defaults to the C name with C added to the end. =item C Choose the interface. This is kind of pointless since there is only one interface right now. Defaults to C, obviously. =item C The name of the class method that returns a reference to a sorted list of items in scalar context, or a sorted list in list context. If called with any arguments, the set is cleared with a call to C, then the set is repopulated by passing all of the arguments to a call to C. The method name defaults to C. =item C The plural name of the items, used to construct the default names for some other methods. Defaults to the method name with C added. =item C The name of the class method that tests for the existence of an item in the set. Defaults to the method name with the prefix C added. =back =item Interfaces =over 4 =item C Creates the entire family of methods described above. The example below illustrates their use. =back =back Example: package MyClass; use Rose::Class::MakeMethods::Set ( inherited_set => [ valid_name => { test_method => 'name_is_valid', delete_implies => 'delete_required_name', inherit_implies => 'inherit_required_name', }, required_name => { add_implies => 'add_valid_name', test_method => 'name_is_required', }, ], ); ... package MySubClass; our @ISA = qw(MyClass); ... MyClass->add_valid_names('A', 'B', 'C'); MyClass->add_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D'; $r1 = join(',', MyClass->required_names); # 'D' $v2 = join(',', MySubClass->valid_names); # 'A,B,C,D'; $r2 = join(',', MySubClass->required_names); # 'D' MyClass->add_required_names('X', 'Y'); $v2 = join(',', MySubClass->valid_names); # 'A,B,C,D,X,Y'; $r2 = join(',', MySubClass->required_names); # 'D,X,Y' MySubClass->delete_valid_names('B', 'X'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D,X,Y'; $r1 = join(',', MyClass->required_names); # 'D,X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'D,Y' MySubClass->delete_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D,X,Y'; $r1 = join(',', MyClass->required_names); # 'D,X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'Y' MySubClass->inherit_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D,X,Y'; $r1 = join(',', MyClass->required_names); # 'D,X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'D,Y' MySubClass->delete_valid_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D,X,Y'; $r1 = join(',', MyClass->required_names); # 'D,X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,Y'; $r2 = join(',', MySubClass->required_names); # 'Y' MySubClass->inherit_valid_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,D,X,Y'; $r1 = join(',', MyClass->required_names); # 'D,X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'D,Y' MyClass->delete_valid_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,X,Y'; $r1 = join(',', MyClass->required_names); # 'X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,Y'; $r2 = join(',', MySubClass->required_names); # 'Y' MySubClass->add_required_name('D'); $v1 = join(',', MyClass->valid_names); # 'A,B,C,X,Y'; $r1 = join(',', MyClass->required_names); # 'X,Y' $v2 = join(',', MySubClass->valid_names); # 'A,C,D,Y'; $r2 = join(',', MySubClass->required_names); # 'D,Y' $h = MyClass->valid_names_hash; # This has no affect on the set. $h is not a reference to the # actual hash used for set storage. delete $h->{'C'}; $v1 = join(',', MyClass->valid_names); # 'A,B,C,X,Y'; $r1 = join(',', MyClass->required_names); # 'X,Y' =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.