From 6f5d0aa91c09489e6c94b4a25694770605995c6e Mon Sep 17 00:00:00 2001 From: Hauke D Date: Sat, 14 Sep 2024 11:29:04 +0000 Subject: [PATCH 1/4] [WIP also] Initial untested (!) impl. With To-Do's in code! --- MANIFEST | 3 ++ lib/Util/H2O/Also.pm | 74 ++++++++++++++++++++++++++++++++++++++++++++ t/Util-H2O-Also.t | 34 ++++++++++++++++++++ xt/author.t | 4 ++- xt/bench.t | 21 +++++++++++++ 5 files changed, 135 insertions(+), 1 deletion(-) create mode 100644 lib/Util/H2O/Also.pm create mode 100755 t/Util-H2O-Also.t create mode 100755 xt/bench.t diff --git a/MANIFEST b/MANIFEST index 3a637d1..d135269 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,11 +1,14 @@ Changes lib/Util/H2O.pm +lib/Util/H2O/Also.pm LICENSE.txt Makefile.PL MANIFEST This list of files README.md t/Util-H2O.t +t/Util-H2O-Also.t xt/author.t +xt/bench.t xt/cpanfile xt/mem.t xt/redef.t diff --git a/lib/Util/H2O/Also.pm b/lib/Util/H2O/Also.pm new file mode 100644 index 0000000..f1671fc --- /dev/null +++ b/lib/Util/H2O/Also.pm @@ -0,0 +1,74 @@ +#!perl +package Util::H2O::Also; +use warnings; +use strict; + +=head1 Name + +Util::H2O::Also - Alternative single-class version of Util::H2O (but slower) + +=head1 Synopsis + + TODO + +=cut + +our $VERSION = '0.26'; +# For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file + +use Carp (); +use Hash::Util (); +use Scalar::Util (); + +sub new { + my $class = shift; + # allow $object->new to access hash key 'new' + if (Scalar::Util::blessed($class) && UNIVERSAL::isa($class, __PACKAGE__)) ## no critic (ProhibitUniversalIsa) + { our $AUTOLOAD = 'new'; goto &AUTOLOAD } + my $hashref = shift; + bless $hashref, $class; + #TODO: Hash::Util::lock_hashref($hashref); + return $hashref; +} + +sub AUTOLOAD { ## no critic (ProhibitAutoloading) + our $AUTOLOAD; + # allow $object->AUTOLOAD to access hash key 'AUTOLOAD' + $AUTOLOAD = 'AUTOLOAD' if !defined $AUTOLOAD; + ( my $key = $AUTOLOAD ) =~ s/.*:://; + undef $AUTOLOAD; # reset this so $object->AUTOLOAD still works + my $self = shift; + return if $key eq 'DESTROY' && !exists $self->{$key}; + Carp::croak("Can't locate object method \"$key\" via package \"".ref($self)."\"") unless exists $self->{$key}; + $self->{$key} = shift if @_; + return $self->{$key}; +} + +# Override UNIVERSAL methods: +sub DOES { our $AUTOLOAD='DOES'; goto &AUTOLOAD } +sub VERSION { our $AUTOLOAD='VERSION'; goto &AUTOLOAD } + +# But don't override these so as to not break common expectations of Perl's objects: +#sub can { our $AUTOLOAD='can'; goto &AUTOLOAD } +#sub isa { our $AUTOLOAD='isa'; goto &AUTOLOAD } + +# Perl doesn't autoload these either: +#TODO: this prevents `use Util::H2O::Also;` sub import { our $AUTOLOAD='import'; goto &AUTOLOAD } +sub unimport { our $AUTOLOAD='unimport'; goto &AUTOLOAD } + +1; +__END__ + +=head1 Author, Copyright, and License + +Copyright (c) 2024 Hauke Daempfling (haukex@zero-g.net). + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself. + +For more information see the L, +which should have been distributed with your copy of Perl. +Try the command C or see +L. + +=cut diff --git a/t/Util-H2O-Also.t b/t/Util-H2O-Also.t new file mode 100755 index 0000000..0454497 --- /dev/null +++ b/t/Util-H2O-Also.t @@ -0,0 +1,34 @@ +#!/usr/bin/env perl +use warnings; +use strict; + +=head1 Synopsis + +Tests for the Perl module L. + +=head1 Author, Copyright, and License + +Copyright (c) 2024 Hauke Daempfling (haukex@zero-g.net). + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself. + +For more information see the L, +which should have been distributed with your copy of Perl. +Try the command C or see +L. + +=cut + +use Test::More; #TODO: tests=>1; + +#TODO: sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping) +#TODO: sub warns (&) { my @w; { local $SIG{__WARN__} = sub { push @w, shift }; shift->() } @w } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn) + +## no critic (RequireTestLabels) + +diag "This is Perl $] at $^X on $^O"; +BEGIN { require_ok 'Util::H2O::Also' } +is $Util::H2O::Also::VERSION, '0.26'; + +done_testing; diff --git a/xt/author.t b/xt/author.t index 30a1581..3e0a45d 100755 --- a/xt/author.t +++ b/xt/author.t @@ -29,12 +29,14 @@ BEGIN { $BASEDIR = catdir($FindBin::Bin,updir); @PERLFILES = ( catfile($BASEDIR,qw/ lib Util H2O.pm /), + catfile($BASEDIR,qw/ lib Util H2O Also.pm /), bsd_glob("$BASEDIR/{t,xt}/*.{t,pm}"), ); } -use Test::More tests => 3*@PERLFILES + 6; +use Test::More tests => 3*@PERLFILES + 7; BEGIN { use_ok 'Util::H2O' } +BEGIN { use_ok 'Util::H2O::Also' } note explain \@PERLFILES; use File::Temp qw/tempfile/; diff --git a/xt/bench.t b/xt/bench.t new file mode 100755 index 0000000..f3cec55 --- /dev/null +++ b/xt/bench.t @@ -0,0 +1,21 @@ +#!/usr/bin/env perl +use warnings; +use strict; +use Test::More tests=>1; +use Util::H2O; +use Util::H2O::Also; +use Benchmark 'cmpthese'; + +my %hash = ( Hello=>'World' ); + +my $o1 = h2o {%hash}; +my $o2 = Util::H2O::Also->new({%hash}); + +cmpthese(-2, { + 'H2O' => sub { $o1->Hello }, + 'Also' => sub { $o2->Hello }, +}); + +pass 'TODO'; + +done_testing; \ No newline at end of file From f6fbe9d2c69a424bdbe13d0826857d5a01e8dfe8 Mon Sep 17 00:00:00 2001 From: Hauke D Date: Sat, 14 Sep 2024 18:56:44 +0000 Subject: [PATCH 2/4] [WIP also] Added Util::H2O::Also (experimental) --- .github/workflows/full-tests.yml | 2 +- .vscode/extensions.json | 1 + Changes | 1 + Makefile.PL | 4 + lib/Util/H2O/Also.pm | 121 +++++++++++++++-- t/Util-H2O-Also.t | 216 ++++++++++++++++++++++++++++++- xt/author.t | 18 ++- xt/bench.t | 9 +- 8 files changed, 351 insertions(+), 21 deletions(-) diff --git a/.github/workflows/full-tests.yml b/.github/workflows/full-tests.yml index cfdbcbb..1767d6e 100644 --- a/.github/workflows/full-tests.yml +++ b/.github/workflows/full-tests.yml @@ -1,5 +1,5 @@ # https://docs.github.com/en/actions/using-workflows/workflow-syntax-for-github-actions -name: Full Tests, Lint, and Coverage (all versions and OSes) +name: Full Tests, Lint, and 100% Coverage, all versions and OSes on: push: # this workflow is somewhat expensive, so only run when explicitly tagged diff --git a/.vscode/extensions.json b/.vscode/extensions.json index 4d08361..1c115d5 100644 --- a/.vscode/extensions.json +++ b/.vscode/extensions.json @@ -1,6 +1,7 @@ { "recommendations": [ "github.vscode-github-actions", + "ms-vscode.live-server", "oderwat.indent-rainbow", "streetsidesoftware.code-spell-checker", ] diff --git a/Changes b/Changes index a0b226e..9cb9412 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,7 @@ Revision history for Perl extension Util::H2O. 0.26 not yet released - Increased minimum required Perl version to 5.8.9 + - Added experimental `Util::H2O::Also` 0.24 Wed, Dec 13 2023 commit 10a8b75ad51a195fc8c8a7a5e8633bec4bf6eb8b - fix a bug where o2h would die on scalars that looked like options diff --git a/Makefile.PL b/Makefile.PL index cf198fd..afbcd67 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -14,6 +14,10 @@ WriteMakefile( file => 'lib/Util/H2O.pm', version => '0.26', }, + 'Util::H2O::Also' => { + file => 'lib/Util/H2O/Also.pm', + version => '0.26', + }, }, resources => { homepage => 'https://github.com/haukex/Util-H2O', diff --git a/lib/Util/H2O/Also.pm b/lib/Util/H2O/Also.pm index f1671fc..9c51104 100644 --- a/lib/Util/H2O/Also.pm +++ b/lib/Util/H2O/Also.pm @@ -7,39 +7,112 @@ use strict; Util::H2O::Also - Alternative single-class version of Util::H2O (but slower) +=head1 Experimental + +B +B + =head1 Synopsis - TODO + use Util::H2O::Also; + + my $hash = Util::H2O::Also->new( { foo => "bar", x => "y" } ); + print $hash->foo, "\n"; # accessor + $hash->x("z"); # change value + + # subclassing + { + package MyClass; + use parent 'Util::H2O::Also'; + sub cool { + my $self = shift; + print $self->what, "\n"; + } + } + my $obj = MyClass->new( { what=>"beans" } ); + $obj->cool; # prints "beans" =cut our $VERSION = '0.26'; # For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file +=head1 Description + +This B module was heavily inspired by L. +While L generates a new package for each hash wrapped in an object, +this module uses a single package and C. + +The advantages are that you get less packages (which may consume a large amount of memory +if you're creating a lot of C objects), and it's very easy to subclass this module to +create multiple objects with the same custom package name. Another minor advantage is that +if the underlying hash is modified, the corresponding accessors for those hash keys will +seem to "appear magically". + +The major disadvantage appears to be speed: +testing shows that even a simple attribute access is six times slower! + +Also, I have so far only implemented some very basic options (see below), so this module +doesn't (yet) provide the richness of options that L does. +Instead, for now this class is just a testbed to compare the two implementations. +Feedback is welcome! + +=head1 C<< Util::H2O::Also->new(I<@opts>, I<$hashref>) >> + +=head2 C<@opts> + +=head3 C<-ro> + +Use L's C to lock the entire hash, +essentially making it immutable. + +=head3 C<-nolock> + +Don't use L's C to lock the keys of the hash. + +=head2 C<$hashref> + +The hash reference to wrap. Will be locked (or not) according to the C<-nolock>/C<-ro> options. + +=cut + use Carp (); use Hash::Util (); use Scalar::Util (); -sub new { - my $class = shift; +sub new { ## no critic (RequireArgUnpacking) # allow $object->new to access hash key 'new' - if (Scalar::Util::blessed($class) && UNIVERSAL::isa($class, __PACKAGE__)) ## no critic (ProhibitUniversalIsa) + if ( @_ && Scalar::Util::blessed($_[0]) && UNIVERSAL::isa($_[0], __PACKAGE__) ) ## no critic (ProhibitUniversalIsa) { our $AUTOLOAD = 'new'; goto &AUTOLOAD } + my $class = shift; + my ($lock,$ro) = (1); + while ( @_ && $_[0] && !ref $_[0] && $_[0]=~/^-/ ) { + if ($_[0] eq '-nolock'){ $lock = 0; shift } + elsif ($_[0] eq '-ro' ) { $ro = shift } + else { Carp::croak("unknown option to $class->new(): '$_[0]'") } + } + Carp::croak("can't use -nolock and -ro together") if !$lock && $ro; my $hashref = shift; + Carp::croak("$class->new() only accepts plain hashrefs") unless ref $hashref eq 'HASH'; bless $hashref, $class; - #TODO: Hash::Util::lock_hashref($hashref); + if ($ro) { Hash::Util::lock_hashref($hashref) } + elsif ($lock) { Hash::Util::lock_ref_keys($hashref) } return $hashref; } -sub AUTOLOAD { ## no critic (ProhibitAutoloading) +sub AUTOLOAD { ## no critic (ProhibitAutoloading, RequireArgUnpacking) our $AUTOLOAD; # allow $object->AUTOLOAD to access hash key 'AUTOLOAD' $AUTOLOAD = 'AUTOLOAD' if !defined $AUTOLOAD; ( my $key = $AUTOLOAD ) =~ s/.*:://; undef $AUTOLOAD; # reset this so $object->AUTOLOAD still works + Carp::confess("Internal error: AUTOLOAD key='$key' called on " + .(defined $_[0] ? $_[0] : 'undef')) + unless Scalar::Util::blessed($_[0]) && UNIVERSAL::isa($_[0], __PACKAGE__); ## no critic (ProhibitUniversalIsa) my $self = shift; return if $key eq 'DESTROY' && !exists $self->{$key}; - Carp::croak("Can't locate object method \"$key\" via package \"".ref($self)."\"") unless exists $self->{$key}; + Carp::croak("Can't locate object method \"$key\" via package \"".ref($self)."\"") + unless exists $self->{$key}; $self->{$key} = shift if @_; return $self->{$key}; } @@ -48,13 +121,37 @@ sub AUTOLOAD { ## no critic (ProhibitAutoloading) sub DOES { our $AUTOLOAD='DOES'; goto &AUTOLOAD } sub VERSION { our $AUTOLOAD='VERSION'; goto &AUTOLOAD } -# But don't override these so as to not break common expectations of Perl's objects: -#sub can { our $AUTOLOAD='can'; goto &AUTOLOAD } +# Perl doesn't autoload these either +# (we still need to allow calling them regularly, like with `use Util::H2O::Also`) +sub import { ## no critic (RequireArgUnpacking) + if ( @_ && Scalar::Util::blessed($_[0]) && UNIVERSAL::isa($_[0], __PACKAGE__) ) ## no critic (ProhibitUniversalIsa) + { our $AUTOLOAD='import'; goto &AUTOLOAD } +} +sub unimport { ## no critic (RequireArgUnpacking) + if ( @_ && Scalar::Util::blessed($_[0]) && UNIVERSAL::isa($_[0], __PACKAGE__) ) ## no critic (ProhibitUniversalIsa) + { our $AUTOLOAD='unimport'; goto &AUTOLOAD } +} + +# But don't override ->isa so as to not break common expectations of Perl's objects: #sub isa { our $AUTOLOAD='isa'; goto &AUTOLOAD } -# Perl doesn't autoload these either: -#TODO: this prevents `use Util::H2O::Also;` sub import { our $AUTOLOAD='import'; goto &AUTOLOAD } -sub unimport { our $AUTOLOAD='unimport'; goto &AUTOLOAD } +# And provide a custom ->can that checks the hash: +sub can { + my ($self, $method) = @_; + return undef unless $method; ## no critic (ProhibitExplicitReturnUndef) + # the following are the only two we don't override + return $self->UNIVERSAL::can($method) if $method eq 'isa' || $method eq 'can'; + # for these, only return their code refs if they are also keys in the hash + if ( $method eq 'import' || $method eq 'unimport' || $method eq 'DOES' + || $method eq 'AUTOLOAD' || $method eq 'VERSION' || $method eq 'new' ) { + return exists $self->{$method} ? $self->UNIVERSAL::can($method) : undef; + } + # otherwise, if we've been subclassed, the user may have implemented the method + my $code = $self->UNIVERSAL::can($method); + return $code if defined $code; + # and finally, if the key is in the hash, return the accessor + return exists $self->{$method} ? sub { our $AUTOLOAD=$method; goto &AUTOLOAD } : undef; +} 1; __END__ diff --git a/t/Util-H2O-Also.t b/t/Util-H2O-Also.t index 0454497..a2ecb7d 100755 --- a/t/Util-H2O-Also.t +++ b/t/Util-H2O-Also.t @@ -20,10 +20,9 @@ L. =cut -use Test::More; #TODO: tests=>1; +use Test::More tests=>146; -#TODO: sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping) -#TODO: sub warns (&) { my @w; { local $SIG{__WARN__} = sub { push @w, shift }; shift->() } @w } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn) +sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping) ## no critic (RequireTestLabels) @@ -31,4 +30,215 @@ diag "This is Perl $] at $^X on $^O"; BEGIN { require_ok 'Util::H2O::Also' } is $Util::H2O::Also::VERSION, '0.26'; +# basic tests +{ + my $o = Util::H2O::Also->new({foo=>'bar'}); + isa_ok $o, 'Util::H2O::Also'; + # basic read/write + is $o->foo, 'bar'; + is $o->foo('quz'), 'quz'; + is $o->foo, 'quz'; + # unknown key + ok exception { $o->bar }; + ok exception { $o->{bar} }; + ok !exists $o->{bar}; + # can + is ref $o->can('foo'), 'CODE'; + is $o->can('foo')->($o), 'quz'; + is $o->can('bar'), undef; + is ref $o->can('can'), 'CODE'; + is ref $o->can('can')->($o, 'isa'), 'CODE'; + is ref $o->can('isa'), 'CODE'; + ok $o->can('isa')->($o, 'Util::H2O::Also'); + ok !$o->can('isa')->($o, 'Test1'); + is $o->can('new'), undef; + is $o->can('AUTOLOAD'), undef; + is $o->can('DOES'), undef; + is $o->can('VERSION'), undef; + is $o->can('import'), undef; + is $o->can('unimport'), undef; + is $o->can('DESTROY'), undef; +} +# test overridden methods +{ + my $o = Util::H2O::Also->new({ new=>'n', AUTOLOAD=>'a', DOES=>'d', VERSION=>'v', import=>'i', + unimport=>'u', DESTROY=>'D' }); + isa_ok $o, 'Util::H2O::Also'; + is $o->new, 'n'; + is $o->AUTOLOAD, 'a'; + is $o->DOES, 'd'; + is $o->VERSION, 'v'; + is $o->import, 'i'; + is $o->unimport, 'u'; + # can + is $o->can('foo'), undef; + is $o->can('bar'), undef; + is ref $o->can('can'), 'CODE'; + is ref $o->can('isa'), 'CODE'; + is ref $o->can('new'), 'CODE'; + is $o->can('new')->($o), 'n'; + is ref $o->can('AUTOLOAD'), 'CODE'; + is $o->can('AUTOLOAD')->($o), 'a'; + is ref $o->can('DOES'), 'CODE'; + is $o->can('DOES')->($o), 'd'; + is ref $o->can('VERSION'), 'CODE'; + is $o->can('VERSION')->($o), 'v'; + is ref $o->can('import'), 'CODE'; + is $o->can('import')->($o), 'i'; + is ref $o->can('unimport'), 'CODE'; + is $o->can('unimport')->($o), 'u'; + is ref $o->can('DESTROY'), 'CODE'; + is $o->can('DESTROY')->($o), 'D'; +} +# test subclassing +{ + package Test1; + use parent 'Util::H2O::Also'; + sub quz { return 'Quz' } +} +{ + # basic subclassing: one attribute from hash and one method from class + my $o = Test1->new({foo=>'bar'}); + isa_ok $o, 'Util::H2O::Also'; + isa_ok $o, 'Test1'; + is $o->foo, 'bar'; + is $o->quz, 'Quz'; + # can + is ref $o->can('foo'), 'CODE'; + is $o->can('foo')->($o), 'bar'; + is $o->can('bar'), undef; + is ref $o->can('quz'), 'CODE'; + is $o->can('quz')->(), 'Quz'; + is ref $o->can('can'), 'CODE'; + is ref $o->can('isa'), 'CODE'; + is $o->can('new'), undef; + is $o->can('AUTOLOAD'), undef; + is $o->can('DOES'), undef; + is $o->can('VERSION'), undef; + is $o->can('import'), undef; + is $o->can('unimport'), undef; + is $o->can('DESTROY'), undef; +} +{ + # the method from the class overrides the attribute from the hash + my $o = Test1->new({quz=>'Hello'}); + isa_ok $o, 'Util::H2O::Also'; + isa_ok $o, 'Test1'; + is $o->quz, 'Quz'; + # can + is $o->can('foo'), undef; + is $o->can('bar'), undef; + is ref $o->can('quz'), 'CODE'; + is $o->can('quz')->(), 'Quz'; + is ref $o->can('can'), 'CODE'; + is ref $o->can('isa'), 'CODE'; + is $o->can('new'), undef; + is $o->can('AUTOLOAD'), undef; + is $o->can('DOES'), undef; + is $o->can('VERSION'), undef; + is $o->can('import'), undef; + is $o->can('unimport'), undef; + is $o->can('DESTROY'), undef; +} +{ + # overridden method still work as attributes + my $o = Test1->new({ new=>'n', AUTOLOAD=>'a', DOES=>'d', VERSION=>'v', import=>'i', + unimport=>'u', DESTROY=>'D' }); + isa_ok $o, 'Util::H2O::Also'; + isa_ok $o, 'Test1'; + is $o->quz, 'Quz'; + is $o->new, 'n'; + is $o->AUTOLOAD, 'a'; + is $o->DOES, 'd'; + is $o->VERSION, 'v'; + is $o->import, 'i'; + is $o->unimport, 'u'; + # can + is $o->can('foo'), undef; + is $o->can('bar'), undef; + is ref $o->can('quz'), 'CODE'; + is $o->can('quz')->(), 'Quz'; + is ref $o->can('can'), 'CODE'; + is ref $o->can('isa'), 'CODE'; + is ref $o->can('new'), 'CODE'; + is $o->can('new')->($o), 'n'; + is ref $o->can('AUTOLOAD'), 'CODE'; + is $o->can('AUTOLOAD')->($o), 'a'; + is ref $o->can('DOES'), 'CODE'; + is $o->can('DOES')->($o), 'd'; + is ref $o->can('VERSION'), 'CODE'; + is $o->can('VERSION')->($o), 'v'; + is ref $o->can('import'), 'CODE'; + is $o->can('import')->($o), 'i'; + is ref $o->can('unimport'), 'CODE'; + is $o->can('unimport')->($o), 'u'; + is ref $o->can('DESTROY'), 'CODE'; + is $o->can('DESTROY')->($o), 'D'; +} + +# default: lock keys +{ + my $h = { hello=>'world' }; + my $o = Util::H2O::Also->new($h); + ok exception { $h->{world} = 'perl' }; + is ref $o->can('hello'), 'CODE'; + is $o->can('hello')->($o), 'world'; + is $o->can('world'), undef; +} +# lock entire hash +{ + my $h = { hello=>'world' }; + my $o = Util::H2O::Also->new(-ro, $h); + ok exception { $h->{world} = 'perl' }; + ok exception { delete $h->{hello} }; + ok exception { $h->{hello} = 'foo' }; + # can + is ref $o->can('hello'), 'CODE'; + is $o->can('hello')->($o), 'world'; + is $o->can('world'), undef; +} +# nolock +{ + my $h = { hello=>'world' }; + my $o = Util::H2O::Also->new(-nolock, $h); + # modifying the hash makes the accessor work + $h->{world} = 'perl'; + is $h->world, 'perl'; + # but calling an accessor for a nonexistent hash key still doesn't work (TODO Later: should it?) + ok exception { $h->err }; + # can + is ref $o->can('hello'), 'CODE'; + is $o->can('hello')->($o), 'world'; + is ref $o->can('world'), 'CODE'; + is $o->can('world')->($o), 'perl'; +} + +# exceptions +{ + my $dummy = bless {}, 'Dummy'; + ok exception { Util::H2O::Also->new() }; + ok exception { Util::H2O::Also->new($dummy) }; + ok exception { Util::H2O::Also->new('') }; + ok exception { Util::H2O::Also->new('bad') }; + ok exception { Util::H2O::Also->new(-bad) }; + ok exception { Util::H2O::Also->new(-ro, -nolock, {}) }; +} + +# unusual things that shouldn't happen in normal code (mostly for coverage) +{ + is( Util::H2O::Also->new({})->can(), undef ); + my $dummy = bless {}, 'Dummy'; + ok( !Util::H2O::Also::import() ); + ok( !Util::H2O::Also::import({}) ); + ok( !Util::H2O::Also::import($dummy) ); + ok( !Util::H2O::Also::unimport() ); + ok( !Util::H2O::Also::unimport({}) ); + ok( !Util::H2O::Also::unimport($dummy) ); + ok exception { Util::H2O::Also::AUTOLOAD() }; + ok exception { Util::H2O::Also::AUTOLOAD({}) }; + ok exception { Util::H2O::Also::AUTOLOAD($dummy) }; + ok exception { Util::H2O::Also::new() }; + ok exception { Util::H2O::Also::new($dummy) }; +} + done_testing; diff --git a/xt/author.t b/xt/author.t index 056c6dc..21ae0ab 100755 --- a/xt/author.t +++ b/xt/author.t @@ -1,4 +1,4 @@ -#!/usr/bin/env perl +#!/usr/bin/env perl ## no critic (ProhibitExcessMainComplexity) use warnings; use strict; @@ -34,7 +34,7 @@ BEGIN { ); } -use Test::More tests => 3*@PERLFILES + 7; +use Test::More tests => 3*@PERLFILES + 8; BEGIN { use_ok 'Util::H2O' } BEGIN { use_ok 'Util::H2O::Also' } note explain \@PERLFILES; @@ -132,6 +132,20 @@ subtest 'synopsis code' => sub { plan tests=>8; END_CODE }, "bar\nworld!\nbeans\n0.927\n", 'output of synopsis correct'; }; +subtest '::Also synopsis' => sub { plan tests=>5; + my $verbatim = getverbatim($PERLFILES[1], qr/\b(?:synopsis)\b/i); + is @$verbatim, 1, 'verbatim block count' or diag explain $verbatim; + is capture_merged { + my $code = <<"END_CODE"; eval "{$code\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) + use warnings; use strict; + $$verbatim[0] + ; + is_deeply \$hash, { foo=>'bar', x=>'z' }, 'synopsis \$hash'; + isa_ok \$obj, 'MyClass'; + isa_ok \$obj, 'Util::H2O::Also'; +END_CODE + }, "bar\nbeans\n", 'output of synopsis correct'; +}; subtest 'cookbook code' => sub { plan tests=>22; my $codes = getverbatim($PERLFILES[0], qr/\b(?:cookbook)\b/i); diff --git a/xt/bench.t b/xt/bench.t index f3cec55..4cbe5e4 100755 --- a/xt/bench.t +++ b/xt/bench.t @@ -4,18 +4,21 @@ use strict; use Test::More tests=>1; use Util::H2O; use Util::H2O::Also; -use Benchmark 'cmpthese'; +use Benchmark qw/ timethese cmpthese /; my %hash = ( Hello=>'World' ); my $o1 = h2o {%hash}; my $o2 = Util::H2O::Also->new({%hash}); -cmpthese(-2, { +my $r = timethese(-2, { 'H2O' => sub { $o1->Hello }, 'Also' => sub { $o2->Hello }, }); +cmpthese $r; -pass 'TODO'; +my $ratio = $$r{H2O}->iters / $$r{Also}->iters; +ok $ratio > 5.5, 'expect Util::H2O to be ~6x faster than Util::H2O::Also, actual ratio ' + .sprintf('%.2f', $ratio); done_testing; \ No newline at end of file From 31dd96e2c9897d58ed238600392352aedeb0ddac Mon Sep 17 00:00:00 2001 From: Hauke D Date: Sat, 14 Sep 2024 19:03:12 +0000 Subject: [PATCH 3/4] [WIP also] Compatibility with old Perls --- t/Util-H2O-Also.t | 2 +- xt/author.t | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/t/Util-H2O-Also.t b/t/Util-H2O-Also.t index a2ecb7d..2712492 100755 --- a/t/Util-H2O-Also.t +++ b/t/Util-H2O-Also.t @@ -93,7 +93,7 @@ is $Util::H2O::Also::VERSION, '0.26'; # test subclassing { package Test1; - use parent 'Util::H2O::Also'; + our @ISA = ('Util::H2O::Also'); ## no critic (ProhibitExplicitISA) sub quz { return 'Quz' } } { diff --git a/xt/author.t b/xt/author.t index 21ae0ab..38d8039 100755 --- a/xt/author.t +++ b/xt/author.t @@ -135,6 +135,7 @@ END_CODE subtest '::Also synopsis' => sub { plan tests=>5; my $verbatim = getverbatim($PERLFILES[1], qr/\b(?:synopsis)\b/i); is @$verbatim, 1, 'verbatim block count' or diag explain $verbatim; + $$verbatim[0] =~ s/^\s*use\s+\Kparent\b/base/mg if $] lt '5.010001'; is capture_merged { my $code = <<"END_CODE"; eval "{$code\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) use warnings; use strict; From 635c0e78889f7faa830793340fd43742c94f7e7d Mon Sep 17 00:00:00 2001 From: Hauke D Date: Sat, 14 Sep 2024 19:06:16 +0000 Subject: [PATCH 4/4] [WIP also] More minor backcompat stuff --- xt/author.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xt/author.t b/xt/author.t index 38d8039..75ea1f3 100755 --- a/xt/author.t +++ b/xt/author.t @@ -135,7 +135,7 @@ END_CODE subtest '::Also synopsis' => sub { plan tests=>5; my $verbatim = getverbatim($PERLFILES[1], qr/\b(?:synopsis)\b/i); is @$verbatim, 1, 'verbatim block count' or diag explain $verbatim; - $$verbatim[0] =~ s/^\s*use\s+\Kparent\b/base/mg if $] lt '5.010001'; + $$verbatim[0] =~ s/^(\s*use\s+)parent\b/${1}base/mg if $] lt '5.010001'; is capture_merged { my $code = <<"END_CODE"; eval "{$code\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) use warnings; use strict;