accessors-1.01/0000755000076500007650000000000011027167475014666 5ustar spurkisspurkis00000000000000accessors-1.01/Build.PL0000444000076500007650000000133111027167475016156 0ustar spurkisspurkis00000000000000#!/usr/bin/perl =head1 NAME Build.PL - Build script generator for C module =head1 SYNOPSIS perl Build.PL ./Build ./Build test ./Build install =cut use strict; use warnings; use File::Spec; use Module::Build; my $build = Module::Build->new ( module_name => 'accessors', dist_version_from => 'lib/accessors.pm', create_makefile_pl => 'passthrough', create_readme => 1, license => 'perl', requires => { 'perl' => '5.6.0', }, build_requires => { 'Test::More' => '0.01', 'Module::Build' => '0.20', }, ); $build->create_build_script; __END__ =head1 AUTHOR Steve Purkis =cut accessors-1.01/Changes0000444000076500007650000000332011027167474016154 0ustar spurkisspurkis00000000000000Revision history for 'accessors' Perl pragma -------------------------------------------- All changes by Steve Purkis, unless otherwise noted. 1.01 + only run benchmark tests when $ENV{BENCHMARK_ACCESSORS} is set. (tests were failing randomly, and annoying lots of people) 1.00 + released as 1.0 to solidify the API & guarantee backwards compat + fixed RT #29753: Suppress warnings in "make test" (it was a bug in the test code) + included accessors::ro (read only) and accessors::rw (read/write) on chocolateboy's request. * changed performance test to be more lenient: 'set/get generated is < 15% slower than optimized (X %)' Threshold is now < 30% slower, because it was failing on some platforms (probably due to the amount of warnings generated by RT #29753, but upped the threshold anyway). + set more invalid accessor names [updated list from chocolateboy] 0.02 + made method-chaining accessors the default. * created accessors::classic and accessors::chained, and killed the 'use accessors qw( foo :style )' syntax. + now compat with perl 5.6+ [reported by Michael Schwern] + tests no longer noisy (no blib or benchmark diagnostics) [reported by Michael Schwern] + using closures + anon sub instead of eval [reported by Michael Schwern] + moved generation methods into simple subs & optimized (smaller pad to restore, results in faster, well factored code) + added InvalidNames to catch things like AUTOLOAD & DESTROY [reported by James Duncan] + s/cascading/chaining/ [reported by James Duncan] + refactored test suite, added benchmarks for classic accessors. + updated docs 0.01 + created Fri Sep 12 2003 after a conversation with Michael Schwern. accessors-1.01/INSTALL0000444000076500007650000000066111027167475015720 0ustar spurkisspurkis00000000000000======================== accessors Installation ======================== INSTALLATION ------------ Ideally, use the CPANPLUS or CPAN shell (`cpanp` or `cpan`) to download and install the latest distribution from your nearest CPAN. To install it manually type the following: perl Build.PL ./Build ./Build test ./Build install Or, if you prefer to use make: perl Makefile.PL make make test make install accessors-1.01/lib/0000755000076500007650000000000011027167474015433 5ustar spurkisspurkis00000000000000accessors-1.01/lib/accessors/0000755000076500007650000000000011027167475017421 5ustar spurkisspurkis00000000000000accessors-1.01/lib/accessors/chained.pm0000444000076500007650000000176411027167475021360 0ustar spurkisspurkis00000000000000=head1 NAME accessors::chained - create method chaining accessors in caller's package. =head1 SYNOPSIS package Foo; use accessors::chained qw( foo bar baz ); my $obj = bless {}, 'Foo'; # generates chaining accessors: $obj->foo( 'hello ' ) ->bar( 'world' ) ->baz( "!\n" ); print $obj->foo, $obj->bar, $obj->baz; =cut package accessors::chained; use strict; use warnings::register; use base qw( accessors ); our $VERSION = '1.01'; our $REVISION = (split(/ /, ' $Revision: 1.3 $ '))[2]; # inherit everything for now. 1; __END__ =head1 DESCRIPTION The B pragma lets you create simple method-chaining accessors at compile-time. This module exists for future backwards-compatability - if the default style of accessor ever changes, method-chaining accessors will still be available through this pragma. See L for documentation. =head1 AUTHOR Steve Purkis =head1 SEE ALSO L, L, L =cut accessors-1.01/lib/accessors/classic.pm0000444000076500007650000000431611027167474021401 0ustar spurkisspurkis00000000000000=head1 NAME accessors::classic - create 'classic' read/write accessor methods in caller's package. =head1 SYNOPSIS package Foo; use accessors::classic qw( foo bar baz ); my $obj = bless {}, 'Foo'; # always return the current value, even on set: $obj->foo( 'hello ' ) if $obj->bar( 'world' ) eq 'world'; print $obj->foo, $obj->bar, $obj->baz( "!\n" ); =cut package accessors::classic; use strict; use warnings::register; use base qw( accessors ); our $VERSION = '1.01'; our $REVISION = (split(/ /, ' $Revision: 1.5 $ '))[2]; use constant style => 'classic'; sub create_accessor { my ($class, $accessor, $property) = @_; # set/get is slightly faster if we eval instead of using a closure + anon # sub, but the difference is marginal (~5%), and this uses less memory... no strict 'refs'; *{$accessor} = sub { (@_ > 1) ? $_[0]->{$property} = $_[1] : $_[0]->{$property}; } } 1; __END__ =head1 DESCRIPTION The B pragma lets you create simple I Perl accessors at compile-time. The generated methods look like this: sub foo { my $self = shift; $self->{foo} = shift if (@_); return $self->{foo}; } They I return the current value. Note that there is I dash (C<->) prepended to the property name as there are in L. This is for backwards compatability. =head1 PERFORMANCE There is B when using generated accessors; in fact there is B. =over 4 =item * typically I<5-15% faster> than hard-coded accessors (like the above example). =item * typically I<1-15% slower> than I accessors (less readable). =item * typically a I performance hit at startup (accessors are created at compile-time). =item * uses the same anonymous sub to reduce memory consumption (sometimes by 80%). =back See the benchmark tests included with this distribution for more details. =head1 CAVEATS Classes using blessed scalarrefs, arrayrefs, etc. are not supported for sake of simplicity. Only hashrefs are supported. =head1 AUTHOR Steve Purkis =head1 SEE ALSO L, L, L, L, L =cut accessors-1.01/lib/accessors/ro.pm0000555000076500007650000000431011027167475020376 0ustar spurkisspurkis00000000000000=head1 NAME accessors::ro - create 'classic' read-only accessor methods in caller's package. =head1 SYNOPSIS package Foo; use accessors::ro qw( foo bar baz ); my $obj = bless { foo => 'read only? ' }, 'Foo'; # values are read-only, so set is disabled: print "oh my!\n" if $obj->foo( "set?" ) eq 'read only? '; # if you really need to change the vars, # you must use direct-variable-access: $obj->{bar} = 'i need a drink '; $obj->{baz} = 'now'; # always returns the current value: print $obj->foo, $obj->bar, $obj->baz, "!\n"; =cut package accessors::ro; use strict; use warnings::register; use base qw( accessors ); our $VERSION = '1.01'; our $REVISION = (split(/ /, ' $Revision: 1.4 $ '))[2]; use constant style => 'ro'; sub create_accessor { my ($class, $accessor, $property) = @_; # get is slightly faster if we eval instead of using a closure + anon # sub, but the difference is marginal (~5%), and this uses less memory... no strict 'refs'; *{$accessor} = sub { return $_[0]->{$property} }; } 1; __END__ =head1 DESCRIPTION The B pragma lets you create simple I read-only accessors at compile-time. The generated methods look like this: sub foo { my $self = shift; return $self->{foo}; } They I return the current value, just like L. =head1 PERFORMANCE There is B when using generated accessors; in fact there is B. =over 4 =item * typically I<5-15% faster> than hard-coded accessors (like the above example). =item * typically I<0-15% slower> than I accessors (less readable). =item * typically a I performance hit at startup (accessors are created at compile-time). =item * uses the same anonymous sub to reduce memory consumption (sometimes by 80%). =back See the benchmark tests included with this distribution for more details. =head1 CAVEATS Classes using blessed scalarrefs, arrayrefs, etc. are not supported for sake of simplicity. Only hashrefs are supported. =head1 AUTHOR Steve Purkis =head1 SEE ALSO L, L, L, L, L =cut accessors-1.01/lib/accessors/rw.pm0000555000076500007650000000161211027167475020410 0ustar spurkisspurkis00000000000000=head1 NAME accessors::rw - create 'classic' read/write accessor methods in caller's package. =head1 SYNOPSIS package Foo; use accessors::rw qw( foo bar baz ); my $obj = bless {}, 'Foo'; # always return the current value, even on set: $obj->foo( 'hello ' ) if $obj->bar( 'world' ) eq 'world'; print $obj->foo, $obj->bar, $obj->baz( "!\n" ); =cut package accessors::rw; use strict; use warnings::register; use base qw( accessors::classic ); our $VERSION = '1.01'; our $REVISION = (split(/ /, ' $Revision: 1.3 $ '))[2]; use constant style => 'rw'; 1; __END__ =head1 DESCRIPTION The B pragma lets you create simple I read/write accessors at compile-time. It is an alias for L. =head1 AUTHOR Steve Purkis . =head1 SEE ALSO L, L, L, L, L =cut accessors-1.01/lib/accessors.pm0000444000076500007650000001365211027167474017763 0ustar spurkisspurkis00000000000000=head1 NAME accessors - create accessor methods in caller's package. =head1 SYNOPSIS package Foo; use accessors qw( foo bar baz ); my $obj = bless {}, 'Foo'; # generates chaining accessors # that you can set like this: $obj->foo( 'hello ' ) ->bar( 'world' ) ->baz( "!\n" ); # you get the values by passing no params: print $obj->foo, $obj->bar, $obj->baz; =cut package accessors; use 5.006; use strict; use warnings::register; our $VERSION = '1.01'; our $REVISION = (split(/ /, ' $Revision: 1.22 $ '))[2]; our $Debug = 0; our $ExportLevel = 0; our @InvalidNames = qw( BEGIN CHECK INIT END DESTROY AUTOLOAD ); use constant style => 'chained'; sub import { my $class = shift; my $callpkg = caller( $class->ExportLevel ); my @properties = @_ or return; $class->create_accessors_for( $callpkg, @properties ); } sub create_accessors_for { my $class = shift; my $callpkg = shift; warn( 'creating ' . $class->style . ' accessors( ', join(' ',@_)," ) in pkg '$callpkg'" ) if $class->Debug; foreach my $property (@_) { my $accessor = "$callpkg\::$property"; die( "can't create $accessor - '$property' is not a valid name!" ) unless $class->isa_valid_name( $property ); warn( "creating " . $class->style . " accessor: $accessor\n" ) if $class->Debug > 1; $class->create_accessor( $accessor, $property ); } return $class; } sub create_accessor { my ($class, $accessor, $property) = @_; $property = "-$property"; # set/get is slightly faster if we eval instead of using a closure + anon # sub, but the difference is marginal (~5%), and this uses less memory... no strict 'refs'; *{$accessor} = sub { (@_ > 1) ? ($_[0]->{$property} = $_[1], return $_[0]) : $_[0]->{$property}; }; } sub isa_valid_name { my ($class, $property) = @_; return unless $property =~ /^(?!\d)\w+$/; return if grep {$property eq $_} $class->InvalidNames; return 1; } ## ## on the off-chance that someone will sub-class: ## ## don't like studly caps for sub-names, but stick with Exporter-like style... sub Debug { $Debug; } sub ExportLevel { $ExportLevel } sub InvalidNames { @InvalidNames } 1; __END__ =head1 DESCRIPTION The B pragma lets you create simple accessors at compile-time. This saves you from writing them by hand, which tends to result in I errors and a mess of duplicated code. It can also help you reduce the ammount of unwanted I that may creep into your codebase when you're feeling lazy. B was designed with laziness in mind. Method-chaining accessors are generated by default. Note that you can still use L directly for reasons of backwards compatability. See L for accessors that always return the current value if you don't like method chaining. =head1 GENERATED METHODS B will generate methods that return the current object on set: sub foo { my $self = shift; if (@_) { $self->{-foo} = shift; return $self; } else { return $self->{-foo}; } } This way they can be I together. =head2 Why prepend the dash? The dash (C<->) is prepended to the property name for a few reasons: =over 4 =item * interoperability with L. =item * to make it difficult to accidentally access the property directly ala: use accessors qw( foo ); $obj->{foo}; # prevents this by mistake $obj->foo; # when you probably meant this (this might sound woolly, but it's easy enough to do). =item * syntactic sugar (this I woolly :). =back You shouldn't care too much about how the property is stored anyway - if you do, you're likely trying to do something special (and should really consider writing the accessors out long hand), or it's simply a matter of preference in which case you can use L, or sub-class this module. =head1 PERFORMANCE There is B when using generated accessors; in fact there is B. =over 4 =item * typically I<10-30% faster> than hard-coded accessors (like the above example). =item * typically I<1-15% slower> than I accessors (less readable). =item * typically a I performance hit at startup (accessors are created at compile-time). =item * uses the same anonymous sub to reduce memory consumption (sometimes by 80%). =back See the benchmark tests included with this distribution for more details. =head1 MOTIVATION The main difference between the B pragma and other accessor generators is B. =over 4 =item * interface B is as easy as it gets. =item * a pragma it fits in nicely with the B pragma: use base qw( Some::Class ); use accessors qw( foo bar baz ); and accessors get created at compile-time. =item * no bells and whistles The module is extensible instead. =back =head1 SUB-CLASSING If you prefer a different style of accessor or you need to do something more complicated, there's nothing to stop you from sub-classing. It should be pretty easy. Look through L, L, and L to see how it's done. =head1 CAVEATS Classes using blessed scalarrefs, arrayrefs, etc. are not supported for sake of simplicity. Only hashrefs are supported. =head1 THANKS Thanks to Michael G. Schwern for indirectly inspiring this module, and for his feedback & suggestions. Also to Paul Makepeace and David Wright for showing me faster accessors, to chocolateboy for his contributions, the CPAN Testers for their bug reports, and to James Duncan and people on London.pm for their feedback. =head1 AUTHOR Steve Purkis =head1 SEE ALSO L, L Similar and related modules: L, L, L, L, L, L, L, L, L =cut accessors-1.01/Makefile.PL0000444000076500007650000000211511027167475016635 0ustar spurkisspurkis00000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.03 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'); accessors-1.01/MANIFEST0000444000076500007650000000046011027167475016015 0ustar spurkisspurkis00000000000000Build.PL Changes INSTALL lib/accessors.pm lib/accessors/chained.pm lib/accessors/classic.pm lib/accessors/ro.pm lib/accessors/rw.pm Makefile.PL MANIFEST MANIFEST.SKIP META.yml README t/01__basic.t t/02__chaining.t t/03__classic.t t/04__invalid.t t/05__default.t t/06__rw.t t/07__ro.t t/Benchmark.pm TODO accessors-1.01/MANIFEST.SKIP0000444000076500007650000000010711027167475016560 0ustar spurkisspurkis00000000000000^_build ^Build$ ^blib ~$ \.bak$ CVS ^\.DS_Store$ ^accessors- Makefile$ accessors-1.01/META.yml0000444000076500007650000000137211027167475016140 0ustar spurkisspurkis00000000000000--- name: accessors version: 1.01 author: - 'Steve Purkis ' abstract: create accessor methods in caller's package. license: perl resources: license: http://dev.perl.org/licenses/ requires: perl: 5.6.0 build_requires: Module::Build: 0.20 Test::More: 0.01 provides: accessors: file: lib/accessors.pm version: 1.01 accessors::chained: file: lib/accessors/chained.pm version: 1.01 accessors::classic: file: lib/accessors/classic.pm version: 1.01 accessors::ro: file: lib/accessors/ro.pm version: 1.01 accessors::rw: file: lib/accessors/rw.pm version: 1.01 generated_by: Module::Build version 0.2808 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 accessors-1.01/README0000444000076500007650000001027711027167475015553 0ustar spurkisspurkis00000000000000NAME accessors - create accessor methods in caller's package. SYNOPSIS package Foo; use accessors qw( foo bar baz ); my $obj = bless {}, 'Foo'; # generates chaining accessors # that you can set like this: $obj->foo( 'hello ' ) ->bar( 'world' ) ->baz( "!\n" ); # you get the values by passing no params: print $obj->foo, $obj->bar, $obj->baz; DESCRIPTION The accessors pragma lets you create simple accessors at compile-time. This saves you from writing them by hand, which tends to result in *cut-n-paste* errors and a mess of duplicated code. It can also help you reduce the ammount of unwanted *direct-variable access* that may creep into your codebase when you're feeling lazy. accessors was designed with laziness in mind. Method-chaining accessors are generated by default. Note that you can still use accessors::chained directly for reasons of backwards compatability. See accessors::classic for accessors that always return the current value if you don't like method chaining. GENERATED METHODS accessors will generate methods that return the current object on set: sub foo { my $self = shift; if (@_) { $self->{-foo} = shift; return $self; } else { return $self->{-foo}; } } This way they can be *chained* together. Why prepend the dash? The dash ("-") is prepended to the property name for a few reasons: * interoperability with Error. * to make it difficult to accidentally access the property directly ala: use accessors qw( foo ); $obj->{foo}; # prevents this by mistake $obj->foo; # when you probably meant this (this might sound woolly, but it's easy enough to do). * syntactic sugar (this *is* woolly :). You shouldn't care too much about how the property is stored anyway - if you do, you're likely trying to do something special (and should really consider writing the accessors out long hand), or it's simply a matter of preference in which case you can use accessors::classic, or sub-class this module. PERFORMANCE There is little-to-no performace hit when using generated accessors; in fact there is usually a performance gain. * typically *10-30% faster* than hard-coded accessors (like the above example). * typically *1-15% slower* than *optimized* accessors (less readable). * typically a *small* performance hit at startup (accessors are created at compile-time). * uses the same anonymous sub to reduce memory consumption (sometimes by 80%). See the benchmark tests included with this distribution for more details. MOTIVATION The main difference between the accessors pragma and other accessor generators is simplicity. * interface use accessors qw( ... ) is as easy as it gets. * a pragma it fits in nicely with the base pragma: use base qw( Some::Class ); use accessors qw( foo bar baz ); and accessors get created at compile-time. * no bells and whistles The module is extensible instead. SUB-CLASSING If you prefer a different style of accessor or you need to do something more complicated, there's nothing to stop you from sub-classing. It should be pretty easy. Look through accessors::classic, accessors::ro, and accessors::rw to see how it's done. CAVEATS Classes using blessed scalarrefs, arrayrefs, etc. are not supported for sake of simplicity. Only hashrefs are supported. THANKS Thanks to Michael G. Schwern for indirectly inspiring this module, and for his feedback & suggestions. Also to Paul Makepeace and David Wright for showing me faster accessors, to chocolateboy for his contributions, the CPAN Testers for their bug reports, and to James Duncan and people on London.pm for their feedback. AUTHOR Steve Purkis SEE ALSO accessors::classic, accessors::chained Similar and related modules: base, fields, Class::Accessor, Class::Struct, Class::Methodmaker, Class::Generate, Class::Class, Class::Tangram, Object::Tiny accessors-1.01/t/0000755000076500007650000000000011027167475015131 5ustar spurkisspurkis00000000000000accessors-1.01/t/01__basic.t0000444000076500007650000000021211027167475017027 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for accessors.pm ## use strict; use warnings; use Test::More tests => 1; use Carp; use_ok( "accessors" ); accessors-1.01/t/02__chaining.t0000444000076500007650000000256611027167475017545 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for accessors (and hence accessors::chained) ## use strict; use warnings; use Test::More tests => 12; use Carp; BEGIN { use_ok( "accessors::chained" ) }; my $time = shift || 0.5; my $foo = bless {}, 'Foo'; can_ok( $foo, 'bar' ); can_ok( $foo, 'baz' ); is( $foo->bar( 'set' )->baz( 2 ), $foo, 'set foo->bar->baz' ); is( $foo->bar, 'set', 'get foo->bar' ); is( $foo->baz, '2', 'get foo->baz' ); SKIP: { skip '$ENV{BENCHMARK_ACCESSORS} not set', 6 unless ($ENV{BENCHMARK_ACCESSORS}); eval "use Benchmark qw( timestr countit )"; # ya never know... skip 'Benchmark.pm not installed!', 6 if ($@); eval "use t::Benchmark"; die $@ if $@; test_generation_performance( 'accessors' ); test_set_get_performance( time => $time, generated => bless( {}, 'Generated' ), hardcoded => bless( {}, 'HardCoded' ), optimized => bless( {}, 'Optimized' ), ); } package Foo; use accessors::chained qw( bar baz ); # use different classes w/same accessor name + variable length # for performance tests... package Generated; use accessors::chained qw( foo ); package HardCoded; sub foo { my $self = shift; if (@_) { $self->{-foo} = shift; return $self; } else { return $self->{-foo}; } } package Optimized; sub foo { (@_ > 1) ? ($_[0]->{'-foo'} = $_[1], return $_[0]) : $_[0]->{'-foo'}; } accessors-1.01/t/03__classic.t0000444000076500007650000000245311027167474017401 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for accessors::classic ## use strict; use warnings; use Test::More tests => 12; use Carp; BEGIN { use_ok( "accessors::classic" ) }; my $time = shift || 0.5; my $foo = bless {}, 'Foo'; can_ok( $foo, 'bar' ); can_ok( $foo, 'baz' ); is( $foo->bar( 'set' ), 'set', 'set foo->bar' ); is( $foo->baz( 2 ), 2, 'set foo->baz' ); is( $foo->bar, 'set', 'get foo->bar' ); SKIP: { skip '$ENV{BENCHMARK_ACCESSORS} not set', 6 unless ($ENV{BENCHMARK_ACCESSORS}); eval "use Benchmark qw( timestr countit )"; # ya never know... skip 'Benchmark.pm not installed!', 6 if ($@); eval "use t::Benchmark"; die $@ if $@; test_generation_performance( 'accessors::classic' ); test_set_get_performance( time => $time, generated => bless( {}, 'Generated' ), hardcoded => bless( {}, 'HardCoded' ), optimized => bless( {}, 'Optimized' ), ); } package Foo; use accessors::classic qw( bar baz ); # use different classes w/same accessor name + variable length # for performance tests... package Generated; use accessors::classic qw( foo ); package HardCoded; sub foo { my $self = shift; $self->{foo} = shift if (@_); return $self->{foo}; } package Optimized; sub foo { (@_ > 1) ? $_[0]->{'foo'} = $_[1] : $_[0]->{'foo'}; } accessors-1.01/t/04__invalid.t0000444000076500007650000000050211027167474017400 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for invalid accessors ## use strict; use warnings; use Test::More tests => 9; use Carp; use_ok( "accessors" ); ## invalid accessor names do { eval { import accessors $_ }; ok( $@, "invalid accessor - $_" ); } for (qw( BEGIN CHECK INIT END DESTROY AUTOLOAD 1notasub @$%*&^';\/ )); accessors-1.01/t/05__default.t0000444000076500007650000000061611027167474017405 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for accessors.pm ## use strict; use warnings; use Test::More tests => 6; use Carp; BEGIN { use_ok( "accessors" ) }; ## use default style: my $foo = bless {}, 'Foo'; can_ok( $foo, 'bar' ); can_ok( $foo, 'baz' ); ok( $foo->bar( 1 ), 'set default' ); is( $foo->bar, 1 , 'get default' ); ok( !$foo->baz, 'get default'); package Foo; use accessors qw( bar baz ); accessors-1.01/t/06__rw.t0000444000076500007650000000100611027167475016405 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for accessors::rw ## use strict; use warnings; use Test::More tests => 6; use Carp; BEGIN { use_ok( "accessors::rw" ) }; my $time = shift || 0.5; my $foo = bless {}, 'Foo'; can_ok( $foo, 'bar' ); can_ok( $foo, 'baz' ); is( $foo->bar( 'set' ), 'set', 'set foo->bar' ); is( $foo->baz( 2 ), 2, 'set foo->baz' ); is( $foo->bar, 'set', 'get foo->bar' ); # no sense benchmarking this as it inherits from accessors::classic. package Foo; use accessors::rw qw( bar baz ); accessors-1.01/t/07__ro.t0000444000076500007650000000246411027167475016407 0ustar spurkisspurkis00000000000000#!/usr/bin/perl ## ## Tests for accessors::ro ## use strict; use warnings; use Test::More tests => 13; use Carp; BEGIN { use_ok( "accessors::ro" ) }; my $time = shift || 0.5; my $foo = bless { bar => 'read only' }, 'Foo'; can_ok( $foo, 'bar' ); can_ok( $foo, 'baz' ); is( $foo->bar( 'noop' ), 'read only', 'set foo->bar blocked' ); is( $foo->bar, 'read only', 'get foo->bar' ); is( $foo->baz, undef, 'get foo->baz' ); $foo->{baz} = 'set'; is( $foo->baz, 'set', 'get foo->baz' ); SKIP: { skip '$ENV{BENCHMARK_ACCESSORS} not set', 6 unless ($ENV{BENCHMARK_ACCESSORS}); eval "use Benchmark qw( timestr countit )"; # ya never know... skip 'Benchmark.pm not installed!', 6 if ($@); eval "use t::Benchmark"; die $@ if $@; test_generation_performance( 'accessors::ro' ); test_set_get_performance( time => $time, generated => bless( {}, 'Generated' ), hardcoded => bless( {}, 'HardCoded' ), optimized => bless( {}, 'Optimized' ), ); } package Foo; use accessors::ro qw( bar baz ); # use different classes w/same accessor name + variable length # for performance tests... package Generated; use accessors::ro qw( foo ); package HardCoded; sub foo { my $self = shift; return $self->{foo}; } package Optimized; sub foo { return $_[0]->{'foo'}; } accessors-1.01/t/Benchmark.pm0000444000076500007650000000420411027167475017357 0ustar spurkisspurkis00000000000000package t::Benchmark; use strict; use Benchmark qw( timethis timestr countit ); use Test::More; use base qw( Exporter ); our @EXPORT = qw( &test_generation_performance &test_set_get_performance ); sub test_generation_performance { my $accessor_class = shift; # generate ~100k accessor names to use up-front (to avoid skewing tests) # then loop through the list & time how long it takes to generate 'em my $i = 0; my @list = ('aa' .. 'aaaa'); # run the test my $r1; { package GeneratedAccessors; my $generator_code = sub { import $accessor_class ($list[$i++]); }; $r1 = Benchmark::timethis( scalar(@list), $generator_code ); } die "accessor generation benchmark failed!" unless $r1; print "# accessor generation: ", timestr( $r1 ), "\n"; my $gen_per_sec = int iters_per_sec( $r1 ); cmp_ok( $gen_per_sec, '>', 100, "generates $gen_per_sec accessors/sec (> 100)" ); } sub test_set_get_performance { my %type = @_; my $time = delete $type{time} || 1; my %r2; # don't use timethese - it's too noisy while (my ($type, $obj) = each %type) { my $x=0; print "# $type: "; $r2{$type} = countit( -$time, sub{$obj->foo($x++); $obj->foo;} ); print timestr( $r2{$type} ), "\n"; ok( $r2{$type}, "got benchmarks for $type" ); } die "set/get benchmark failed!" unless %r2; my $percent = percent_faster($r2{generated}, $r2{hardcoded}); cmp_ok( $percent, '>', 0.0, "set/get generated is faster than hardcoded ($percent%)" ); $percent = percent_faster($r2{generated}, $r2{optimized}); if ($percent > 0) { pass( "set/get generated is *faster* than optimized ($percent%)" ); } else { $percent = -$percent; cmp_ok( $percent, '<=', 30.0, "set/get generated is < 30% slower than optimized ($percent%)" ); } } ## these really belong in Benchmark.pm sub iters_per_sec { my $benchmark = shift; eval { $benchmark->iters / ($benchmark->[1] + $benchmark->[2]) }; } sub percent_faster { my ($b1, $b2) = @_; my ($p1, $p2) = map { iters_per_sec( $_ ) } ( $b1, $b2 ); my $percent = sprintf( '%.3f', eval { ($p1 - $p2) / $p1 * 100.0 } ); } 1; accessors-1.01/TODO0000444000076500007650000000041511027167475015354 0ustar spurkisspurkis00000000000000===================== accessors Todo List ===================== consider adding get/set style accessors: use accessors::setget qw( ... ); use accessors::get qw( ... ); use accessors::set qw( ... ); or maybe even: use getters qw( ... ); use setters qw( ... );