Class-Std-Fast-v0.0.8/0000755000000000000000000000000011016517372013076 5ustar rootrootClass-Std-Fast-v0.0.8/t/0000755000000000000000000000000011016517372013341 5ustar rootrootClass-Std-Fast-v0.0.8/t/access_automethod.t0000444000000000000000000000317311016517372017222 0ustar rootrootuse Test::More 'no_plan'; package Object::POOF::DB; use warnings; use strict; use Carp qw(cluck); use Class::Std::Fast; # Module implementation here { my %dbname_of :ATTR; sub BUILD { my ($self, $ident, $arg_ref) = @_; # set optional constructor values: if ($arg_ref->{dbname}) { $self->set_dbname( $arg_ref->{dbname} ); } } sub AUTOMETHOD : RESTRICTED { my ($self, $ident, $value) = @_; my $subname = $_; # subname passed via $_ # return failure if not get_something or set_something my ($mode, $name) = $subname =~ m/\A ([gs]et)_(.*) \z/xms or return; # if get, return a sub that gives the value if ($mode eq 'get') { if ($name eq 'dbname') { return sub { return $dbname_of{$ident} } } } # if set, return a sub that sets the value elsif ($mode eq 'set') { if ($name eq 'dbname') { return sub { $dbname_of{$ident} = $value }} } return; # for posterity } } package TestApp::DB; use Class::Std::Fast; use base qw( Object::POOF::DB ); { sub BUILD { my ($self, $ident, $arg_ref) = @_; # set defaults if not set in constructor $self->get_dbname or $self->set_dbname('test'); } sub verify { my ($self) = @_; ::is $self->get_dbname(), 'test' => 'Restricted AUTOMETHOD ok'; } } package main; my $obj = TestApp::DB->new(); $obj->verify(); ok !eval { $obj->get_dbname() } => 'Restricted AUTOMETHOD inaccessible'; like $@, qr/Can't call restricted/ => 'Restricted AUTOMETHOD error msg'; Class-Std-Fast-v0.0.8/t/start.t0000444000000000000000000000154511016517372014666 0ustar rootrootprint "1..4\n"; package MyBase; use Class::Std::Fast; { my %attr : ATTR( :default(42) ); sub BUILD { my ($self, $id) = @_; print 'not ' if defined $attr{$id}; print "ok 1 - Default not available in BUILD\n"; } sub START { my ($self, $id) = @_; print 'not ' if !defined $attr{$id}; print "ok 3 - Default set before START\n"; } } package Der; use Class::Std::Fast; use base qw( MyBase ); { my %attr : ATTR( :init_arg ); sub BUILD { my ($self, $id) = @_; print 'not ' if defined $attr{$id}; print "ok 2 - Init arg not available in BUILD\n"; } sub START { my ($self, $id) = @_; print 'not ' if !defined $attr{$id} || $attr{$id} ne '86'; print "ok 4 - Init arg set before START\n"; } } package main; Der->new({ attr=>86 }); Class-Std-Fast-v0.0.8/t/cumulative.t0000444000000000000000000000623311016517372015706 0ustar rootrootpackage Base1; use Class::Std::Fast; BEGIN{ @ISA = qw( Base2 ); } { sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ } sub der_first :CUMULATIVE { return __PACKAGE__ } sub shift_obj :CUMULATIVE { return shift } } package Base2; use Class::Std::Fast; { sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ } sub der_first :CUMULATIVE { return __PACKAGE__ } sub shift_obj :CUMULATIVE { return shift } } package Base3; use Class::Std::Fast; use base qw( Base2 ); { sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ } sub der_first :CUMULATIVE { return __PACKAGE__ } sub shift_obj :CUMULATIVE { return shift } } package Base4; use Class::Std::Fast; { sub base_first { return __PACKAGE__ } sub der_first { return __PACKAGE__ } sub shift_obj { return shift } } package Der1; use Class::Std::Fast; use base qw(Base1 Base2 Base3 Base4); { sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ } sub der_first :CUMULATIVE { return __PACKAGE__ } sub shift_obj :CUMULATIVE { return shift } } package Der2; use Class::Std::Fast; use base qw(Base1 Base2 Base3 Base4); { sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ } sub der_first :CUMULATIVE { return __PACKAGE__ } sub shift_obj :CUMULATIVE { return shift } } package Reder1; use Class::Std::Fast; use base qw(Der1 Der2); { sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ } sub der_first :CUMULATIVE { return __PACKAGE__ } sub shift_obj :CUMULATIVE { return shift } } package main; use Test::More tests => 62; my $obj = Reder1->new(); my @up_order = qw( Reder1 Der1 Der2 Base1 Base3 Base2 ); my @down_order = qw( Base2 Base1 Base3 Der1 Der2 Reder1 ); my $up_string = join q{}, @up_order; my $down_string = join q{}, @down_order; my @objs = ($obj) x 6; for my $test_run (1..2) { my $res_up = $obj->der_first(); my $res_down = $obj->base_first(); my $res_objs = $obj->shift_obj(); is int $res_up, int @up_order => 'Numeric cumulative up'; is int $res_down, int @down_order => 'Numeric cumulative down'; is "$res_up", $up_string => 'String cumulative up'; is "$res_down", $down_string => 'String cumulative down'; is_deeply \@$res_up, \@up_order => 'List cumulative up'; is_deeply \@$res_down, \@down_order => 'List cumulative down'; for my $classname (keys %$res_up) { ok grep($classname, @up_order) => "Valid up hash key ($classname)"; is $classname, $res_up->{$classname} => "Valid up hash value ($classname)"; } for my $classname (keys %$res_down) { ok grep($classname, @down_order) => "Valid down hash key ($classname)"; is $classname, $res_up->{$classname} => "Valid down hash value ($classname)"; } is_deeply \@$res_objs, \@objs => "shift(\@_) used in method"; } Class-Std-Fast-v0.0.8/t/96_prereq_build.t0000555000000000000000000000131311016517372016520 0ustar rootroot#!/usr/bin/perl use strict; use warnings; use Test::More; use English qw(-no_match_vars); if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set (export) $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval 'use Test::Prereq::Build'; if ( $EVAL_ERROR ) { my $msg = 'Test::Prereq::Build not installed; skipping'; plan( skip_all => $msg ); } # workaround for the bugs of Test::Prereq::Build my @skip_workaround = qw{ }; # These modules should not go into Build.PL my @skip_devel_only = qw{ Test::Kwalitee Test::Perl::Critic Test::Prereq::Build }; my @skip = ( @skip_workaround, @skip_devel_only, ); prereq_ok( undef, undef, \@skip ); Class-Std-Fast-v0.0.8/t/access_name.t0000444000000000000000000000456611016517372016000 0ustar rootrootuse Test::More 'no_plan'; package MyBase; use Class::Std::Fast; { my %name : ATTR( :name ); my %rank : ATTR( name => 'rank' :set('RANK') ); my %snum : ATTR( :name ); sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'MyBase::name initialized'; ::is $rank{$ident}, 'MyBase::rank' => 'MyBase::rank initialized'; ::is $snum{$ident}, 'MyBase::snum' => 'MyBase::snum initialized'; } } package Der; use Class::Std::Fast; use base qw( MyBase ); { my %name : ATTR( :name ); my %rank : ATTR( name => 'rank' ); my %snum : ATTR( :name('snum') :get ); sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'Der::name initialized'; ::is $rank{$ident}, 'generic rank' => 'Der::rank initialized'; ::is $snum{$ident}, 'Der::snum' => 'Der::snum initialized'; } } package main; my $obj = MyBase->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', MyBase => { rank => 'MyBase::rank', } }); $obj->verify(); ok eval { $obj->set_RANK('new rank'); 1; } => 'set_RANK defined'; ok !eval { $obj->set_rank('new rank'); 1; } => 'set_rank not defined'; my $derobj = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', MyBase => { rank => 'MyBase::rank', }, Der => { snum => 'Der::snum', }, }); $derobj->verify(); is $derobj->get_name(), 'MyBase::name' => 'Der name read accessor'; is $derobj->get_rank(), 'generic rank' => 'Der rank read accessor'; is $derobj->get_sernum(), 'Der::snum' => 'Der rank read accessor'; $derobj->set_rank('new rank'); is $derobj->get_rank(), 'new rank' => 'Der rank write accessor'; eval { $derobj->setname('new name') }; ok $@ =~ m/\ACan't locate object method "setname" via package "Der"/ => 'Read only name attribute'; my $der2 = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', MyBase => { rank => 'MyBase::rank', }, Der => { snum => 0, }, }); is( $der2->get_sernum(), 0, 'false values allowable as attribute parameters' ); Class-Std-Fast-v0.0.8/t/caching.t0000444000000000000000000000177711016517372015134 0ustar rootrootuse lib '../lib'; package MyPackage; use strict; use Class::Std::Fast cache => 1; use Test::More; my %value_of :ATTR(:name :default<()>); sub START { pass("START method called for ID ${ $_[0] }"); } sub BUILD { pass("BUILD called for ID ${ $_[0] }"); } sub DEMOLISH { pass "DEMOLISH called for ID ${ $_[0] }" } 1; package MyPackageBasic; use strict; use Class::Std::Fast caching => 1, constructor => 'basic'; 1; package main; use strict; use Test::More; plan tests => 9; my $test; # fire ok, BUILD, START # Tests 1,2,3 ok $test = MyPackage->new(); my $id = ${ $test }; # fire DEMOLISH (4) undef $test; my $basic = MyPackageBasic->new(); # fire ok, BUILD, START - #5,6,7 ok $test = MyPackage->new({ value => $basic }); #8 is ${ $test }, $id, 'Obj has ID of destroyed object'; #9 ok ${ $basic } > ${ $test }, 'Obj created before has greater ID than cached obj'; # undef $test; # Avoid calling DEMOLISH in global destruction { no warnings qw(redefine); *MyPackage::DEMOLISH = sub {} }Class-Std-Fast-v0.0.8/t/simple.t0000444000000000000000000001031611016517372015016 0ustar rootrootuse Test::More 'no_plan'; package MyBase; use Class::Std::Fast; { my %name : ATTR( :init_arg :get ); my %rank : ATTR( init_arg => 'rank' :get :set ); my %snum : ATTR( :init_arg('snum') :get ); my %priv : ATTR; my %def : ATTR( :default :get ); my %dval : ATTR( :default('dval') :get ); sub BUILD { my ($self, $ident, $arg_ref) = @_; ::is ref $arg_ref, 'HASH' => 'Args passed to MyBase::BUILD in hash-ref'; ::is ident $self, $ident => 'Identity correct in MyBase::BUILD'; $priv{$ident} = $arg_ref->{priv}; ::is $priv{$ident}, 'MyBase::priv' => 'MyBase priv arg unpacked correctly'; $snum{$ident} = $arg_ref->{snum} . '!'; ::is $snum{$ident}, 'MyBase::snum!' => 'MyBase snum arg unpacked correctly'; } sub DEMOLISH { my ($self, $ident) = @_; ::is ident $self, $ident => 'Identity correct in MyBase::DEMOLISH' } sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'MyBase::name initialized'; ::is $rank{$ident}, 'MyBase::rank' => 'MyBase::rank initialized'; ::is $snum{$ident}, 'MyBase::snum!' => 'MyBase::snum initialized'; ::is $priv{$ident}, 'MyBase::priv' => 'MyBase::name initialized'; ::is $def{$ident}, 'MyBase::def' => 'MyBase::def initialized'; } } package Der; use Class::Std::Fast; use base qw( MyBase ); { my %name : ATTR( :init_arg ); my %rank : ATTR( init_arg => 'rank' ); my %snum : ATTR( :init_arg('snum') :get ); my %priv : ATTR( :init_arg :get ); my %def : ATTR( :init_arg :default :get ); sub BUILD { my ($self, $ident, $arg_ref) = @_; ::is ref $arg_ref, 'HASH' => 'Args passed to Der::BUILD in hash-ref'; ::is ident $self, $ident => 'Identity correct in Der::BUILD'; } sub DEMOLISH { my ($self, $ident) = @_; ::is ident $self, $ident => 'Identity correct in Der::DEMOLISH' } sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'Der::name initialized'; ::is $rank{$ident}, 'generic rank' => 'Der::rank initialized'; ::is $snum{$ident}, 'Der::snum' => 'Der::snum initialized'; ::is $priv{$ident}, 'Der::priv' => 'Der::name initialized'; ::is $def{$ident}, 'Der::def' => 'Der::def initialized'; } } package main; my $obj = MyBase->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', } }); $obj->verify(); my $derobj = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', }, Der => { snum => 'Der::snum', priv => 'Der::priv', def => 'Der::def', }, }); $derobj->verify(); is $derobj->get_name(), 'MyBase::name' => 'Der name read accessor'; is $derobj->get_rank(), 'MyBase::rank' => 'Der rank read accessor'; is $derobj->get_snum(), 'Der::snum' => 'Der rank read accessor'; is $derobj->get_priv(), 'Der::priv' => 'Der priv read accessor'; $derobj->set_rank('new rank'); is $derobj->get_rank(), 'new rank' => 'Der rank write accessor'; eval { $derobj->setname('new name') }; ok $@ =~ m/\ACan't locate object method "setname" via package "Der"/ => 'Read only name attribute'; my $der2 = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', }, Der => { snum => 0, priv => 'Der::priv', }, }); is( $der2->get_snum(), 0, 'false values allowable as attribute parameters' ); is( $der2->get_dval, 'dval', 'default values evaled correctly' ); Class-Std-Fast-v0.0.8/t/automethod.t0000444000000000000000000000472311016517372015703 0ustar rootrootpackage Common; use Class::Std::Fast; { sub AUTOMETHOD { return sub { return 'Common::foo()' }; return; } } package Foo; use Class::Std::Fast; use base qw( Common ); { sub foo { return 'Foo::foo()'; } } package Bar; use Class::Std::Fast; use base qw( Common ); { sub AUTOMETHOD { return sub { return 'Bar::foo()' } if m/\A foo \Z/xms; return; } } package Baz; use base qw( Bar ); package Qux; package main; use Test::More 'no_plan'; my $meth_ref; $meth_ref = Common->can('foo'); ok( $meth_ref => 'Common can foo()' ); is( Common->foo(), 'Common::foo()' => 'Direct common foo()' ); is( Common->$meth_ref(), 'Common::foo()' => 'Indirect common foo()' ); $meth_ref = Foo->can('foo'); ok( $meth_ref => 'Foo can foo()' ); is( Foo->foo(), 'Foo::foo()' => 'Direct Foo foo()' ); is( Foo->$meth_ref(), 'Foo::foo()' => 'Indirect Foo foo()' ); $meth_ref = Foo->can('bar'); ok( $meth_ref => 'Foo can bar()' ); is( Foo->bar(), 'Common::foo()' => 'Direct Foo bar()' ); is( Foo->$meth_ref(), 'Common::foo()' => 'Indirect Foo bar()' ); $meth_ref = Bar->can('foo'); ok( $meth_ref => 'Bar can foo()' ); is( Bar->foo(), 'Bar::foo()' => 'Direct Bar foo()' ); is( Bar->$meth_ref(), 'Bar::foo()' => 'Indirect Bar foo()' ); $meth_ref = Bar->can('bar'); ok( $meth_ref => 'Bar can bar()' ); is( Bar->bar(), 'Common::foo()' => 'Direct Bar bar()' ); is( Bar->$meth_ref(), 'Common::foo()' => 'Indirect Bar bar()' ); $meth_ref = Baz->can('foo'); ok( $meth_ref => 'Baz can foo()' ); is( Baz->foo(), 'Bar::foo()' => 'Direct Baz foo()' ); is( Baz->$meth_ref(), 'Bar::foo()' => 'Indirect Baz foo()' ); $meth_ref = Baz->can('bar'); ok( $meth_ref => 'Baz can bar()' ); is( Baz->bar(), 'Common::foo()' => 'Direct Baz bar()' ); is( Baz->$meth_ref(), 'Common::foo()' => 'Indirect Baz bar()' ); $meth_ref = Qux->can('foo'); ok( !$meth_ref => 'Qux no can foo()' ); eval { Qux->foo() }; ok( $@ => 'No Qux foo()' ); Class-Std-Fast-v0.0.8/t/00.load.t0000444000000000000000000000053211016517372014661 0ustar rootrootuse Test::More tests => 2; BEGIN { package Test::Class::Std::Fast; ::use_ok('Class::Std::Fast'); package Test::Class::Std::Fast::Storable; ::use_ok('Class::Std::Fast::Storable'); } diag( "Testing Class::Std::Fast $Class::Std::Fast::VERSION" ); diag( "Testing Class::Std::Fast::Storable $Class::Std::Fast::Storable::VERSION" ); Class-Std-Fast-v0.0.8/t/runtime.t0000444000000000000000000001153211016517372015211 0ustar rootroot# if you execute this script directly it say's # Looks like you planned 47 tests but only ran 44. # because the destructos / DEMOLISH methods won't be # executed use Test::More tests => 45; eval q{ package MyBase; use Class::Std::Fast; { my %name : ATTR( :init_arg :get ); my %rank : ATTR( init_arg => 'rank' :get :set ); my %snum : ATTR( :init_arg('snum') :get ); my %priv : ATTR; my %def : ATTR( :default :get ); my %dval : ATTR( :default('dval') :get ); sub BUILD { my ($self, $ident, $arg_ref) = @_; ::is ref $arg_ref, 'HASH' => 'Args passed to MyBase::BUILD in hash-ref'; ::is ident $self, $ident => 'Identity correct in MyBase::BUILD'; $priv{$ident} = $arg_ref->{priv}; ::is $priv{$ident}, 'MyBase::priv' => 'MyBase priv arg unpacked correctly'; $snum{$ident} = $arg_ref->{snum} . '!'; ::is $snum{$ident}, 'MyBase::snum!' => 'MyBase snum arg unpacked correctly'; } sub DEMOLISH { my ($self, $ident) = @_; ::is ident $self, $ident => 'Identity correct in MyBase::DEMOLISH' } sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'MyBase::name initialized'; ::is $rank{$ident}, 'MyBase::rank' => 'MyBase::rank initialized'; ::is $snum{$ident}, 'MyBase::snum!' => 'MyBase::snum initialized'; ::is $priv{$ident}, 'MyBase::priv' => 'MyBase::name initialized'; ::is $def{$ident}, 'MyBase::def' => 'MyBase::def initialized'; } sub rest : RESTRICTED { ::ok 1, 'Accessed restricted'; } Class::Std::Fast::initialize; } package Der; use Class::Std::Fast; use base qw( MyBase ); { my %name : ATTR( :init_arg ); my %rank : ATTR( init_arg => 'rank' ); my %snum : ATTR( :init_arg('snum') :get ); my %priv : ATTR( :init_arg :get ); my %def : ATTR( :init_arg :default :get ); sub BUILD { my ($self, $ident, $arg_ref) = @_; ::is ref $arg_ref, 'HASH' => 'Args passed to Der::BUILD in hash-ref'; ::is ident $self, $ident => 'Identity correct in Der::BUILD'; } sub DEMOLISH { my ($self, $ident) = @_; ::is ident $self, $ident => 'Identity correct in Der::DEMOLISH' } sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'Der::name initialized'; ::is $rank{$ident}, 'generic rank' => 'Der::rank initialized'; ::is $snum{$ident}, 'Der::snum' => 'Der::snum initialized'; ::is $priv{$ident}, 'Der::priv' => 'Der::name initialized'; ::is $def{$ident}, 'Der::def' => 'Der::def initialized'; $self->rest(); } Class::Std::Fast::initialize; } }; package main; my $obj = MyBase->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', } }); $obj->verify(); my $derobj = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', }, Der => { snum => 'Der::snum', priv => 'Der::priv', def => 'Der::def', }, }); $derobj->verify(); is $derobj->get_name(), 'MyBase::name' => 'Der name read accessor'; is $derobj->get_rank(), 'MyBase::rank' => 'Der rank read accessor'; is $derobj->get_snum(), 'Der::snum' => 'Der rank read accessor'; is $derobj->get_priv(), 'Der::priv' => 'Der priv read accessor'; $derobj->set_rank('new rank'); is $derobj->get_rank(), 'new rank' => 'Der rank write accessor'; eval { $derobj->setname('new name') }; ok $@ =~ m/\ACan't locate object method "setname" via package "Der"/ => 'Read only name attribute'; my $der2 = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', }, Der => { snum => 0, priv => 'Der::priv', }, }); is( $der2->get_snum(), 0, 'false values allowable as attribute parameters' ); is( $der2->get_dval, 'dval', 'default values evaled correctly' ); print "# DONE - now comes the cleanup...\n"; Class-Std-Fast-v0.0.8/t/01.cloning.t0000444000000000000000000001066411016517372015403 0ustar rootrootpackage main; use Test::More tests => 43; use strict; package TestClass; use Class::Std::Fast::Storable; { my %name_of :ATTR( :get :set ); my %flavor_of :ATTR( :get :set ); } package LinkedList; use Class::Std::Fast::Storable; { my %info_of :ATTR( :get :set ); my %next_node_for :ATTR( :get :set ); } package TestMISubClass; use Class::Std::Fast::Storable; use base qw( TestClass LinkedList ); { my %ref_copy_for :ATTR( :get ); my %unknown1 :ATTR; #for testing with no attr name given my %unknown2 :ATTR; #for testing with no attr name given sub set_next_node { my $self = shift; my $id = ident $self; die "no param provided" unless @_; my $next_node = shift; $ref_copy_for{$id} = $next_node; $self->SUPER::set_next_node($next_node); return; } sub set_unknown1 { my $id = ident shift; $unknown1{$id} = shift; } sub get_unknown1 { return $unknown1{ident shift}; } sub set_unknown2 { my $id = ident shift; $unknown2{$id} = shift; } sub get_unknown2 { return $unknown2{ident shift}; } } package main; use Class::Std::Fast::Storable; use Storable; use Carp; use Data::Dumper; ########################################################## # very basic testing of a single object my $object = TestClass->new; $object->set_name("Vanilla Bean"); $object->set_flavor("vanilla"); my $clone = Storable::dclone($object); is( $clone->get_name, "Vanilla Bean", "properties successfully cloned"); is( $clone->get_flavor, "vanilla", "properties successfully cloned"); ########################################################## # testing a nested structure my $first_node = LinkedList->new; $first_node->set_info(1); for my $i (2..10) { my $next_node = LinkedList->new; $next_node->set_info($i); $next_node->set_next_node($first_node); $first_node = $next_node; } my $id = ident($first_node); $first_node = Storable::dclone($first_node); isnt($id, ident($first_node), "should in fact be a different object"); for my $i (reverse 1..10) { is($first_node->get_info, $i, "values in the nodes all match"); $first_node = $first_node->get_next_node; } ########################################################## # testing MI and structural integrity my @flavors = qw( vanilla chocolate strawberry mango peach grape ); my $obj; for my $flavor ( @flavors ) { my $next = TestMISubClass->new; $next->set_flavor($flavor); $next->set_info($flavor); $next->set_unknown1("1_$flavor"); $next->set_unknown2("2_$flavor"); $next->set_next_node($obj); $obj = $next; } $clone = Storable::freeze($obj); undef $obj; #should destroy the whole list $clone = Storable::thaw($clone); for my $flavor ( reverse @flavors ) { is($flavor, $clone->get_flavor, "flavor cloned the same"); is("1_$flavor", $clone->get_unknown1, "unknown1 cloned the same"); is("2_$flavor", $clone->get_unknown2, "unknown2 cloned the same"); my $next = $clone->get_next_node; my $copy = $clone->get_ref_copy; last unless $next; is(ident($next), ident($copy), "clones of same object should be the same"); $clone = $next; } ########################################################## # generating diagnostics $object = TestClass->new; $object->set_name("Vanilla Bean"); $object->set_flavor("vanilla"); eval { $object->STORABLE_thaw(0, 0, {TestClass => { name => "foo" } } ) }; like($@, qr{trying to modify existing attributes}, "block attempted manipulation"); eval { $object->STORABLE_thaw(0, 0, {TestClass => { unknown => "foo" } } ) }; like($@, qr{unknown attribute}, "error on unknown attribute"); eval { $object->STORABLE_thaw(0, 0, {unknown => {} } ) }; like($@, qr{unknown base class}, "error on unknown base class"); ########################################################## # calling hooks my($freeze_pre, $freeze_post, $thaw_pre, $thaw_post); { no warnings; #ignore spurious "only used once" warnings *TestClass::STORABLE_freeze_pre = sub { $freeze_pre = 1 }; *TestClass::STORABLE_freeze_post = sub { $freeze_post = 1 }; *TestClass::STORABLE_thaw_pre = sub { $thaw_pre = 1 }; *TestClass::STORABLE_thaw_post = sub { $thaw_post = 1 }; } Storable::dclone($object); ok( $freeze_pre, "STORABLE_freeze_pre called"); ok( $freeze_post, "STORABLE_freeze_post called"); ok( $thaw_pre, "STORABLE_thaw_pre called"); ok( $thaw_post, "STORABLE_thaw_post called"); Class-Std-Fast-v0.0.8/t/pod-coverage.t0000444000000000000000000000035411016517372016101 0ustar rootroot#!perl -T use Test::More; eval 'use Test::Pod::Coverage'; plan skip_all => "Test::Pod::Coverage required for testing POD coverage" if $@; use Class::Std::Fast; all_pod_coverage_ok( { also_private => [ qr/^[A-Z_]+$|^uniq$/ ], }, ); Class-Std-Fast-v0.0.8/t/dump.t0000444000000000000000000000210411016517372014466 0ustar rootrootpackage MyBase; use Class::Std::Fast; { my %public_of :ATTR( :init_arg ); my %private_of :ATTR; sub BUILD { my ($self, $ident) = @_; $private_of{$ident} = 'base priv'; } } package MyDer; use base qw( MyBase ); use Class::Std::Fast; { my %public_of :ATTR( :init_arg ); my %private_of :ATTR; sub BUILD { my ($self, $ident) = @_; $private_of{$ident} = 'der priv'; } } package main; my $rep = MyDer->new({ MyBase => { pub => 'base pub' }, MyDer => { pub => 'der pub' }, })->_DUMP; my $hash = eval $rep; use Test::More 'no_plan'; ok !ref $rep => 'Representation is string'; ok $hash => 'Representation is valid'; is $hash->{MyBase}{pub}, 'base pub' => 'Public base attribute'; is $hash->{MyBase}{'????'}, 'base priv' => 'Private base attribute'; is $hash->{MyDer}{pub}, 'der pub' => 'Public derived attribute'; is $hash->{MyDer}{'????'}, 'der priv' => 'Private derived attribute'; Class-Std-Fast-v0.0.8/t/begin-coercion.t0000444000000000000000000000041011016517372016402 0ustar rootrootuse Test::More 'no_plan'; package Problem; use Class::Std::Fast; # overload seems to interfere with overloading coercions sub as_string : STRINGIFY { return 'string'; } package main; our $obj; BEGIN { $obj = Problem->new(); ok("$obj"); } ok("$obj"); Class-Std-Fast-v0.0.8/t/97_kwalitee.t0000444000000000000000000000056311016517372015654 0ustar rootroot#!/usr/bin/perl use strict; use warnings; use Test::More; use English qw(-no_match_vars); if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval 'use Test::Kwalitee'; if ( $EVAL_ERROR ) { my $msg = 'Test::Kwalitee not installed; skipping'; plan( skip_all => $msg ); } Class-Std-Fast-v0.0.8/t/pod.t0000444000000000000000000000021411016517372014303 0ustar rootroot#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Class-Std-Fast-v0.0.8/t/perlattrs.t0000444000000000000000000000117111016517372015544 0ustar rootrootpackage MyBase; use Test::More 'no_plan'; sub MODIFY_HASH_ATTRIBUTES { my ($package, $referent, @attrs) = @_; for my $attr (@attrs) { if ($attr =~ /Loud/) { $referent->{Loud} = 1; } undef $attr } return grep {defined} @attrs; } use Class::Std::Fast; { my %name_of :ATTR( :name ) :Loud; sub verify { my ($self) = @_; is $name_of{ident $self}, "mha_test" => ':ATTR handled correctly'; is $name_of{Loud}, 1 => ':Loud handled correctly'; } } package main; my $obj = MyBase->new({name=>'mha_test'}); $obj->verify(); Class-Std-Fast-v0.0.8/t/coercions.t0000444000000000000000000001330411016517372015511 0ustar rootrootmy %global_hash; my @global_array; my $global_scalar; sub global_sub {} my %global_hash2; my @global_array2; my $global_scalar2; sub global_sub2 {} # Test basic coercions... package BaseClass; use Class::Std::Fast; { sub as_str : STRINGIFY { return 'hello world' } sub as_num : NUMERIFY { return 42 } sub as_bool : BOOLIFY { return } sub as_code : CODIFY { return \&::global_sub } sub as_glob : GLOBIFY { return \*::global_glob } sub as_hash : HASHIFY { return \%global_hash } sub as_array : ARRAYIFY { return \@global_array } } # Test inheritance without change... package DerClass; use base qw( BaseClass ); # Test inheritance with change... package DerClass2; use Class::Std::Fast; use base qw( BaseClass ); { sub as_str : STRINGIFY { return 'goodbye world' } sub as_num : NUMERIFY { return 86 } sub as_bool : BOOLIFY { return 1 } sub as_code : CODIFY { return \&::global_sub2 } sub as_glob : GLOBIFY { return \*::global_glob2 } sub as_hash : HASHIFY { return \%global_hash2 } sub as_array : ARRAYIFY { return \@global_array2 } } # Test inheritance with change and they didn't "use Class::Std::Fast" package DerClass3; use base qw( BaseClass ); { sub as_str : STRINGIFY { return 'goodbye world' } sub as_num : NUMERIFY { return 86 } sub as_bool : BOOLIFY { return 1 } sub as_code : CODIFY { return \&::global_sub2 } sub as_glob : GLOBIFY { return \*::global_glob2 } sub as_hash : HASHIFY { return \%global_hash2 } sub as_array : ARRAYIFY { return \@global_array2 } } # Test inheritance with change and they don't re-specify the coercions package DerClass4; use base qw( BaseClass ); { sub as_str { return 'goodbye world' } sub as_num { return 86 } sub as_bool { return 1 } sub as_code { return \&::global_sub2 } sub as_glob { return \*::global_glob2 } sub as_hash { return \%global_hash2 } sub as_array { return \@global_array2 } } # Test inheritance with changing the subs used for the coercions package DerClass5; use base qw( BaseClass ); { sub as_str_changed : STRINGIFY { return 'goodbye world' } sub as_num_changed : NUMERIFY { return 86 } sub as_bool_changed : BOOLIFY { return 1 } sub as_code_changed : CODIFY { return \&::global_sub2 } sub as_glob_changed : GLOBIFY { return \*::global_glob2 } sub as_hash_changed : HASHIFY { return \%global_hash2 } sub as_array_changed : ARRAYIFY { return \@global_array2 } } package main; use Test::More 'no_plan'; my $obj; # Basic coercions... $obj = BaseClass->new(); ok !$obj => 'Base Boolean coercion'; is 0+$obj, 42 => 'Base Numeric coercion'; is "$obj", 'hello world' => 'Base String coercion'; is \&{$obj}, \&global_sub => 'Base Code coercion'; is \*{$obj}, \*global_glob => 'Base Glob coercion'; is \%{$obj}, \%global_hash => 'Base Hash coercion'; is \@{$obj}, \@global_array => 'Base Array coercion'; # Inheriting coercions... $obj = DerClass->new(); ok !$obj => 'Der Boolean coercion'; is 0+$obj, 42 => 'Der Numeric coercion'; is "$obj", 'hello world' => 'Der String coercion'; is \&{$obj}, \&global_sub => 'Der Code coercion'; is \*{$obj}, \*global_glob => 'Der Glob coercion'; is \%{$obj}, \%global_hash => 'Der Hash coercion'; is \@{$obj}, \@global_array => 'Der Array coercion'; # Redefining coercions on inheritance... $obj = DerClass2->new(); ok $obj => 'Der2 Boolean coercion'; is 0+$obj, 86 => 'Der2 Numeric coercion'; is "$obj", 'goodbye world' => 'Der2 String coercion'; is \&{$obj}, \&global_sub2 => 'Der2 Code coercion'; is \*{$obj}, \*global_glob2 => 'Der2 Glob coercion'; is \%{$obj}, \%global_hash2 => 'Der2 Hash coercion'; is \@{$obj}, \@global_array2 => 'Der2 Array coercion'; # Redefining coercions on inheritance and there is no "use Class::Std::Fast" # in the subclass $obj = DerClass3->new(); ok $obj => 'Der3 Boolean coercion'; is 0+$obj, 86 => 'Der3 Numeric coercion'; is "$obj", 'goodbye world' => 'Der3 String coercion'; is \&{$obj}, \&global_sub2 => 'Der3 Code coercion'; is \*{$obj}, \*global_glob2 => 'Der3 Glob coercion'; is \%{$obj}, \%global_hash2 => 'Der3 Hash coercion'; is \@{$obj}, \@global_array2 => 'Der3 Array coercion'; # The subclass doesn't need to specify the coercions again $obj = DerClass4->new(); ok $obj => 'Der4 Boolean coercion'; is 0+$obj, 86 => 'Der4 Numeric coercion'; is "$obj", 'goodbye world' => 'Der4 String coercion'; is \&{$obj}, \&global_sub2 => 'Der4 Code coercion'; is \*{$obj}, \*global_glob2 => 'Der4 Glob coercion'; is \%{$obj}, \%global_hash2 => 'Der4 Hash coercion'; is \@{$obj}, \@global_array2 => 'Der4 Array coercion'; # The subclass doesn't need to specify the coercions again $obj = DerClass5->new(); ok $obj => 'Der5 Boolean coercion'; is 0+$obj, 86 => 'Der5 Numeric coercion'; is "$obj", 'goodbye world' => 'Der5 String coercion'; is \&{$obj}, \&global_sub2 => 'Der5 Code coercion'; is \*{$obj}, \*global_glob2 => 'Der5 Glob coercion'; is \%{$obj}, \%global_hash2 => 'Der5 Hash coercion'; is \@{$obj}, \@global_array2 => 'Der5 Array coercion'; Class-Std-Fast-v0.0.8/t/access.t0000444000000000000000000000404211016517372014765 0ustar rootrootuse Test::More 'no_plan'; package MyBase; use Class::Std::Fast; { sub everyone { return 'everyone' } sub family :RESTRICTED { return 'family' } sub personal :PRIVATE { return 'personal' } sub try_all { $self = shift; for my $method (qw(everyone family personal)) { ::is $self->$method(), $method => "Called $method"; } } } package MyDer; use Class::Std::Fast; use base qw( MyBase ); { sub everyone { my $self = shift; $self->SUPER::everyone(); } sub family :RESTRICTED { my $self = shift; $self->SUPER::family(); } sub personal :PRIVATE { my $self = shift; $self->SUPER::personal(); } } package main; my $base_obj = MyBase->new(); my $der_obj = MyDer->new(); $base_obj->try_all(); ok !eval { $der_obj->try_all(); 1 } => 'Derived call failed'; like $@, qr/Can't call private method MyDer::personal\(\) from class MyBase/ => '...with correct error message'; is $base_obj->everyone, 'everyone' => 'External everyone succeeded'; ok !eval { $base_obj->family } => 'External family failed as expected'; like $@, qr/Can't call restricted method MyBase::family\(\) from class main/ => '...with correct error message'; ok !eval { $base_obj->personal } => 'External personal failed as expected'; like $@, qr/Can't call private method MyBase::personal\(\) from class main/ => '...with correct error message'; is $der_obj->everyone, 'everyone' => 'External derived everyone succeeded'; ok !eval { $der_obj->family } => 'External derived family failed as expected'; like $@, qr/Can't call restricted method MyDer::family\(\) from class main/ => '...with correct error message'; ok !eval { $der_obj->personal } => 'External derived personal failed as expected'; like $@, qr/Can't call private method MyDer::personal\(\) from class main/ => '...with correct error message'; Class-Std-Fast-v0.0.8/lib/0000755000000000000000000000000011016517372013644 5ustar rootrootClass-Std-Fast-v0.0.8/lib/Class/0000755000000000000000000000000011016517372014711 5ustar rootrootClass-Std-Fast-v0.0.8/lib/Class/Std/0000755000000000000000000000000011016517372015443 5ustar rootrootClass-Std-Fast-v0.0.8/lib/Class/Std/Fast.pm0000444000000000000000000005340611016517372016704 0ustar rootrootpackage Class::Std::Fast; use version; $VERSION = qv('0.0.8'); use strict; use warnings; use Carp; BEGIN { # warn if we cannot save aray UNIVERSAL::Can (because Class::Std has # already overwritten it...) exists $INC{'Class/Std.pm'} && warn 'Class::Std::Fast loaded too late - put >use Class::Std::Fast< somewhere at the top of your application '; # save away UNIVERSAL::can *real_can = \&UNIVERSAL::can; require Class::Std; no strict qw(refs); for my $sub ( qw(MODIFY_CODE_ATTRIBUTES AUTOLOAD _mislabelled initialize) ) { *{$sub} = \&{'Class::Std::' . $sub}; } } my %object_cache_of = (); my %do_cache_class_of = (); my %destroy_isa_unsorted_of = (); my %attribute; my %optimization_level_of = (); my $instance_counter = 1; # use () prototype to indicate to perl that it does not need to prepare an # argument stack sub OBJECT_CACHE_REF () { return \%object_cache_of }; sub ID_GENERATOR_REF () { return \$instance_counter }; my @exported_subs = qw( ident DESTROY _DUMP AUTOLOAD ); my @exported_extension_subs = qw( MODIFY_CODE_ATTRIBUTES MODIFY_HASH_ATTRIBUTES ); sub _cache_class_ref () { croak q{you can't call this method in your namespace} if 0 != index caller, 'Class::Std::'; return \%do_cache_class_of; } sub _attribute_ref () { croak q{you can't call this method in your namespace} if 0 != index caller, 'Class::Std::'; return \%attribute; } sub _get_internal_attributes { croak q{you can't call this method in your namespace} if 0 != index caller, 'Class::Std::'; return $attribute{$_[-1]}; } sub _set_optimization_level { $optimization_level_of{$_[0]} = $_[1] || 1; } # Prototype allows perl to inline ID sub ID() { return $instance_counter++; } sub ident ($) { return ${$_[0]}; } sub _init_class_cache { $do_cache_class_of{ $_[0] } = 1; $object_cache_of{ $_[0] } ||= []; } sub _init_import { my ($caller_package, %flags) = @_; $destroy_isa_unsorted_of{ $caller_package } = undef if ($flags{isa_unsorted}); _init_class_cache( $caller_package ) if ($flags{cache}); no strict qw(refs); if ($flags{constructor} eq 'normal') { *{ $caller_package . '::new' } = \&new; } elsif ($flags{constructor} eq 'basic' && $flags{cache}) { *{ $caller_package . '::new' } = \&_new_basic_cache; } elsif ($flags{constructor} eq 'basic' && ! $flags{cache}) { *{ $caller_package . '::new' } = \&_new_basic; } elsif ($flags{constructor} eq 'none' ) { # nothing to do } else { croak "Illegal import flags constructor => '$flags{constructor}', cache => '$flags{cache}'"; } } sub import { my $caller_package = caller; my %flags = (@_>=3) ? @_[1..$#_] : (@_==2) && $_[1] >=2 ? ( constructor => 'basic', cache => 0 ) : ( constructor => 'normal', cache => 0); $flags{cache} = 0 if not defined $flags{cache}; $flags{constructor} = 'normal' if not defined $flags{constructor}; _init_import($caller_package, %flags); no strict qw(refs); for my $sub ( @exported_subs ) { *{ $caller_package . '::' . $sub } = \&{$sub}; } for my $sub ( @exported_extension_subs ) { my $target = $caller_package . '::' . $sub; my $real_sub = *{ $target }{CODE} || sub { return @_[2..$#_] }; no warnings qw(redefine); *{ $target } = sub { my ($package, $referent, @unhandled) = @_; for my $handler ($sub, $real_sub) { next if ! @unhandled; @unhandled = $handler->($package, $referent, @unhandled); } return @unhandled; }; } } sub __create_getter { my ($package, $referent, $getter) = @_; no strict 'refs'; *{$package.'::get_'.$getter} = sub { return $referent->{${$_[0]}}; } } sub __create_setter { my ($package, $referent, $setter) = @_; no strict 'refs'; *{$package.'::set_'.$setter} = sub { $referent->{${$_[0]}} = $_[1]; return $_[0]; } } sub MODIFY_HASH_ATTRIBUTES { my ($package, $referent, @attrs) = @_; for my $attr (@attrs) { next if $attr !~ m/\A ATTRS? \s* (?: \( (.*) \) )? \z/xms; my ($default, $init_arg, $getter, $setter, $name); if (my $config = $1) { $default = Class::Std::_extract_default($config); $name = Class::Std::_extract_name($config); $init_arg = Class::Std::_extract_init_arg($config) || $name; if ($getter = Class::Std::_extract_get($config) || $name) { __create_getter($package, $referent, $getter, $name); } if ($setter = Class::Std::_extract_set($config) || $name) { __create_setter($package, $referent, $setter, $name); } } undef $attr; push @{$attribute{$package}}, { ref => $referent, default => $default, init_arg => $init_arg, name => $name || $init_arg || $getter || $setter || '????', }; } return grep { defined } @attrs; } sub _DUMP { my ($self) = @_; my $id = ${$self}; my %dump; for my $package (keys %attribute) { my $attr_list_ref = $attribute{$package}; for my $attr_ref ( @{$attr_list_ref} ) { next if !exists $attr_ref->{ref}{$id}; $dump{$package}{$attr_ref->{name}} = $attr_ref->{ref}{$id}; } } require Data::Dumper; my $dump = Data::Dumper::Dumper(\%dump); $dump =~ s/^.{8}//gxms; return $dump; } sub _new_basic { return bless \(my $anon_scalar = $instance_counter++), $_[0]; } sub _new_basic_cache { return pop @{ $object_cache_of{ $_[0] }} || bless \(my $anon_scalar = $instance_counter++), $_[0]; } sub new { no strict 'refs'; # Symbol Class:: must exist... croak "Can't find class $_[0]" if ! keys %{ $_[0] . '::' }; Class::Std::initialize(); # Ensure run-time (and mod_perl) setup is done # extra safety only required if we actually care of arguments ... croak "Argument to $_[0]\->new() must be hash reference" if ($#_) && ref $_[1] ne 'HASH'; # try cache first if caching is enabled for this class my $new_obj = exists($do_cache_class_of{ $_[0] }) && pop @{ $object_cache_of{ $_[0] } } || bless \(my $another_anon_scalar = $instance_counter++), $_[0]; my (@missing_inits, @suss_keys, @start_methods); $_[1] ||= {}; my %arg_set; BUILD: for my $base_class (Class::Std::_reverse_hierarchy_of($_[0])) { my $arg_set = $arg_set{$base_class} = { %{$_[1]}, %{$_[1]->{$base_class}||{}} }; # Apply BUILD() methods ... { no warnings 'once'; if (my $build_ref = *{$base_class.'::BUILD'}{CODE}) { $build_ref->($new_obj, ${$new_obj}, $arg_set); } if (my $init_ref = *{$base_class.'::START'}{CODE}) { push @start_methods, sub { $init_ref->($new_obj, ${$new_obj}, $arg_set); }; } } # Apply init_arg and default for attributes still undefined ... my $init_arg; INIT: for my $attr_ref ( @{$attribute{$base_class}} ) { defined $attr_ref->{ref}{${$new_obj}} and next INIT; # Get arg from initializer list... if (defined $attr_ref->{init_arg} && exists $arg_set->{$attr_ref->{init_arg}}) { $attr_ref->{ref}{${$new_obj}} = $arg_set->{$attr_ref->{init_arg}}; next INIT; } elsif (defined $attr_ref->{default}) { # Or use default value specified... $attr_ref->{ref}{${$new_obj}} = eval $attr_ref->{default}; $@ and $attr_ref->{ref}{${$new_obj}} = $attr_ref->{default}; next INIT; } if (defined $attr_ref->{init_arg}) { # Record missing init_arg ... push @missing_inits, "Missing initializer label for $base_class: " . "'$attr_ref->{init_arg}'.\n"; push @suss_keys, keys %{$arg_set}; } } } croak @missing_inits, _mislabelled(@suss_keys), 'Fatal error in constructor call' if @missing_inits; $_->() for @start_methods; return $new_obj; } # Copied form Class::Std for performance my %_hierarchy_of; sub _hierarchy_of { my ($class) = @_; return @{$_hierarchy_of{$class}} if exists $_hierarchy_of{$class}; no strict 'refs'; my @hierarchy = $class; my @parents = @{$class.'::ISA'}; while (defined (my $parent = shift @parents)) { push @hierarchy, $parent; push @parents, @{$parent.'::ISA'}; } # only sort if sorting is of any interest # BIG speedup for classes with a long linear inheritance tree - # may cause trouble with diamond inheritance. # Sorting must be disabled by user if (! exists $destroy_isa_unsorted_of{$class}) { my %seen; # maybe applying the Schwarzian transform could help? # ... and sort {} grep {} @list runs through the list twice... return @{$_hierarchy_of{$class}} = sort { $a->isa($b) ? -1 : $b->isa($a) ? +1 : 0 } grep { ! exists $seen{$_} and $seen{$_} = 1 } @hierarchy; } else { my %seen; return @{$_hierarchy_of{$class}} = grep { ! exists $seen{$_} and $seen{$_} = 1 } @hierarchy; } } # DESTROY looks a bit cryptic, thus needs to be explained... # # It performs the following tasks: # - traverse the @ISA hierarchy # - for every base class # - call DEMOLISH if there is such a method with $_[0], ${$_[0]} as # arguments (read as: $self, $ident). # - delete the element with key ${ $_[0] } (read as: $ident)from all :ATTR hashes # sub DESTROY { my $ident = ${$_[0]}; my $class = ref $_[0]; push @_, $ident; # Shortcut: check @ISA - saves us a method call if 0... # DEMOLISH: for my $base_class (scalar @{ "$class\::ISA" } # ? Class::Std::_hierarchy_of($class) # : ($class) ) { no strict qw(refs); for my $base_class (exists $_hierarchy_of{$class} ? @{$_hierarchy_of{$class}} : _hierarchy_of($class)) { # call by & to tell perl that it doesn't need to put up a new argument # stack &{"$base_class\::DEMOLISH"} if ( exists(&{"$base_class\::DEMOLISH"}) ); delete $_->{ref}->{ $ident } for (@{$attribute{$base_class}}); } # call with @_ as arguments - dirty but fast... &Class::Std::Fast::_cache if exists($do_cache_class_of{ $class }); } # Maybe we could speed up DESTROY by putting specific DESTROY methods # into Class::Std::Fast classes via symbol table sub _cache { push @{ $object_cache_of{ ref $_[0] }}, bless $_[0], ref $_[0]; } # clean out cache method to prevent it being called in global destruction sub END { no warnings qw(redefine); *Class::Std::Fast::_cache = sub {}; } # save away real can. We need can() [the real one] in # Class::Std::Fast::Storable - implementing STORBALE_freeze_pre / post # via AUTOMETHOD is a bad idea, anyway... sub real_can; # *real_can = \&CORE::UNIVERSAL::can; # Override can to make it work with AUTOMETHODs # Slows down can() for all objects { my $real_can = \&UNIVERSAL::can; no warnings qw(redefine once); *UNIVERSAL::can = sub { defined $_[0] or return; my ($invocant, $method_name) = @_; if (my $sub_ref = $real_can->(@_)) { return $sub_ref; } # call to Class::Std::_hierarchy_of replaced by hash lookup for my $parent_class ( exists $_hierarchy_of{ ref $invocant || $invocant } ? @{ $_hierarchy_of{ ref $invocant || $invocant }} : Class::Std::Fast::_hierarchy_of(ref $invocant || $invocant) ) { no strict 'refs'; if (my $automethod_ref = *{$parent_class.'::AUTOMETHOD'}{CODE}) { local $CALLER::_ = $_; local $_ = $method_name; if (my $method_impl = $automethod_ref->(@_)) { return sub { my $inv = shift; $inv->$method_name(@_) } } } } return; }; } 1; __END__ =pod =head1 NAME Class::Std::Fast - faster but less secure than Class::Std =head1 VERSION This document describes Class::Std::Fast 0.0.8 =head1 SYNOPSIS package MyClass; use Class::Std::Fast; 1; package main; MyClass->new(); =head1 DESCRIPTION Class::Std::Fast allows you to use the beautiful API of Class::Std in a faster way than Class::Std does. You can get the object's ident via scalarifiyng your object. Getting the objects ident is still possible via the ident method, but it's faster to scalarify your object. =head1 SUBROUTINES/METHODS =head2 new The constructor acts like Class::Std's constructor. For extended constructors see L below. package FastObject; use Class::Std::Fast; 1; my $fast_obj = FastObject->new(); =head2 ident If you use Class::Std::Fast you shouldn't use this method. It's only existant for downward compatibility. # insted of my $ident = ident $self; # use my $ident = ${$self}; =head2 initialize Class::Std::Fast::initialize(); Imported from L. Please look at the documentation from L for more details. =head2 Methods for accessing Class::Std::Fast's internals Class::Std::Fast exposes some of it's internals to allow the construction of Class::Std::Fast based objects from outside the auto-generated constructors. You should never use these methods for doing anything else. In fact you should not use these methods at all, unless you know what you're doing. =head2 ID Returns an ID for the next object to construct. If you ever need to override the constructor created by Class::Std::Fast, be sure to use Class::Std::Fast::ID as the source for the ID to assign to your blessed scalar. More precisely, you should construct your object like this: my $self = bless \do { my $foo = Class::Std::Fast::ID } , $class; Every other method of constructing Class::Std::Fast - based objects will lead to data corruption (duplicate object IDs). =head2 ID_GENERATOR_REF Returns a reference to the ID counter scalar. The current value is the B object ID ! You should never use this method unless you're trying to create Class::Std::Fast objects from outside Class::Std::Fast (and possibly outside perl). In case you do (like when creating perl objects in XS code), be sure to post-increment the ID counter B creating an object, which you may do from C with sv_inc( SvRV(id_counter_ref) ) =head2 OBJECT_CACHE_REF Returns a reference to the object cache. You should never use this method unless your're trying to (re-)create Class::Std::Fast objects from outside Class::Std::Fast (and possibly outside perl). See for a description of the object cache facility. =head1 EXTENSIONS TO Class::Std =head2 Methods =head3 real_can Class::Std::Fast saves away UNIVERSAL::can as Class::Std::Fast::real_can before overwriting it. You should not use real_can, because it does not check for subroutines implemented via AUTOMETHOD. It is there if you need the old can() for speed reasons, and know what you're doing. =head2 Constructors Class::Std::Fast allows the user to chose between several constructor options. =over =item * Standard constructor No special synopsis. Acts like Class::Std's constructor =item * Basic constructor use Class::Std::Fast qw(2); use Class::Std::Fast constructor => 'basic'; Does not call BUILD and START (and does not walk down the inheritance hierarchy calling BUILD and START). Does not perform any attribute initializations. Really fast, but very basic. =item * No constructor use Class::Std::Fast qw(3); use Class::Std::Fast constructor => 'none'; No constructor is exported into the calling class. The recommended usage is: use Class::Std::Fast constructor => none; sub new { my $self = bless \do { my $foo = Class::Std::Fast::ID } , $_[0]; # do what you need to do after that } If you use the Object Cache (see below) the recommended usage is: use Class::Std::Fast constructor => 'none', cache => 1; sub new { my $self = pop @{ Class::Std::Fast::OBJECT_CACHE_REF()->{ $_[0] } } || bless \do { my $foo = Class::Std::Fast::ID() } , $_[0]; } =back =head2 Destructors Class::Std sorts the @ISA hierarchy before traversing it to avoid cleaning up the wrong class first. However, this is unneccessary if the class in question has a linear inheritance tree. Class authors may disable sorting by calling use Class::Std::Fast unsorted => 1; Use only if you know your class' complete inheritance tree... =head2 Object Cache =head3 Synopsis use Class::Std::Fast cache => 1; =head3 Description While inside out objects are basically an implementation of the Flyweight Pattern (object data is stored outside the object), there's still one aspect missing: object reuse. While Class::Std::Fast does not provide flyweights in the classical sense (one object re-used again and again), it provides something close to it: An object cache for re-using destroyed objects. The object cache is implemented as a simple hash with the class names of the cached objects as keys, and a list ref of cached objects as values. The object cache is filled by the DESTROY method exported into all Class::Std::Fast based objects: Instead of actually destroying the blessed scalar reference (Class::Std::Fast based objects are nothing more), the object to be destroyed is pushed into it's class' object cache. new() in turn does not need to create a new blessed scalar, but can just pop one off the object cache (which is a magnitude faster). Using the object cache is recommended for persistent applications (like running under mod_perl), or applications creating and destroying lots of Class::Std::Fast based objects again and again. The exported constructor automatically uses the Object Cache when caching is enabled by setting the cache import flag to a true value. For an example of a user-defined constructor see L above. =head3 Memory overhead The object cache trades speed for memory. This is a very perlish way for adressing performance issues, but may cause your application to blow up if you're short of memory. On a 32bit Linux, Devel::Size reports 44 bytes for a Class::Std::Fast based object - so a cache containing 1 000 000 (one million) of objects needs around 50MB of memory (Devel Size only reports the memory use it can see - the actual usage is system dependent and something between 4 and 32 bytes more). If you are anxious about falling short of memory, only enable caching for those classes whose objects you know to be frequently created and destroyed, and leave it turned off for the less frequently used classes - this gives you both speed benefits, and avoids holding a cache of object that will never be needed again. =head1 DIAGNOSTICS see Class::Std. Additional diagnostics are: =over =item * Class::Std::Fast loaded too late - put >use Class::Std::Fast< somewhere at the top of your application (warning) Class::Std has been "use"d before Class::Std::Fast. While both classes happily coexist in one application, Class::Std::Fast must be loaded first for maximum speedup. This is due to both classes overwriting UNIVERSAL::can. Class::Std::Fast uses the original (fast) can where appropritate, but cannot access it if Class::Std has overwritten it before with it's (slow) replacement. =back =head1 CONFIGURATION AND ENVIRONMENT =head1 DEPENDENCIES =over =item * L =item * L =item * L =back =head1 INCOMPATIBILITIES see L =head1 BUGS AND LIMITATIONS =over =item * You can't use the :SCALARIFY attribute for your Objects. We use an increment for building identifiers and not Scalar::Util::refaddr like Class::Std. =item * Inheriting from non-Class::Std::Fast modules does not work You cannot inherit from non-Class::Std::Fast classes, not even if you overwrite the default constructor. To be more precise, you cannot inherit from classes which use something different from numeric blessed scalar references as their objects. Even so inheriting from similarly contructed classes like Object::InsideOut could work, you would have to make sure that object IDs cannot be duplicated. It is therefore strongly discouraged to build classes with Class::Std::Fast derived from non-Class::Std::Fast classes. If you really need to inherit from non-Class::Std::Fast modules, make sure you use Class::Std::Fast::ID as described above for creating objects. =item * No runtime initialization with constructor => 'basic' / 'none' When eval'ing Class::Std::Fast based classes using the basic constructor, make sure the last line is Class::Std::Fast::initialize(); In contrast to Class::Std, Class::Std::Fast performs no run-time initialization when the basic constructor is enabled, so your code has to do it itself. The same holds true for constructor => 'none', of course. CUMULATIVE, PRIVATE, RESTRICTED and anticumulative methods won't work if you leave out this line. =back =head1 RCS INFORMATIONS =over =item Last changed by $Author: ac0v $ =item Id $Id: Fast.pm 469 2008-05-26 11:26:35Z ac0v $ =item Revision $Revision: 469 $ =item Date $Date: 2008-05-26 13:26:35 +0200 (Mon, 26 May 2008) $ =item HeadURL $HeadURL: file:///var/svn/repos/Hyper/Class-Std-Fast/branches/0.0.8/lib/Class/Std/Fast.pm $ =back =head1 AUTHORS Andreas 'ac0v' Specht C<< >> Martin Kutter C<< >> =head1 LICENSE AND COPYRIGHT Copyright (c) 2007, Andreas Specht C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Std-Fast-v0.0.8/lib/Class/Std/Fast/0000755000000000000000000000000011016517372016340 5ustar rootrootClass-Std-Fast-v0.0.8/lib/Class/Std/Fast/Storable.pm0000444000000000000000000001544411016517372020457 0ustar rootrootpackage Class::Std::Fast::Storable; use version; $VERSION = qv('0.0.8'); use strict; use warnings; use Carp; use Storable; BEGIN { require Class::Std::Fast; } my $attributes_of_ref = {}; my @exported_subs = qw( Class::Std::Fast::ident Class::Std::Fast::DESTROY Class::Std::Fast::MODIFY_CODE_ATTRIBUTES Class::Std::Fast::AUTOLOAD Class::Std::Fast::_DUMP STORABLE_freeze STORABLE_thaw MODIFY_HASH_ATTRIBUTES ); sub import { my $caller_package = caller; my %flags = (@_>=3) ? @_[1..$#_] : (@_==2) && $_[1] >=2 ? ( constructor => 'basic', cache => 0 ) : ( constructor => 'normal', cache => 0); $flags{cache} = 0 if not defined $flags{cache}; $flags{constructor} = 'normal' if not defined $flags{constructor}; Class::Std::Fast::_init_import( $caller_package, %flags ); no strict qw(refs); for my $name ( @exported_subs ) { my ($sub_name) = $name =~ m{(\w+)\z}xms; *{ $caller_package . '::' . $sub_name } = \&{$name}; } } sub MODIFY_HASH_ATTRIBUTES { my $caller_package = $_[0]; my @unhandled = Class::Std::Fast::MODIFY_HASH_ATTRIBUTES(@_); my $i = 0; $attributes_of_ref->{$caller_package} = { map { $_->{name} eq '????' ? '????_' . $i++ : $_->{name} => $_->{ref}; } @{Class::Std::Fast::_get_internal_attributes($caller_package) || []} }; return @unhandled; } # It's a constant - so there's no use creating it in each freeze again my $FROZEN_ANON_SCALAR = Storable::freeze(\(my $anon_scalar)); sub STORABLE_freeze { # TODO do we really need to unpack @_? We're getting called for # Zillions of objects... my($self, $cloning) = @_; Class::Std::Fast::real_can($self, 'STORABLE_freeze_pre') && $self->STORABLE_freeze_pre($cloning); my %frozen_attr; #to be constructed my $id = ${$self}; my @package_list = ref $self; my %package_seen = ( $package_list[0] => 1 ); # ignore diamond/looped base classes :-) no strict qw(refs); PACKAGE: while( my $package = shift @package_list) { #make sure we add any base classes to the list of #packages to examine for attributes. # Original line: # push @package_list, grep { ! $package_seen{$_}++; } @{"${package}::ISA"}; # This one's faster... push @package_list, grep { ! exists $package_seen{$_} && do { $package_seen{$_} = undef; 1; } } @{"${package}::ISA"}; #look for any attributes of this object for this package my $attr_ref = $attributes_of_ref->{$package} or next PACKAGE; # TODO replace inner my variable by $_ - faster... ATTR: # examine attributes from known packages only for ( keys %{$attr_ref} ) { #nothing to do if attr not set for this object exists $attr_ref->{$_}{$id} and $frozen_attr{$package}{ $_ } = $attr_ref->{$_}{$id}; # save the attr by name into the package hash } } Class::Std::Fast::real_can($self, 'STORABLE_freeze_post') && $self->STORABLE_freeze_post($cloning, \%frozen_attr); return ($FROZEN_ANON_SCALAR, \%frozen_attr); } sub STORABLE_thaw { # croak "must be called from Storable" unless caller eq 'Storable'; # unfortunately, Storable never appears on the call stack. # TODO do we really need to unpack @_? We're getting called for # zillions of objects... my $self = shift; my $cloning = shift; my $frozen_attr_ref = $_[1]; # $_[0] is the frozen anon scalar. Class::Std::Fast::real_can($self, 'STORABLE_thaw_pre') && $self->STORABLE_thaw_pre($cloning, $frozen_attr_ref); my $id = ${$self} ||= Class::Std::Fast::ID(); PACKAGE: while( my ($package, $pkg_attr_ref) = each %{$frozen_attr_ref} ) { # TODO This test is quite expensive. Is there a better one? $self->isa($package) or croak "unknown base class '$package' seen while thawing " . ref $self; ATTR: for ( keys %{$attributes_of_ref->{$package}} ) { # for known attrs... # nothing to do if frozen attr doesn't exist exists $pkg_attr_ref->{$_} or next ATTR; # block attempts to meddle with existing objects exists $attributes_of_ref->{$package}->{$_}->{$id} and croak "trying to modify existing attributes for $package"; # ok, set the attribute $attributes_of_ref->{$package}->{$_}->{$id} = delete $pkg_attr_ref->{$_}; } # this is probably serious enough to throw an exception. # however, TODO: it would be nice if the class could somehow # indicate to ignore this problem. %$pkg_attr_ref and croak "unknown attribute(s) seen while thawing class $package:" . join q{, }, keys %$pkg_attr_ref; } Class::Std::Fast::real_can($self, 'STORABLE_thaw_post') && $self->STORABLE_thaw_post($cloning); } 1; __END__ =pod =head1 NAME Class::Std::Fast::Storable - Fast Storable InsideOut objects =head1 VERSION This document describes Class::Std::Fast::Storable 0.0.8 =head1 SYNOPSIS package MyClass; use Class::Std::Fast::Storable; 1; package main; use Storable qw(freeze thaw); my $thawn = freeze(thaw(MyClass->new())); =head1 DESCRIPTION Class::Std::Fast::Storable does the same as Class::Std::Storable does for Class::Std. The API is the same as Class::Std::Storable's, with few exceptions. =head1 SUBROUTINES/METHODS =head2 STORABLE_freeze see method Class::Std::Storable::STORABLE_freeze =head2 STORABLE_thaw see method Class::Std::Storable::STORABLE_thaw =head1 DIAGNOSTICS see L and see L =head1 CONFIGURATION AND ENVIRONMENT =head1 DEPENDENCIES =over =item * L =item * L =item * L =back =head1 INCOMPATIBILITIES STORABLE_freeze_pre, STORABLE_freeze_post, STORABLE_thaw_pre and STORABLE_thaw_post must not be implemented as AUTOMETHOD. see L and L =head1 BUGS AND LIMITATIONS see L and L =head1 RCS INFORMATIONS =over =item Last changed by $Author: ac0v $ =item Id $Id: Storable.pm 469 2008-05-26 11:26:35Z ac0v $ =item Revision $Revision: 469 $ =item Date $Date: 2008-05-26 13:26:35 +0200 (Mon, 26 May 2008) $ =item HeadURL $HeadURL: file:///var/svn/repos/Hyper/Class-Std-Fast/branches/0.0.8/lib/Class/Std/Fast/Storable.pm $ =back =head1 AUTHOR Andreas 'ac0v' Specht C<< >> =head1 LICENSE AND COPYRIGHT Copyright (c) 2007, Andreas Specht C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Std-Fast-v0.0.8/benchmark/0000755000000000000000000000000011016517372015030 5ustar rootrootClass-Std-Fast-v0.0.8/benchmark/can.pl0000444000000000000000000000045611016517372016131 0ustar rootrootuse lib '../lib'; use Class::Std::Fast; use Benchmark qw(cmpthese); cmpthese 1000000 , { can => sub { return 1 if (Class::Std::Fast->can('DESTROY')) }, symbol => sub { return 1 if (*{Class::Std::Fast::DESTROY}{CODE}) }, exist => sub { return 1 if exists &{Class::Std::Fast::DESTROY} }, }; Class-Std-Fast-v0.0.8/benchmark/class-std.txt0000444000000000000000000001333711016517372017473 0ustar rootrootThis is the output from class-std.pl run on a IBM Thinkpad T42 equipped with a 1.7GHz Pentium Mobile (Dothan). The machine has 1 GB of memory, which was more than sufficient for running the benchmark. The Benchmark was run from inside Eclipse from a Gnome desktop. OS was Ubuntu 7.10 (Gutsy Gibbon). Class-Std-Fast is SVN revision 195 (trunk). Summary of my perl5 (revision 5 version 8 subversion 8) configuration: Platform: osname=linux, osvers=2.6.15.7, archname=i486-linux-gnu-thread-multi uname='linux palmer 2.6.15.7 #1 smp thu sep 7 19:42:20 utc 2006 i686 gnulinux ' config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=i486-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.8 -Darchlib=/usr/lib/perl/5.8 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.8.8 -Dsitearch=/usr/local/lib/perl/5.8.8 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Uusesfio -Uusenm -Duseshrplib -Dlibperl=libperl.so.5.8.8 -Dd_dosuid -des' hint=recommended, useposix=true, d_sigaction=define usethreads=define use5005threads=undef useithreads=define usemultiplicity=define useperlio=define d_sfio=undef uselargefiles=define usesocks=undef use64bitint=undef use64bitall=undef uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64', optimize='-O2', cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include' ccversion='', gccversion='4.1.3 20070831 (prerelease) (Ubuntu 4.1.2-16ubuntu1)', gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234 d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12 ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8 alignbytes=4, prototype=define Linker and Libraries: ld='cc', ldflags =' -L/usr/local/lib' libpth=/usr/local/lib /lib /usr/lib libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt perllibs=-ldl -lm -lpthread -lc -lcrypt libc=/lib/libc-2.6.1.so, so=so, useshrplib=true, libperl=libperl.so.5.8.8 gnulibc_version='2.6.1' Dynamic Linking: dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E' cccdlflags='-fPIC', lddlflags='-shared -L/usr/local/lib' Characteristics of this binary (from libperl): Compile-time options: MULTIPLICITY PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP THREADS_HAVE_PIDS USE_ITHREADS USE_LARGE_FILES USE_PERLIO USE_REENTRANT_API Built under linux Compiled at Sep 29 2007 05:57:38 @INC: /etc/perl /usr/local/lib/perl/5.8.8 /usr/local/share/perl/5.8.8 /usr/lib/perl5 /usr/share/perl5 /usr/lib/perl/5.8 /usr/share/perl/5.8 /usr/local/lib/site_perl . Info: Each test creates an object an stacks two objects into it (two levels) MyBenchTestFastCache (50000 iterations - first run) timethis 50000: 1 wallclock secs ( 0.91 usr + 0.02 sys = 0.93 CPU) @ 53763.44/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 2 wallclock secs ( 1.58 usr + 0.01 sys = 1.59 CPU) @ 0.63/s (n=1) (warning: too few iterations for a reliable count) MyBenchTestFastCache (50000 iterations - second run) timethis 50000: 0 wallclock secs ( 0.45 usr + 0.00 sys = 0.45 CPU) @ 111111.11/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 2 wallclock secs ( 1.54 usr + 0.01 sys = 1.55 CPU) @ 0.65/s (n=1) (warning: too few iterations for a reliable count) MyBenchTestFastBasic (50000 iterations - first run) timethis 50000: 1 wallclock secs ( 0.57 usr + 0.01 sys = 0.58 CPU) @ 86206.90/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 1 wallclock secs ( 1.39 usr + 0.00 sys = 1.39 CPU) @ 0.72/s (n=1) (warning: too few iterations for a reliable count) MyBenchTestFastBasic (50000 iterations - second run) timethis 50000: 1 wallclock secs ( 0.55 usr + 0.00 sys = 0.55 CPU) @ 90909.09/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 1 wallclock secs ( 1.38 usr + 0.01 sys = 1.39 CPU) @ 0.72/s (n=1) (warning: too few iterations for a reliable count) MyBenchTestFast (50000 iterations - first run) timethis 50000: 14 wallclock secs (13.10 usr + 0.08 sys = 13.18 CPU) @ 3793.63/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 1 wallclock secs ( 1.51 usr + 0.03 sys = 1.54 CPU) @ 0.65/s (n=1) (warning: too few iterations for a reliable count) MyBenchTestFast (50000 iterations - second run) timethis 50000: 14 wallclock secs (12.93 usr + 0.08 sys = 13.01 CPU) @ 3843.20/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 1 wallclock secs ( 1.52 usr + 0.00 sys = 1.52 CPU) @ 0.66/s (n=1) (warning: too few iterations for a reliable count) MyBenchTest (50000 iterations - first run) timethis 50000: 14 wallclock secs (13.48 usr + 0.08 sys = 13.56 CPU) @ 3687.32/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 2 wallclock secs ( 1.71 usr + 0.02 sys = 1.73 CPU) @ 0.58/s (n=1) (warning: too few iterations for a reliable count) MyBenchTest (50000 iterations - second run) timethis 50000: 14 wallclock secs (13.27 usr + 0.09 sys = 13.36 CPU) @ 3742.51/s (n=50000) Cleanup: Destroying 150000 objects timethis 1: 2 wallclock secs ( 1.71 usr + 0.02 sys = 1.73 CPU) @ 0.58/s (n=1) (warning: too few iterations for a reliable count) Class-Std-Fast-v0.0.8/benchmark/class-std.pl0000444000000000000000000000375211016517372017267 0ustar rootrootuse lib '../lib'; use Benchmark; my @list; package MyBenchTestFastBasic; use Class::Std::Fast constructor => 'basic', isa_unsorted => 1; my %one_of :ATTR(:name :default<()>); my %two_of :ATTR(:name :default<()>); my %three_of :ATTR(:name :default<()>); my %four_of :ATTR(:name :default<()>); Class::Std::initialize; 1; package MyBenchTestFast; use Class::Std::Fast; my %one_of :ATTR(:name :default<()>); my %two_of :ATTR(:name :default<()>); my %three_of :ATTR(:name :default<()>); my %four_of :ATTR(:name :default<()>); Class::Std::initialize; 1; package MyBenchTest; use Class::Std; my %one_of :ATTR(:name :default<()>); my %two_of :ATTR(:name :default<()>); my %three_of :ATTR(:name :default<()>); my %four_of :ATTR(:name :default<()>); Class::Std::initialize; 1; package MyBenchTestFastCache; use Class::Std::Fast constructor => 'basic', cache => 1 , isa_unsorted => 1; my %one_of :ATTR(:name); my %two_of :ATTR(:name); my %three_of :ATTR(:name); my %four_of :ATTR(:name); Class::Std::initialize; 1; package main; print "Info: Each test creates an object an stacks two objects into it (two levels)\n"; for my $class ('MyBenchTestFastCache', 'MyBenchTestFastBasic') { #, 'MyBenchTestFast', 'MyBenchTest') { my $n = 100000; print "\n$class ($n iterations - first run)\n"; timethis $n, sub { push @list, $class->new(); $list[-1]->set_one($class->new()); $list[-1]->get_one()->set_two($class->new()); $list[-1]->get_one(); }; print "Cleanup: Destroying ${ \($n *3) } objects\n"; timethis 1, sub { undef @list }; print "\n$class ($n iterations - second run)\n"; timethis $n , sub { push @list, $class->new(); $list[-1]->set_one($class->new()); $list[-1]->get_one()->set_two($class->new()); $list[-1]->get_one(); }; print "Cleanup: Destroying ${ \($n *3) } objects\n"; timethis 1, sub { undef @list }; } Class-Std-Fast-v0.0.8/benchmark/destructor.pl0000444000000000000000000000250411016517372017562 0ustar rootrootuse lib '../lib'; use Benchmark; my @list; package MyBenchTestFastBasic; use Class::Std::Fast constructor => 'basic', isa_unsorted => 1; my %one_of :ATTR(:name :default<()>); my %two_of :ATTR(:name :default<()>); my %three_of :ATTR(:name :default<()>); my %four_of :ATTR(:name :default<()>); Class::Std::initialize; 1; package MyBenchTestFast; use Class::Std::Fast; my %one_of :ATTR(:name :default<()>); my %two_of :ATTR(:name :default<()>); my %three_of :ATTR(:name :default<()>); my %four_of :ATTR(:name :default<()>); Class::Std::initialize; 1; package MyBenchTest; use Class::Std; my %one_of :ATTR(:name :default<()>); my %two_of :ATTR(:name :default<()>); my %three_of :ATTR(:name :default<()>); my %four_of :ATTR(:name :default<()>); Class::Std::initialize; 1; package MyBenchTestFastCache; use base qw(MyBenchTest); use Class::Std::Fast constructor => 'basic', cache => 1, unsorted_isa => 1; my %one_of :ATTR(:name); my %two_of :ATTR(:name); my %three_of :ATTR(:name); my %four_of :ATTR(:name); Class::Std::initialize; 1; package main; my $n = 100; my $n = 5; timethis $n, sub { for my $class ('MyBenchTestFastBasic') { push @list, $class->new({ one => 'foo', two => 'bar'}) for (1..5000); undef @list }; }; Class-Std-Fast-v0.0.8/benchmark/bless.pl0000444000000000000000000000050111016517372016467 0ustar rootrootpackage SomeClass; package main; use strict; use Benchmark qw(timethese timethis cmpthese); my $id = 1; our $ID = \$id; my @data; sub new { my $self = bless \ do{ my $o= ${ $ID }++}, shift; return $self;} timethis 1000000, sub { my $data = new( 'SomeClass' ) }; print "Pentium M (Dothan), 1,7GHz rate: 653594/s\n"; Class-Std-Fast-v0.0.8/Changes0000444000000000000000000000171111016517372014367 0ustar rootrootRevision history for Class-Std-Fast 0.0.8 Mon May 26 13:25:26 CEST 2008 * Allow access to even more internals for even more XS surgery 0.0.7 Fri May 16 15:00:28 CEST 2008 * factored out getter / setter creation into separate functions to allow XS surgery 0.0.6 Mon May 5 13:06:53 CEST 2008 * Storable freeze/thaw speedup * DESTROY speedup for classes using inheritance 0.0.5 Sat Dec 01 17:30:00 CEST 2007 * Fixed DESTROY issues * made object cache work with overloading 0.0.4 Tue Nov 20 19:44:00 CEST 2007 * Introduced named options for import * Added object caching * updated tests 0.0.3 Tue Nov 11 22:10:00 CEST 2007 * fixed DESTROY/DEMOLISH methods, * added missing pod for initialize method * updated tests in runtime.t 0.0.2 Tue Nov 10 21:37:00 CEST 2007 Fixed test scripts 0.0.1 Tue Nov 10 18:51:00 CEST 2007 Initial release. Class-Std-Fast-v0.0.8/MANIFEST0000444000000000000000000000076711016517372014237 0ustar rootrootbenchmark/bless.pl benchmark/can.pl benchmark/class-std.pl benchmark/class-std.txt benchmark/destructor.pl Build.PL Changes lib/Class/Std/Fast.pm lib/Class/Std/Fast/Storable.pm Makefile.PL MANIFEST This list of files META.yml README t/00.load.t t/01.cloning.t t/96_prereq_build.t t/97_kwalitee.t t/access.t t/access_automethod.t t/access_name.t t/automethod.t t/begin-coercion.t t/caching.t t/coercions.t t/cumulative.t t/dump.t t/perlattrs.t t/pod-coverage.t t/pod.t t/runtime.t t/simple.t t/start.t Class-Std-Fast-v0.0.8/META.yml0000444000000000000000000000116011016517372014343 0ustar rootroot--- name: Class-Std-Fast version: v0.0.8 author: - "Andreas 'ac0v' Specht - ACID@cpan.org" abstract: faster but less secure than Class::Std license: perl resources: license: http://dev.perl.org/licenses/ requires: Class::Std: 0.0.8 Data::Dumper: 0 Scalar::Util: 0 version: 0 build_requires: Test::More: 0 provides: Class::Std::Fast: file: lib/Class/Std/Fast.pm version: v0.0.8 Class::Std::Fast::Storable: file: lib/Class/Std/Fast/Storable.pm version: v0.0.8 generated_by: Module::Build version 0.2806 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 Class-Std-Fast-v0.0.8/Makefile.PL0000444000000000000000000000113311016517372015044 0ustar rootroot# Note: this file was auto-generated by Module::Build::Compat version 0.03 use ExtUtils::MakeMaker; WriteMakefile ( 'PL_FILES' => {}, 'INSTALLDIRS' => 'site', 'NAME' => 'Class::Std::Fast', 'EXE_FILES' => [], 'VERSION_FROM' => 'lib/Class/Std/Fast.pm', 'PREREQ_PM' => { 'Test::More' => 0, 'Scalar::Util' => 0, 'version' => 0, 'Data::Dumper' => 0, 'Class::Std' => '0.0.8' } ) ; Class-Std-Fast-v0.0.8/Build.PL0000444000000000000000000000114211016517372014366 0ustar rootrootuse strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Class::Std::Fast', license => 'perl', dist_author => q{Andreas 'ac0v' Specht - ACID@cpan.org}, dist_version_from => 'lib/Class/Std/Fast.pm', create_makefile_pl => 'traditional', requires => { 'version' => 0, 'Scalar::Util' => 0, 'Data::Dumper' => 0, 'Class::Std' => '0.0.8', }, build_requires => { 'Test::More' => 0, }, add_to_cleanup => [ 'Class-Std-*' ], ); $builder->create_build_script(); Class-Std-Fast-v0.0.8/README0000444000000000000000000000105711016517372013757 0ustar rootrootClass::Std::Fast version 0.0.8 This module provides a faster but less secure version of Class::Std INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL ./Build ./Build test ./Build install COPYRIGHT AND LICENCE Copyright (C) 2008, Andreas 'ac0v' Specht This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.