From 7825e6886acab30d1dcc37581ea82764f260411f Mon Sep 17 00:00:00 2001 From: Hauke D Date: Sat, 14 Sep 2024 16:22:11 +0000 Subject: [PATCH] Added -parent option (closes #24) --- Changes | 3 ++ lib/Util/H2O.pm | 125 ++++++++++++++++++++++++++++++++---------------- t/Util-H2O.t | 55 ++++++++++++++++++--- xt/author.t | 15 +++++- 4 files changed, 150 insertions(+), 48 deletions(-) diff --git a/Changes b/Changes index a0b226e..79484d4 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,9 @@ Revision history for Perl extension Util::H2O. 0.26 not yet released - Increased minimum required Perl version to 5.8.9 + - Added `-parent` option (Thanks @XSven!) + - WARNING: Potentially Incompatible Change: + - The `-isa` option now adds to the target `@ISA` array instead of replacing it. 0.24 Wed, Dec 13 2023 commit 10a8b75ad51a195fc8c8a7a5e8633bec4bf6eb8b - fix a bug where o2h would die on scalars that looked like options diff --git a/lib/Util/H2O.pm b/lib/Util/H2O.pm index ba06910..2eefea1 100644 --- a/lib/Util/H2O.pm +++ b/lib/Util/H2O.pm @@ -47,6 +47,10 @@ our $VERSION = '0.26'; our @EXPORT = qw/ h2o /; ## no critic (ProhibitAutomaticExportation) our @EXPORT_OK = qw/ o2h /; +#TODO Later: At some future release, we could assume everyone is up-to-date and/or +# has access to older versions of the documentation, and therefore remove all of +# the historical information about how different versions of the module behaved. + =head1 Description This module allows you to turn hashrefs into objects, so that instead @@ -112,27 +116,37 @@ method with the same name. Specify the class name into which to bless the object (as opposed to the default: a generated, unique package name in C). -I If you use this option, C<-clean> defaults to I, +B For the reasons described below, +using this option by itself is usually not advisable. +If you want to use C for ad-hoc I creation, you should probably +use C<-new> in addition to this option, or just use C<-classify> instead. +If on the other hand you want to create several ad-hoc objects that are all +of a specific type (in other words, they all have the same parent class), +you should use C<-parent> in addition to this option. + +I The C<-parent> option changes the meaning of this option +slightly, please see its documentation for details. + +I If you use this option, C<-clean> defaults to I, meaning that the package will stay in Perl's symbol table and use -memory accordingly, and since this function installs the accessors in -the package every time it is called, if you re-use the same package -name, you will get "redefined" warnings. Therefore, if you want to -create multiple objects in the same package, you should probably use -C<-new> or C<-classify>. - -If you wanted to generate a unique package name in a different package, -you could use: -C<< h2o -class => sprintf('My::Class::Name::_%x', $hash+0), $hash >>, -perhaps even in combination with C<< -isa => 'My::Class::Name' >>. -However, keep in mind that you shouldn't step into another class' namespace -without knowing that this won't cause conflicts, and also that not using the -default class names means that functions like C will no longer identify -the objects as coming from C. +memory accordingly, and since +B installs the accessors (methods) in the package every time it is called>, +if you re-use the same package name, you will get "redefined" warnings, +telling you that something is wrong. +This is why you should most likely use C<-new> or C<-classify> +if you want to create multiple objects in the same package. + +I Be aware that not using the default class names means that functions +like C will no longer identify the objects as coming from C. + +I Keep in mind that you shouldn't step into another class' namespace +without knowing that this won't cause conflicts. =item C<< -classify => I >> In the form C<< -classify => I >>, this is simply the short -form of the options C<< -new, -meth, -class => I >>. +form of the options C<< -new, -meth, -class => I >>; +please see those options for details. As of v0.16, in the special form C<< -classify => I<$hashref> >>, where the C<-classify> B be the B option in C<@opts> before the @@ -152,23 +166,48 @@ C, or perhaps if you want to write your methods as regular Cs: }, qw/ x y /; } -Note C will remain in the package's namespace, one possibility is that you -could load L after you load this module. +Note that in this example, C will remain in the package's namespace. +To avoid that, you could C and then call the function as C, +or you could load L after you load this module. You might also note that in the above example, one could write C as a -regular C in the package. And at that point, one might recongize the +regular C in the package. And at that point, one might recognize the similarity between the code and what one can do with e.g. L or even L. +I the C<-parent> option changes the meaning of this option +slightly, please see its documentation for details. + +=item C<-parent> + +Convenience option that must be used together with C<< -class => 'YourClassName' >>, +where it is the equivalent of +C<< -class => sprintf('YourClassName::_%x', $hash+0), -isa => 'YourClassName' >>. +In other words, using this option causes the object to become a subclass of the +specified class name, with a unique class name under the specified name. + +I that this means that this option changes the meaning of the C<-class>/C<-classify> +options a bit, in that the resulting object will no longer have exactly the package +name you specified with those options. + +Please be aware of the various B documented in C<-class> and C<-isa>, such as that +superclass methods aren't called, and that C<-clean> will default to I. + +If you use C<-isa> in addition to this option, those package names will be I +to C<@ISA> in addition to the class name as described above. +This option was added in v0.26. + =item C<< -isa => I >> -Convenience option to set the L|perlvar/"@ISA"> variable in the package +Convenience option to add items to the L|perlvar/"@ISA"> variable in the package of the object, so that the object inherits from that/those package(s). -This option was added in v0.14. + +This option was added in v0.14, and its behavior was B slightly in v0.26: +previously, this option would overwrite any previous value of C<@ISA>, now it appends. B The methods created by C will not call superclass methods. This means the parent class' C method(s) are not called, and any -accessors generated from hash keys are blindly overriden. +accessors generated from hash keys are blindly overridden. =item C<-new> @@ -206,13 +245,14 @@ modifications to the hash's keyset. Defaults to I. The C<-nolock> option is provided as a short form of C<< -lock=>0 >>. Keysets of objects created by the constructor generated by the -C<-new> option are also locked. Versions of this module before -v0.12 did not lock the keysets of new objects. +C<-new> option are also locked. -Versions of this module before v0.06 did not lock the keyset. -Versions of this module as of v0.12 issue a warning on old Perls. -(Versions of this module before v0.26 were compatible with Perls older than v5.8.9, -where L and its C were not available.) +Versions of this module before v0.06 did not lock the keyset at all. +Versions of this module before v0.12 did not lock the keysets of new objects. +Versions of this module from v0.12 to v0.24 (inclusive) issued a warning on old Perls. +Versions of this module before v0.26 were compatible with Perls older than v5.8.9, +where L and its C were not available, but newer versions +require at least that version of perl, so that hash locking is always available. =item C<-nolock> @@ -328,17 +368,18 @@ The (now blessed and optionally locked) C<$hashref>. our $_PACKAGE_REGEX = qr/\AUtil::H2O::_[0-9A-Fa-f]+\z/; sub h2o { ## no critic (RequireArgUnpacking, ProhibitExcessComplexity) - my ($recurse,$arrays,$meth,$class,$isa,$destroy,$new,$clean,$lock,$ro,$pass); + my ($recurse,$arrays,$meth,$class,$isa,$destroy,$new,$clean,$lock,$ro,$pass,$parent); while ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-/ ) { - if ($_[0] eq '-recurse' ) { $recurse = shift } ## no critic (ProhibitCascadingIfElse) - elsif ($_[0] eq '-arrays'){ $arrays = shift } - elsif ($_[0] eq '-meth' ) { $meth = shift } - elsif ($_[0] eq '-clean') { $clean = (shift, shift()?1:0) } - elsif ($_[0] eq '-lock' ) { $lock = (shift, shift()?1:0) } - elsif ($_[0] eq '-nolock'){ $lock = 0; shift } - elsif ($_[0] eq '-ro' ) { $ro = shift } - elsif ($_[0] eq '-new' ) { $new = shift } - elsif ($_[0] eq '-pass' ) { + if ($_[0] eq '-recurse') { $recurse = shift } ## no critic (ProhibitCascadingIfElse) + elsif ($_[0] eq '-arrays') { $arrays = shift } + elsif ($_[0] eq '-meth' ) { $meth = shift } + elsif ($_[0] eq '-clean' ) { $clean = (shift, shift()?1:0) } + elsif ($_[0] eq '-lock' ) { $lock = (shift, shift()?1:0) } + elsif ($_[0] eq '-nolock') { $lock = 0; shift } + elsif ($_[0] eq '-ro' ) { $ro = shift } + elsif ($_[0] eq '-new' ) { $new = shift } + elsif ($_[0] eq '-parent') { $parent = shift } + elsif ($_[0] eq '-pass') { $pass = (shift, shift); croak "invalid -pass option value (must be 'undef' or 'ref')" if !defined $pass || $pass ne 'undef' && $pass ne 'ref'; @@ -366,6 +407,7 @@ sub h2o { ## no critic (RequireArgUnpacking, ProhibitExcessComplexity) } else { croak "unknown option to h2o: '$_[0]'" } } + croak "-parent must be used with -class or -classify" if $parent && !$class; $clean = !defined $class unless defined $clean; $lock = 1 unless defined $lock; $recurse = 1 if $arrays; @@ -405,7 +447,9 @@ sub h2o { ## no critic (RequireArgUnpacking, ProhibitExcessComplexity) { h2o($arrays?-arrays:-recurse, -lock=>$lock, ($ro?-ro:()), $_) } } } - my $pack = defined $class ? $class : sprintf('Util::H2O::_%x', $hash+0); + my $pack = defined $class + ? ( $parent ? sprintf('%s::_%x', $class, $hash+0) : $class ) + : sprintf('Util::H2O::_%x', $hash+0); for my $k (keys %keys) { my $sub = $ro ? sub { my $self = shift; croak "this object is read-only" if @_; exists $self->{$k} ? $self->{$k} : undef } @@ -438,7 +482,8 @@ sub h2o { ## no critic (RequireArgUnpacking, ProhibitExcessComplexity) }; { no strict 'refs'; *{$pack.'::new'} = $sub } ## no critic (ProhibitNoStrict) } - if ($isa) { no strict 'refs'; @{$pack.'::ISA'} = @$isa } ## no critic (ProhibitNoStrict) + if ($parent) { no strict 'refs'; push @{$pack.'::ISA'}, $class } ## no critic (ProhibitNoStrict) + if ($isa) { no strict 'refs'; push @{$pack.'::ISA'}, @$isa } ## no critic (ProhibitNoStrict) bless $hash, $pack; if ($ro) { lock_hashref $hash } elsif ($lock) { lock_ref_keys $hash, keys %keys } diff --git a/t/Util-H2O.t b/t/Util-H2O.t index 4baf5cf..b01731b 100755 --- a/t/Util-H2O.t +++ b/t/Util-H2O.t @@ -20,7 +20,7 @@ L. =cut -use Test::More tests => 339; +use Test::More tests => 360; use Scalar::Util qw/blessed/; use Symbol qw/delete_package/; @@ -293,13 +293,13 @@ my $PACKRE = $Util::H2O::_PACKAGE_REGEX; ## no critic (ProtectPrivateVars) } # -isa +sub get_isa { + my $x = shift; + $x = ref $x if ref $x; + no strict 'refs'; ## no critic (ProhibitNoStrict) + return \@{$x.'::ISA'}; +} { - sub get_isa { - my $x = shift; - $x = ref $x if ref $x; - no strict 'refs'; ## no critic (ProhibitNoStrict) - return \@{$x.'::ISA'}; - } { package IsaTest2; ## no critic (ProhibitMultiplePackages) sub foo { return "foo" } } @@ -310,6 +310,8 @@ my $PACKRE = $Util::H2O::_PACKAGE_REGEX; ## no critic (ProtectPrivateVars) { package IsaTest5; ## no critic (ProhibitMultiplePackages) sub quz { return "quz" } } + { package IsaTest6; ## no critic (ProhibitMultiplePackages) + our @ISA = ('IsaTest5'); } ## no critic (ProhibitExplicitISA) my $o1 = h2o {}; is_deeply get_isa($o1), []; h2o -class=>'IsaTest1', {}; @@ -332,6 +334,45 @@ my $PACKRE = $Util::H2O::_PACKAGE_REGEX; ## no critic (ProtectPrivateVars) ok $o4->can("foo"); ok $o4->can("bar"); ok $o4->can("quz"); + my $o6 = h2o -isa=>'IsaTest3', -class=>'IsaTest6', {}; + ok $o6->isa('IsaTest6'); + ok $o6->isa('IsaTest5'); + ok $o6->isa('IsaTest3'); + ok $o6->isa('IsaTest2'); +} +# -parent +{ + ok exception { h2o -parent, {} }; # must be used with -class or -classify + ok exception { h2o -parent, -isa=>'Foo', {} }; + + my $o1 = h2o -class=>'ParOne', {}; + is_deeply get_isa($o1), []; + is ref $o1, 'ParOne'; + + my $o2 = h2o -class=>'ParTwo', -parent, {}; + is_deeply get_isa($o2), ['ParTwo']; + like ref $o2, qr/^ParTwo::_[0-9a-f]+$/; + ok $o2->isa('ParTwo'); + + my $o3 = h2o -classify=>'ParThree', -parent, {}; + is_deeply get_isa($o3), ['ParThree']; + like ref $o3, qr/^ParThree::_[0-9a-f]+$/; + ok $o3->isa('ParThree'); + + { + package ParFour; ## no critic (ProhibitMultiplePackages) + my $o4 = main::h2o -parent, -classify, {}; + main::is_deeply main::get_isa($o4), ['ParFour']; + main::like ref $o4, qr/^ParFour::_[0-9a-f]+$/; + main::ok $o4->isa('ParFour'); + } + + { package ParSix } ## no critic (ProhibitMultiplePackages) + my $o5 = h2o -isa=>'ParSix', -class=>'ParFive', -parent, {}; + is_deeply get_isa($o5), ['ParFive','ParSix']; + like ref $o5, qr/^ParFive::_[0-9a-f]+$/; + ok $o5->isa('ParFive'); + ok $o5->isa('ParSix'); } # -clean diff --git a/xt/author.t b/xt/author.t index a344770..6be64cb 100755 --- a/xt/author.t +++ b/xt/author.t @@ -33,7 +33,7 @@ BEGIN { ); } -use Test::More tests => 3*@PERLFILES + 6; +use Test::More tests => 3*@PERLFILES + 7; BEGIN { use_ok 'Util::H2O' } note explain \@PERLFILES; @@ -93,6 +93,19 @@ subtest 'namespace::clean' => sub { plan tests=>4; is $o->test, "", 'method'; ok !exists &Yet::Another::h2o, 'cleaned'; }; +# and this is the other documented alternative for keeping the namespace clean +subtest 'without import' => sub { plan tests=>4; + { + package And::Again; ## no critic (ProhibitMultiplePackages) + use Util::H2O (); + Util::H2O::h2o -classify, { foo=>sub{"Foo!"} }, qw/bar/; + sub test2 { return "<".shift->bar.">" } + } + my $o = new_ok 'And::Again', [ bar=>"xyz" ]; + is $o->foo, "Foo!", 'getter'; + is $o->test2, "", 'method'; + ok !exists &And::Again::h2o, 'not present'; +}; subtest 'destroy errors' => sub { plan tests=>2; # Possible To-Do for Later: For a reason I can't explain yet, the warning from the destructor is not always captured by the signal handler here.