libclass-delegator-perl-0.09/0000755000175000017500000000000011015163715015104 5ustar nachonacholibclass-delegator-perl-0.09/Build.PL0000444000175000017500000000071311015163715016377 0ustar nachonachouse Module::Build; my $build = Module::Build->new( module_name => 'Class::Delegator', license => 'perl', configure_requires => { 'Module::Build' => '0.2701' }, recommends => { 'Test::Pod' => '1.20' }, build_requires => { 'Module::Build' => '0.2701', 'Test::More' => '0.17', }, create_makefile_pl => 'passthrough', create_readme => 1, ); $build->create_build_script; libclass-delegator-perl-0.09/Changes0000444000175000017500000000434011015163715016376 0ustar nachonachoRevision history for Perl extension Class::Delegator. 0.09 2008-05-22T03:27:06 - Removed the spelling test from the distribution, since it can fail on systems without a spell program or using a different locale. 0.08 2008-05-15T03:36:19 - Fixed a Perl 5.5 test failure. I never should have been testing for line number, anyway. The file name is enough. - Added a spelling test. No more typos! 0.07 2008-05-05T17:57:26 - Added the "configure_requires", and "recommends" parameters to Build.PL. 0.06 2006-01-02T18:28:48 - Fixed test failures on some platforms. It seems that how error line numbers are determined can vary from Perl to Perl. 0.05 2005-12-30T21:45:22 - Fixed a few more minor typos. - Added #line comments to the generated delegation methods that point to the context in which Class::Delegator was used. This makes debugging easier, as any exceptions will have an appropriate file name and line number rather than "at (eval 137) line 1". Patch from Sterling Hanenkamp. - Added meethod name information to the delegating methods, by assigning the method name to *__ANON__. 0.04 2005-11-02T03:04:23 - Minor documentation typo fix (cpan #12286). 0.03 2005-04-13T18:22:10 - Added a word missing from an error message. - Fixed a spelling error. Reported by Ramesh R. - Fixed a warning in the tests. 0.02 2005-01-29T20:36:34 - Added support for dispatching a single method call to multiple attributes. The "as" parameter can be used to dispatch to different methods in those multiple attributes. This brings things more in line with how Class::Delegation works. - Added a "Benchmarks" section to demonstrate the performance of Class::Delegator vs. Class::Delegation and manually-generated delegation methods. - When specified as an array reference, the "as" parameter no longer needs to contain the same number of items as the "send" parameter. But it does need to be the same number of items as in the "to" parameter when both "to" and "as" are array references. 0.01 2005-01-28T00:02:09 - Initial public release. libclass-delegator-perl-0.09/lib/0000755000175000017500000000000011015163715015652 5ustar nachonacholibclass-delegator-perl-0.09/lib/Class/0000755000175000017500000000000011015163715016717 5ustar nachonacholibclass-delegator-perl-0.09/lib/Class/Delegator.pm0000444000175000017500000002506511015163715021171 0ustar nachonachopackage Class::Delegator; # $Id: Delegator.pm 3912 2008-05-15 03:33:00Z david $ use strict; $Class::Delegator::VERSION = '0.09'; =begin comment Fake-out Module::Build. Delete if it ever changes to support =head1 headers other than all uppercase. =head1 NAME Class::Delegator - Simple and fast object-oriented delegation =end comment =head1 Name Class::Delegator - Simple and fast object-oriented delegation =head1 Synopsis package Car; use Class::Delegator send => 'start', to => '{engine}', send => 'power', to => 'flywheel', as => 'brake', send => [qw(play pause rewind fast_forward shuffle)], to => 'ipod', send => [qw(accelerate decelerate)], to => 'brakes', as => [qw(start stop)], send => 'drive', to => [qw(right_rear_wheel left_rear_wheel)], as => [qw(rotate_clockwise rotate_anticlockwise)] ; =head1 Description This module provides a subset of the functionality of Damian Conway's lovely L module. Why a subset? Well, I didn't need all of the fancy matching semantics, just string string specifications to map delegations. Furthermore, I wanted it to be fast (See L). And finally, since Class::Delegation uses an C block to do its magic, it doesn't work in persistent environments that don't execute C blocks, such as in L. However the specification semantics of Class::Delegator differ slightly from those of Class::Delegation, so this module isn't a drop-in replacement for Class::Delegation. Read on for details. =head2 Specifying methods to be delegated The names of methods to be redispatched can be specified using the C parameter. This parameter may be specified as a single string or as an array of strings. A single string specifies a single method to be delegated, while an array reference is a list of methods to be delegated. =head2 Specifying attributes to be delegated to Use the C parameter to specify the attribute(s) or accessor method(s) to which the method(s) specified by the C parameter are to be delegated. The semantics of the C parameter are a bit different from Class::Delegation. In order to ensure the fastest performance possible, this module simply installs methods into the calling class to handle the delegation. There is no use of C<$AUTOLOAD> or other such trickery. But since the new methods are installed by Cing a string, the C parameter for each delegation statement must be specified in the manner appropriate to accessing the underlying attribute. For example, to delegate a method call to an attribute stored in a hash key, simply wrap the key in braces: use Class::Delegator send => 'start', to => '{engine}', ; To delegate to a method, simply name the method: use Class::Delegator send => 'power', to => 'flywheel', ; If your objects are array-based, wrap the appropriate array index number in brackets: use Class::Delegator send => 'idle', to => '[3]', ; And so on. =head2 Specifying the name of a delegated method Sometimes it's necessary for the name of the method that's being delegated to be different from the name of the method to which you're delegating execution. For example, your class might already have a method with the same name as the method to which you're delegating. The C parameter allows you translate the method name or names in a delegation statement. The value associated with an C parameter specifies the name of the method to be invoked, and may be a string or an array (with the number of elements in the array matching the number of elements in a corresponding C array). If the attribute is specified via a single string, that string is taken as the name of the attribute to which the associated method (or methods) should be delegated. For example, to delegate invocations of C<$self-Epower(...)> to C<$self-E{flywheel}-Ebrake(...)>: use Class::Delegator send => 'power', to => '{flywheel}', as => 'brake', ; If both the C and the C parameters specify array references, each local method name and deleted method name form a pair, which is invoked. For example: use Class::Delegator send => [qw(accelerate decelerate)], to => 'brakes', as => [qw(start stop)], ; In this example, the C method will be delegated to the C method of the C attribute and the C method will be delegated to the C method of the C attribute. =head2 Delegation to multiple attributes in parallel An array reference can be used as the value of the C parameter to specify the a list of attributes, I are delegated to--in the same order as they appear in the array. In this case, the C parameter B be a scalar value, not an array of methods to delegate. For example, to distribute invocations of C<$self-Edrive(...)> to both C<$self-E{left_rear_wheel}-Edrive(...)> and C<$self-E{right_rear_wheel}-Edrive(...)>: use Class::Delegator send => 'drive', to => ["{left_rear_wheel}", "{right_rear_wheel}"] ; Note that using an array to specify parallel delegation has an effect on the return value of the delegation method specified by the C parameter. In a scalar context, the original call returns a reference to an array containing the (scalar context) return values of each of the calls. In a list context, the original call returns a list of array references containing references to the individual (list context) return lists of the calls. So, for example, if the C method of a class were delegated like so: use Class::Delegator send => 'cost', to => ['supplier', 'manufacturer', 'distributor'] ; then the total cost could be calculated like this: use List::Util 'sum'; my $total = sum @{$obj->cost()}; If both the C<"to"> key and the C<"as"> parameters specify multiple values, then each attribute and method name form a pair, which is invoked. For example: use Class::Delegator send => 'escape', to => ['{flywheel}', '{smokescreen}'], as => ['engage', 'release'], ; would sequentially call, within the C delegation method: $self->{flywheel}->engage(...); $self->{smokescreen}->release(...); =cut ############################################################################## sub import { my $class = shift; my ($caller, $filename, $line) = caller; while (@_) { my ($key, $send) = (shift, shift); _die(qq{Expected "send => " but found "$key => $send"}) unless $key eq 'send'; ($key, my $to) = (shift, shift); _die(qq{Expected "to => " but found "$key => $to"}) unless $key eq 'to'; _die('Cannot specify both "send" and "to" as arrays') if ref $send && ref $to; if (ref $to) { my $as = ($_[0] || '') eq 'as' ? (shift, shift) : undef; if (ref $as) { _die('Arrays specified for "to" and "as" must be the same length') unless @$to == @$as; } elsif (defined $as) { _die('Cannot specify "as" as a scalar if "to" is an array') } else { $as = []; } my $meth = "$caller\::$send"; my @lines = ( # Copy @_ to @args to ensure same args passed to all methods. "#line $line $filename", "sub { local \*__ANON__ = '$meth';", 'my ($self, @args) = @_;', 'my @ret;', ); my @array = ( 'return (', ); my @scalar = ( ') if wantarray;', 'return [', ); while (@$to) { my $t = shift @$to; my $m = shift @$as || $send; push @scalar, "scalar \$self->$t->$m(\@args),"; push @array, "[\$self->$t->$m(\@args)],"; } no strict 'refs'; *{$meth} = eval join "\n", @lines, @array, @scalar, ']', '}'; } else { my $as = ($_[0] || '') eq 'as' ? (shift, ref $_[0] ? shift : [shift]) : []; $send = [$send] unless ref $send; while (@$send) { my $s = shift @$send; my $m = shift @$as || $s; my $meth = "$caller\::$s"; no strict 'refs'; *{$meth} = eval qq{#line $line $filename sub { local \*__ANON__ = '$meth'; shift->$to->$m(\@_); }; }; } } } } sub _die { require Carp; Carp::croak(@_); } ############################################################################## =head1 Benchmarks I whipped up a quick script to compare the performance of Class::Delegator to Class::Delegation and a manually-installed delegation method (the control). I'll let the numbers speak for themselves: Benchmark: timing 1000000 iterations of Class::Delegation, Class::Delegator, Manually... Class::Delegation: 106 wallclock secs (89.03 usr + 2.09 sys = 91.12 CPU) @ 10974.54/s (n=1000000) Class::Delegator: 3 wallclock secs ( 3.44 usr + 0.02 sys = 3.46 CPU) @ 289017.34/s (n=1000000) Control: 3 wallclock secs ( 3.01 usr + 0.02 sys = 3.03 CPU) @ 330033.00/s (n=1000000) =head1 Bugs Please send bug reports to or report them via the CPAN Request Tracker at L. =head1 Author =begin comment Fake-out Module::Build. Delete if it ever changes to support =head1 headers other than all uppercase. =head1 AUTHOR =end comment David Wheeler =head1 See Also =over =item L Damian Conway's brilliant module does ten times what this one does--and does it ten times slower. =item L Kurt Starsinic's module uses inheritance to manage delegation, and has a somewhat more complex interface. =item L Simon Cozen's delegation module takes the same approach as this module, but provides no method for resolving method name clashes the way this module's C parameter does. =back =head1 Copyright and License Copyright (c) 2005-2008 David Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut libclass-delegator-perl-0.09/Makefile.PL0000444000175000017500000000212211015163715017051 0ustar nachonacho# Note: this file was auto-generated by Module::Build::Compat version 0.2808_01 unless (eval "use Module::Build::Compat 0.02; 1" ) { print "This module requires Module::Build to install itself.\n"; require ExtUtils::MakeMaker; my $yn = ExtUtils::MakeMaker::prompt (' Install Module::Build now from CPAN?', 'y'); unless ($yn =~ /^y/i) { die " *** Cannot install without Module::Build. Exiting ...\n"; } require Cwd; require File::Spec; require CPAN; # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); CPAN::Shell->install('Module::Build::Compat'); CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate or die "Couldn't install Module::Build, giving up.\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); libclass-delegator-perl-0.09/MANIFEST0000444000175000017500000000020411015163715016227 0ustar nachonachoBuild.PL Changes lib/Class/Delegator.pm Makefile.PL MANIFEST This list of files META.yml README t/base.t t/pod-coverage.t t/pod.t libclass-delegator-perl-0.09/META.yml0000444000175000017500000000105611015163715016355 0ustar nachonacho--- name: Class-Delegator version: 0.09 author: - 'David Wheeler ' abstract: Simple and fast object-oriented delegation license: perl resources: license: http://dev.perl.org/licenses/ configure_requires: Module::Build: 0.2701 build_requires: Module::Build: 0.2701 Test::More: 0.17 recommends: Test::Pod: 1.20 provides: Class::Delegator: file: lib/Class/Delegator.pm version: 0.09 generated_by: Module::Build version 0.280801 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 libclass-delegator-perl-0.09/README0000444000175000017500000001752611015163715015775 0ustar nachonachoName Class::Delegator - Simple and fast object-oriented delegation Synopsis package Car; use Class::Delegator send => 'start', to => '{engine}', send => 'power', to => 'flywheel', as => 'brake', send => [qw(play pause rewind fast_forward shuffle)], to => 'ipod', send => [qw(accelerate decelerate)], to => 'brakes', as => [qw(start stop)], send => 'drive', to => [qw(right_rear_wheel left_rear_wheel)], as => [qw(rotate_clockwise rotate_anticlockwise)] ; Description This module provides a subset of the functionality of Damian Conway's lovely Class::Delegation module. Why a subset? Well, I didn't need all of the fancy matching semantics, just string string specifications to map delegations. Furthermore, I wanted it to be fast (See Benchmarks). And finally, since Class::Delegation uses an "INIT" block to do its magic, it doesn't work in persistent environments that don't execute "INIT" blocks, such as in mod_perl. However the specification semantics of Class::Delegator differ slightly from those of Class::Delegation, so this module isn't a drop-in replacement for Class::Delegation. Read on for details. Specifying methods to be delegated The names of methods to be redispatched can be specified using the "send" parameter. This parameter may be specified as a single string or as an array of strings. A single string specifies a single method to be delegated, while an array reference is a list of methods to be delegated. Specifying attributes to be delegated to Use the "to" parameter to specify the attribute(s) or accessor method(s) to which the method(s) specified by the "send" parameter are to be delegated. The semantics of the "to" parameter are a bit different from Class::Delegation. In order to ensure the fastest performance possible, this module simply installs methods into the calling class to handle the delegation. There is no use of $AUTOLOAD or other such trickery. But since the new methods are installed by "eval"ing a string, the "to" parameter for each delegation statement must be specified in the manner appropriate to accessing the underlying attribute. For example, to delegate a method call to an attribute stored in a hash key, simply wrap the key in braces: use Class::Delegator send => 'start', to => '{engine}', ; To delegate to a method, simply name the method: use Class::Delegator send => 'power', to => 'flywheel', ; If your objects are array-based, wrap the appropriate array index number in brackets: use Class::Delegator send => 'idle', to => '[3]', ; And so on. Specifying the name of a delegated method Sometimes it's necessary for the name of the method that's being delegated to be different from the name of the method to which you're delegating execution. For example, your class might already have a method with the same name as the method to which you're delegating. The "as" parameter allows you translate the method name or names in a delegation statement. The value associated with an "as" parameter specifies the name of the method to be invoked, and may be a string or an array (with the number of elements in the array matching the number of elements in a corresponding "send" array). If the attribute is specified via a single string, that string is taken as the name of the attribute to which the associated method (or methods) should be delegated. For example, to delegate invocations of "$self->power(...)" to "$self->{flywheel}->brake(...)": use Class::Delegator send => 'power', to => '{flywheel}', as => 'brake', ; If both the "send" and the "as" parameters specify array references, each local method name and deleted method name form a pair, which is invoked. For example: use Class::Delegator send => [qw(accelerate decelerate)], to => 'brakes', as => [qw(start stop)], ; In this example, the "accelerate" method will be delegated to the "start" method of the "brakes" attribute and the "decelerate" method will be delegated to the "stop" method of the "brakes" attribute. Delegation to multiple attributes in parallel An array reference can be used as the value of the "to" parameter to specify the a list of attributes, *all of which* are delegated to--in the same order as they appear in the array. In this case, the "send" parameter must be a scalar value, not an array of methods to delegate. For example, to distribute invocations of "$self->drive(...)" to both "$self->{left_rear_wheel}->drive(...)" and "$self->{right_rear_wheel}->drive(...)": use Class::Delegator send => 'drive', to => ["{left_rear_wheel}", "{right_rear_wheel}"] ; Note that using an array to specify parallel delegation has an effect on the return value of the delegation method specified by the "send" parameter. In a scalar context, the original call returns a reference to an array containing the (scalar context) return values of each of the calls. In a list context, the original call returns a list of array references containing references to the individual (list context) return lists of the calls. So, for example, if the "cost" method of a class were delegated like so: use Class::Delegator send => 'cost', to => ['supplier', 'manufacturer', 'distributor'] ; then the total cost could be calculated like this: use List::Util 'sum'; my $total = sum @{$obj->cost()}; If both the "to" key and the "as" parameters specify multiple values, then each attribute and method name form a pair, which is invoked. For example: use Class::Delegator send => 'escape', to => ['{flywheel}', '{smokescreen}'], as => ['engage', 'release'], ; would sequentially call, within the "escape()" delegation method: $self->{flywheel}->engage(...); $self->{smokescreen}->release(...); Benchmarks I whipped up a quick script to compare the performance of Class::Delegator to Class::Delegation and a manually-installed delegation method (the control). I'll let the numbers speak for themselves: Benchmark: timing 1000000 iterations of Class::Delegation, Class::Delegator, Manually... Class::Delegation: 106 wallclock secs (89.03 usr + 2.09 sys = 91.12 CPU) @ 10974.54/s (n=1000000) Class::Delegator: 3 wallclock secs ( 3.44 usr + 0.02 sys = 3.46 CPU) @ 289017.34/s (n=1000000) Control: 3 wallclock secs ( 3.01 usr + 0.02 sys = 3.03 CPU) @ 330033.00/s (n=1000000) Bugs Please send bug reports to or report them via the CPAN Request Tracker at . Author David Wheeler See Also Class::Delegation Damian Conway's brilliant module does ten times what this one does--and does it ten times slower. Class::Delegate Kurt Starsinic's module uses inheritance to manage delegation, and has a somewhat more complex interface. Class::HasA Simon Cozen's delegation module takes the same approach as this module, but provides no method for resolving method name clashes the way this module's "as" parameter does. Copyright and License Copyright (c) 2005-2008 David Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. libclass-delegator-perl-0.09/t/0000755000175000017500000000000011015163715015347 5ustar nachonacholibclass-delegator-perl-0.09/t/base.t0000555000175000017500000002211111015163715016444 0ustar nachonacho#!perl -w # $Id: base.t 3872 2008-05-09 19:36:23Z david $ use strict; use Test::More tests => 99; BEGIN { use_ok('Class::Delegator') } FOO: { package MyTest::Foo; sub new { bless {} } sub bar { my $self = shift; return $self->{bar} unless @_; $self->{bar} = shift; }; sub try { my $self = shift; return $self->{try} unless @_; $self->{try} = shift; }; } can_ok 'MyTest::Foo' => 'new'; can_ok 'MyTest::Foo' => 'bar'; can_ok 'MyTest::Foo' => 'try'; SIMPLE: { package MyTest::Simple; sub new { bless { foo => MyTest::Foo->new } } use Class::Delegator send => 'bar', to => '{foo}', ; } can_ok 'MyTest::Simple' => 'bar'; ok my $d = MyTest::Simple->new, "Construct new simple object"; is $d->bar, $d->{foo}->bar, "Make sure the simple values are the same"; ok $d->bar('hello'), "Set the value via the simple delegate"; is $d->bar, 'hello', "Make sure that the simple attribute was set"; is $d->{foo}->bar, 'hello', "And that it is in the simple contained object"; TWOSIMPLE: { package MyTest::TwoSimple; sub new { bless { foo => MyTest::Foo->new, foo2 => MyTest::Foo->new } } use Class::Delegator send => 'bar', to => '{foo}', send => 'try', to => '{foo2}', ; } can_ok 'MyTest::TwoSimple' => 'bar'; can_ok 'MyTest::TwoSimple' => 'try'; ok $d = MyTest::TwoSimple->new, "Construct new two simple object"; is $d->bar, $d->{foo}->bar, "Make sure the bar simple values are the same"; ok $d->bar('hello'), "Set the value via the bar simple delegate"; is $d->bar, 'hello', "Make sure that the bar simple attribute was set"; is $d->{foo}->bar, 'hello', "And that it is in the bar simple contained object"; isnt $d->bar, $d->try, "Make sure that the two values are different"; is $d->try, $d->{foo2}->try, "Make sure the try simple values are the same"; ok $d->try('fee'), "Set the value via the try simple delegate"; is $d->try, 'fee', "Make sure that the try simple attribute was set"; is $d->{foo2}->try, 'fee', "And that it is in the try simple contained object"; isnt $d->bar, $d->try, "Make sure that the two values are still different"; AS: { package MyTest::As; sub new { bless { foo => MyTest::Foo->new } } use Class::Delegator send => 'yow', to => '{foo}', as => 'bar', ; } ok ! MyTest::As->can('bar'), "MyTest::As cannot 'bar'"; can_ok 'MyTest::As' => 'yow'; ok $d = MyTest::As->new, "Construct new as object"; is $d->yow, $d->{foo}->bar, "Make sure the as values are the same"; ok $d->yow('hello'), "Set the as value via the delegate"; is $d->yow, 'hello', "Make sure that the as attribute was set"; is $d->{foo}->bar, 'hello', "And that it is in the as contained object"; METHOD: { package MyTest::Method; sub new { bless { foo => MyTest::Foo->new } } sub foo { shift->{foo} } use Class::Delegator send => 'bar', to => 'foo', ; } can_ok 'MyTest::Method' => 'bar'; ok $d = MyTest::Method->new, "Construct new meth object"; is $d->bar, $d->foo->bar, "Make sure the meth values are the same"; ok $d->bar('hello'), "Set the value via the meth delegate"; is $d->bar, 'hello', "Make sure that the meth attribute was set"; is $d->foo->bar, 'hello', "And that it is in the contained object"; ARRAY: { package MyTest::Array; sub new { bless [ MyTest::Foo->new ] } use Class::Delegator send => 'bar', to => '[0]', ; } can_ok 'MyTest::Array' => 'bar'; ok $d = MyTest::Array->new, "Construct new array object"; is $d->bar, $d->[0]->bar, "Make sure the array values are the same"; ok $d->bar('hello'), "Set the value via the array delegate"; is $d->bar, 'hello', "Make sure that the array attribute was set"; is $d->[0]->bar, 'hello', "And that it is in the contained object"; MULTI: { package MyTest::Multi; sub new { bless { foo => MyTest::Foo->new } } use Class::Delegator send => [qw(bar try)], to => '{foo}', ; } can_ok 'MyTest::Multi' => 'bar'; can_ok 'MyTest::Multi' => 'try'; ok $d = MyTest::Multi->new, "Construct new multi object"; is $d->bar, $d->{foo}->bar, "Make sure the bar values are the same"; ok $d->bar('hello'), "Set the value via the bar delegate"; is $d->bar, 'hello', "Make sure that the bar attribute was set"; is $d->{foo}->bar, 'hello', "And that it is in the foo contained object"; is $d->try, $d->{foo}->try, "Make sure the try values are the same"; ok $d->try('hello'), "Set the value via the try delegate"; is $d->try, 'hello', "Make sure that the try attribute was set"; is $d->{foo}->try, 'hello', "And that it is in the foo contained object"; MULTIAS: { package MyTest::MultiAs; sub new { bless { foo => MyTest::Foo->new } } use Class::Delegator send => [qw(rab yrt)], to => '{foo}', as => [qw(bar try)], ; } can_ok 'MyTest::MultiAs' => 'rab'; can_ok 'MyTest::MultiAs' => 'yrt'; ok $d = MyTest::MultiAs->new, "Construct new multi object"; is $d->rab, $d->{foo}->bar, "Make sure the rab values are the same"; ok $d->rab('hello'), "Set the value via the rab delegate"; is $d->rab, 'hello', "Make sure that the rab attribute was set"; is $d->{foo}->bar, 'hello', "And that it is in the foo contained object"; is $d->yrt, $d->{foo}->try, "Make sure the yrt values are the same"; ok $d->yrt('hello'), "Set the value via the yrt delegate"; is $d->yrt, 'hello', "Make sure that the yrt attribute was set"; is $d->{foo}->try, 'hello', "And that it is in the foo contained object"; MULTITO: { package MyTest::MultiTo; sub new { bless { foo => MyTest::Foo->new, bat => MyTest::Foo->new } } use Class::Delegator send => 'bar', to => ['{foo}', '{bat}'], ; } can_ok 'MyTest::MultiTo' => 'bar'; ok $d = MyTest::MultiTo->new, "Construct new MultiTo object"; is $d->{foo}->bar, undef, "Check that foo's bar is undef"; is $d->{bat}->bar, undef, "Check that bat's bar is undef"; ok $d->bar('yo'), "Set bar_try to 'yo'"; is $d->{foo}->bar, 'yo', "Check that foo's bar is now 'yo'"; is $d->{bat}->bar, 'yo', "Check that bat's bar is now 'yow'"; # Try getting the results. ok $d = MyTest::MultiTo->new, "Construct another MultiTo object"; is_deeply [$d->bar(1)], [[1], [1]], "Check return array"; is_deeply scalar $d->bar(1), [1, 1], "Check return arrayref"; MULTITOAS: { package MyTest::MultiToAs; sub new { bless { foo => MyTest::Foo->new, bat => MyTest::Foo->new } } use Class::Delegator send => 'bar_try', to => ['{foo}', '{bat}'], as => [qw(bar try)], ; } can_ok 'MyTest::MultiToAs' => 'bar_try'; ok $d = MyTest::MultiToAs->new, "Construct new MultiToAs object"; is $d->{foo}->bar, undef, "Check that foo's bar is undef"; is $d->{foo}->try, undef, "Check that foo's try is undef"; is $d->{bat}->bar, undef, "Check that bat's bar is undef"; is $d->{bat}->try, undef, "Check that bat's try is undef"; ok $d->bar_try('yo'), "Set bar_try to 'yo'"; is $d->{foo}->bar, 'yo', "Check that foo's bar is now 'yo'"; is $d->{foo}->try, undef, "Check that foo's try is still undef"; is $d->{bat}->bar, undef, "Check that bat's bar is still undef"; is $d->{bat}->try, 'yo', "Check that bat's try is now 'yow'"; ERRORS: { package MyTest::Errors; use Test::More; sub new { bless {} } sub try {} eval { Class::Delegator->import(foo => 'bar') }; ok my $err = $@, "Catch 'missing send' exception"; like $err, qr/Expected "send => " but found "foo => bar"/, "Caught correct 'missing send' exception"; eval { Class::Delegator->import(send => 'foo', foo => 'bar') }; ok $err = $@, "Catch 'missing to' exception"; like $err, qr/Expected "to => " but found "foo => bar"/, "Caught correct 'missing to' exception"; eval { Class::Delegator->import(send => [], to => []) }; ok $err = $@, "Catch 'double array' exception"; like $err, qr/Cannot specify both "send" and "to" as arrays/, "Caught correct 'double array' exception"; eval { Class::Delegator->import(send => 'foo', to => [1], as => []) }; ok $err = $@, "Catch 'different length' exception"; like $err, qr/Arrays specified for "to" and "as" must be the same length/, "Caught correct 'different length' exception"; eval { Class::Delegator->import(send => 'foo', to => [1], as => 1) }; ok $err = $@, "Catch 'scalar as' exception"; like $err, qr/Cannot specify "as" as a scalar if "to" is an array/, "Caught correct 'scalar as' exception"; } LINENOS: { package MyTest::LineNos; use Test::More; sub new { bless {} } sub try { die 'Ow' } # Fake out line numbering so that we can just use one in the test. #line 248 t/base.t use Class::Delegator send => 'hey', # Line 251, error should be from here. to => 'try' ; # Line 253, sometimes error is here. No idea why. } ok my $try = MyTest::LineNos->new, 'Create new LineNos object'; use Carp; local $SIG{__DIE__} = \&confess; eval { $try->hey }; ok my $err = $@, 'Should Catch exception'; my $fn = 't/base.t'; like $err, qr/called (?:at\s+$fn|$fn\s+at)\s+line/, 'The exception should have this file name in it'; like $err, qr/MyTest::LineNos::hey/, 'The exception should have the name of the delegating method'; libclass-delegator-perl-0.09/t/pod-coverage.t0000555000175000017500000000036411015163715020113 0ustar nachonacho#!perl -w # $Id: pod-coverage.t 1168 2005-01-28 00:04:16Z david $ use strict; use Test::More; eval "use Test::Pod::Coverage 1.06"; plan skip_all => "Test::Pod::Coverage 1.06 required for testing POD coverage" if $@; all_pod_coverage_ok(); libclass-delegator-perl-0.09/t/pod.t0000555000175000017500000000031011015163715016311 0ustar nachonacho#!perl -w # $Id: pod.t 1168 2005-01-28 00:04:16Z david $ use strict; use Test::More; eval "use Test::Pod 1.20"; plan skip_all => "Test::Pod 1.20 required for testing POD" if $@; all_pod_files_ok();