Util-H2O-0.24/0000700000175000017500000000000014536334175012277 5ustar haukexhaukexUtil-H2O-0.24/LICENSE.txt0000644000175000017500000001664314121612736014136 0ustar haukexhaukexNAME perlartistic - the Perl Artistic License SYNOPSIS You can refer to this document in Pod via "L" Or you can see this document by entering "perldoc perlartistic" DESCRIPTION Perl is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this Kit. This is "The Artistic License". It's here so that modules, programs, etc., that want to declare this as their distribution license can link to it. For the GNU General Public License, see perlgpl. The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. Conditions 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Util-H2O-0.24/lib/0000700000175000017500000000000014536334175013045 5ustar haukexhaukexUtil-H2O-0.24/lib/Util/0000700000175000017500000000000014536334175013762 5ustar haukexhaukexUtil-H2O-0.24/lib/Util/H2O.pm0000644000175000017500000006043214536333017014721 0ustar haukexhaukex#!perl package Util::H2O; use warnings; use strict; use Exporter 'import'; use Carp; use Symbol qw/delete_package/; =head1 Name Util::H2O - Hash to Object: turns hashrefs into objects with accessors for keys =head1 Synopsis use Util::H2O; my $hash = h2o { foo => "bar", x => "y" }, qw/ more keys /; print $hash->foo, "\n"; # accessor $hash->x("z"); # change value $hash->more("cowbell"); # additional keys my $struct = { hello => { perl => "world!" } }; h2o -recurse, $struct; # objectify nested hashrefs as well print $struct->hello->perl, "\n"; my $obj = h2o -meth, { # code references become methods what => "beans", cool => sub { my $self = shift; print $self->what, "\n"; } }; $obj->cool; # prints "beans" h2o -classify=>'Point', { # whip up a class angle => sub { my $self = shift; atan2($self->y, $self->x) } }, qw/ x y /; my $one = Point->new(x=>1, y=>2); my $two = Point->new(x=>3, y=>4); printf "%.3f\n", $two->angle; # prints 0.927 =cut our $VERSION = '0.24'; # For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file our @EXPORT = qw/ h2o /; ## no critic (ProhibitAutomaticExportation) our @EXPORT_OK = qw/ o2h /; BEGIN { # lock_ref_keys wasn't available until Hash::Util 0.06 / Perl v5.8.9 # (note the following will probably also fail on the Perl v5.9 dev releases) # uncoverable branch false # uncoverable condition false if ( $] ge '5.008009' ) { require Hash::Util; Hash::Util->import(qw/ lock_ref_keys lock_hashref /) } else { *lock_ref_keys = *lock_hashref = sub { carp "this Perl is too old to lock the hash"; # uncoverable statement }; # uncoverable statement } } =head1 Description This module allows you to turn hashrefs into objects, so that instead of C<< $hash->{key} >> you can write C<< $hash->key >>, plus you get protection from typos. In addition, options are provided that allow you to whip up really simple classes. You can still use the hash like a normal hashref as well, as in C<< $hash->{key} >>, C, and so on, but note that by default this function also locks the hash's keyset to prevent typos there too. This module exports a single function by default. =head2 C, I<$hashref>, I<@additional_keys>> =head3 C<@opts> If you specify an option with a value multiple times, only the last one will take effect. =over =item C<-recurse> Nested hashes are objectified as well. The only options that are passed down to nested hashes are C<-lock> and C<-ro>. I of the other options will be applied to the nested hashes, including C<@additional_keys>. Nested arrayrefs are not recursed into, but see the C<-arrays> option for that. Versions of this module before v0.12 did not pass down the C<-lock> option, meaning that if you used C<-nolock, -recurse> on those versions, the nested hashes would still be locked. =item C<-arrays> Like C<-recurse>, but additionally, C is applied to elements of nested arrays as well. The same options as with C<-recurse> are passed down to nested hashes and arrayrefs. Takes precedence over the C<-pass> option, i.e. if you use these two options together, arrayrefs are still descended into. Like hashrefs, the original arrays are modified! This option implies C<-recurse>. This option was added in v0.20. =item C<-meth> Any code references present in the hash at the time of this function call will be turned into methods. Because these methods are installed into the object's package, they can't be changed later by modifying the hash. To avoid confusion when iterating over the hash, the hash entries that were turned into methods are removed from the hash. The key is also removed from the "allowed keys" (see the C<-lock> option), I you specify it in C<@additional_keys>. In that case, you can change the value of that key completely independently of the method with the same name. =item C<< -class => I >> 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, 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. =item C<< -classify => I >> In the form C<< -classify => I >>, this is simply the short form of the options C<< -new, -meth, -class => I >>. 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 L|/"$hashref">, it is the same as C<< -new, -meth, -class => __PACKAGE__, I<$hashref> >> - that is, the current package's name is used as the custom class name. It does not make sense to use this outside of an explicit package, since your class will be named C
. With this option, the C example in the L can be written like the following, which can be useful if you want to add more things to the C, or perhaps if you want to write your methods as regular Cs: { package Point; use Util::H2O; h2o -classify, { angle => sub { my $self = shift; atan2($self->y, $self->x) } }, 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. 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 similarity between the code and what one can do with e.g. L or even L. =item C<< -isa => I >> Convenience option to set 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. 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. =item C<-new> Generates a constructor named C in the package. The constructor works as a class and instance method, and dies if it is given any arguments that it doesn't know about. If you want more advanced features, like required arguments, validation, or other initialization, you should probably L to something like L instead. =item C<< -destroy => I >> Allows you to specify a custom destructor. This coderef will be called from the object's actual C in void context with the first argument being the same as the first argument to the C method. Errors will be converted to warnings. This option was added in v0.14. =item C<< -clean => I >> Whether or not to clean up the generated package when the object is destroyed. Defaults to I when C<-class> is specified, I otherwise. If this is I, be aware that the packages will stay in Perl's symbol table and use memory accordingly, and any subs/methods in those packages may cause "redefined" warnings if the package name is re-used. As of v0.16, this module will refuse to delete the package if it is named C
. =item C<< -lock => I >> Whether or not to use L's C to prevent 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. Note that on really old Perls, that is, before Perl v5.8.9, L and its C are not available, so the hash is never locked on those versions of Perl. 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. =item C<-nolock> Short form of the option C<< -lock=>0 >>. =item C<-ro> Makes the entire hash read-only using L's C and the generated accessors will also throw an error if you try to change values. In other words, this makes the object and the underlying hash immutable. You cannot specify any C<@additional_keys> with this option enabled unless you also use the C<-new> option - the additional keys will then only be useful as arguments to the constructor. This option can't be used with C<-nolock> or C<< -lock=>0 >>. This option was added in v0.12. Using this option will not work and cause a warning when used on really old Perls (before v5.8.9), because this functionality was not yet available there. =item C<< -pass => "ref" I "undef" >> When this option is set to C<"undef"> (that's the string C<"undef">, I C itself!), then passing a value of C for the C<$hashref> will not result in a fatal error, the value will simply be passed through. When this option is set to the string C<"ref">, then any value other than a plain hashref that is a reference, including objects, plus C as above, will be passed through without modification. Any hashes nested inside of these references will not be descended into, even when C<-recurse> is specified. However, C<-arrays> takes precedence over this option, see its documentation. This option was added in v0.18. =back =head3 C<$hashref> You must supply a plain (unblessed) hash reference here, unless you've specified the C<-pass> and/or C<-arrays> options. Be aware that this function I modify the original hashref(s) by blessing it and locking its keyset (the latter can be disabled with the C<-lock> option), and if you use C<-meth> or C<-classify>, keys whose values are code references will be removed. If you use C<-arrays>, the elements of those arrays may also be modified. An accessor will be set up for each key in the hash(es); note that the keys must of course be valid Perl identifiers for you to be able to call the method normally (see also the L). The following keys will be treated specially by this module. Please note that there are further keys that are treated specially by Perl and/or that other code may expect to be special, such as L's C. See also L and the references therein. =over =item C This key is not allowed in the hash if the C<-new> option is on. =item C This key is not allowed except if all of the following apply: =over =item * C<-destroy> is not used, =item * C<-clean> is off (which happens by default when you use C<-class>), =item * C<-meth> is on, and =item * the value of the key C is a coderef. =back Versions of this module before v0.14 allowed a C key in more circumstances (whenever C<-clean> was off). =item C If your hash contains a key named C, or this key is present in C<@additional_keys>, this module will set up a method called C, which is subject to Perl's normal autoloading behavior - see L and L. Without the C<-meth> option, you will get a "catch-all" accessor to which all method calls to unknown method names will go, and with C<-meth> enabled (which is implied by C<-classify>), you can install your own custom C handler by passing a coderef as the value for this key - see L. However, it is important to note that enabling autoloading removes any typo protection on method names! =back =head3 C<@additional_keys> Methods will be set up for these keys even if they do not exist in the hash. Please see the list of keys that are treated specially above. =head3 Returns The (now blessed and optionally locked) C<$hashref>. =cut 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); 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' ) { $pass = (shift, shift); croak "invalid -pass option value (must be 'undef' or 'ref')" if !defined $pass || $pass ne 'undef' && $pass ne 'ref'; } elsif ($_[0] eq '-class') { $class = (shift, shift); croak "invalid -class option value" if !defined $class || ref $class || !length $class; } elsif ($_[0] eq '-classify') { $class = (shift, shift); if ( ref $class eq 'HASH' ) { unshift @_, $class; $class = caller; } croak "invalid -classify option value" if !defined $class || ref $class || !length $class; $meth = 1; $new = 1; } elsif ($_[0] eq '-isa') { $isa = (shift, shift); croak "invalid -isa option value" if !( ref($isa) eq 'ARRAY' || !ref($isa) ); $isa = [$isa] unless ref $isa; } elsif ($_[0] eq '-destroy') { $destroy = (shift, shift); croak "invalid -destroy option value" unless ref $destroy eq 'CODE'; } else { croak "unknown option to h2o: '$_[0]'" } } $clean = !defined $class unless defined $clean; $lock = 1 unless defined $lock; $recurse = 1 if $arrays; my $hash = shift; if ( ref $hash ne 'HASH' ) { if ( $arrays && ref $hash eq 'ARRAY' ) { for (@$hash) { h2o( -arrays, -lock=>$lock, ($ro?-ro:()), $_ ) if ref eq 'HASH' || ref eq 'ARRAY' } return $hash; } elsif ( $pass ) { if ( $pass eq 'ref' ) { return $hash if !defined $hash || ref $hash; croak "this h2o call only accepts references or undef"; } else { # $pass must be 'undef' due to checks above return $hash if !defined $hash; croak "this h2o call only accepts a plain hashref or undef"; } } croak "this h2o call only accepts plain hashrefs"; } croak "h2o with additional keys doesn't make sense with -ro" if $ro && @_ && !$new; my %ak = map {$_=>1} @_; my %keys = map {$_=>1} @_, keys %$hash; croak "h2o hashref may not contain a key named DESTROY" if exists $keys{DESTROY} && ( $destroy || $clean || !$meth || ref $hash->{DESTROY} ne 'CODE' ); croak "h2o hashref may not contain a key named new if you use the -new option" if $new && exists $keys{new}; croak "h2o can't turn off -lock if -ro is on" if $ro && !$lock; if ($recurse) { for (values %$hash) { if ( $arrays && ref eq 'ARRAY' ) { h2o(-arrays, -lock=>$lock, ($ro?-ro:()), $_) } elsif ( ref eq 'HASH' ) { h2o($arrays?-arrays:-recurse, -lock=>$lock, ($ro?-ro:()), $_) } } } my $pack = defined $class ? $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 } : sub { my $self = shift; $self->{$k} = shift if @_; $self->{$k} }; if ( $meth && ref $$hash{$k} eq 'CODE' ) { $sub = delete $$hash{$k}; $ak{$k} or delete $keys{$k} } { no strict 'refs'; *{"${pack}::$k"} = $sub } ## no critic (ProhibitNoStrict) } if ( $destroy || $clean ) { my $sub = sub { $destroy and ( eval { $destroy->($_[0]); 1 } or carp $@ ); ## no critic (ProhibitMixedBooleanOperators) if ( $clean ) { if ( $pack eq 'main' ) { carp "h2o refusing to delete package \"main\"" } else { delete_package($pack) } } }; { no strict 'refs'; *{$pack.'::DESTROY'} = $sub } ## no critic (ProhibitNoStrict) } if ( $new ) { my $sub = sub { my $class = shift; $class = ref $class if ref $class; croak "Odd number of elements in argument list" if @_%2; my $self = {@_}; exists $keys{$_} or croak "Unknown argument '$_'" for keys %$self; bless $self, $class; if ($ro) { lock_hashref $self } elsif ($lock) { lock_ref_keys $self, keys %keys } return $self; }; { no strict 'refs'; *{$pack.'::new'} = $sub } ## no critic (ProhibitNoStrict) } if ($isa) { no strict 'refs'; @{$pack.'::ISA'} = @$isa } ## no critic (ProhibitNoStrict) bless $hash, $pack; if ($ro) { lock_hashref $hash } elsif ($lock) { lock_ref_keys $hash, keys %keys } return $hash; } =head2 C, I<$h2object>> This function takes an object as created by C and turns it back into a hashref by making shallow copies of the object hash and any nested objects that may have been created via C<-recurse>, C<-arrays>, or created manually. This function is recursive by default because for a non-recursive operation you can simply write: C<{%$h2object}> (making a shallow copy). Unlike C, this function returns a new hashref instead of modifying the given variable in place (unless what you give this function is not an C object, in which case it will just be returned unchanged). Similarly, if you specify the C<-arrays> option, shallow copies of arrays will be returned in place of the original ones, with C applied to the elements. B that this function operates only on objects in the default package - it does not step into plain hashrefs, it does not step into arrayrefs unless you specify C<-arrays>, nor does it operate on objects created with the C<-class> or C<-classify> options. Also be aware that because methods created via C<-meth> are removed from the object hash, these will disappear in the resulting hashref. This function was added in v0.18. =head3 C<@opts> If you specify an option with a value multiple times, only the last one will take effect. =over =item C<-arrays> If you specify this option, nested arrayrefs are descended into as well. This option was added in v0.20. =item C<--> This string ends the option processing, allowing you to pass scalar values to C that would otherwise be interpreted as options. The C function is special-cased such that a call C returns C<"--"> instead of throwing an error. This was added in v0.24 in order to fix a bug with scalars beginning with C<"-"> in earlier versions of this module. Users of C are advised to upgrade. =back =cut sub o2h { ## no critic (RequireArgUnpacking) my ($arrays); unless ( @_==1 && $_[0] && !ref$_[0] && $_[0]eq'--' ) { ## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions) while ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-/ ) { if ($_[0] eq '-arrays' ) { $arrays = shift } elsif ($_[0] eq '--') { shift; last } else { croak "unknown option to o2h: '$_[0]'" } } } croak "missing argument to o2h" unless @_; my $h2o = shift; croak "too many arguments to o2h" if @_; my @args = ( ( $arrays ? (-arrays) : () ), '--' ); if ( ref($h2o) =~ $_PACKAGE_REGEX ) { return { map { $_ => o2h(@args, $h2o->{$_}) } keys %$h2o } } elsif ( $arrays && ref $h2o eq 'ARRAY' ) { return [ map { o2h(@args, $_) } @$h2o ] } return $h2o; } 1; __END__ =head1 Cookbook =head2 Keys with Spaces, Dashes, or Other Non-Identifier Characters If the hash you want to pass to C contains keys that are not usable as method names, such as keys containing spaces or dashes, you can transform the hash before passing it to C. There are several ways to achieve this, including in plain Perl, but one of the easier ways is with C from the core module L. use List::Util 'pairmap'; my $hash = { "foo bar" => 123, "quz-ba%z" => 456 }; my $obj = h2o { pairmap { $a=~tr/a-zA-Z0-9/_/c; ($a,$b) } %$hash }; print $obj->foo_bar, $obj->quz_ba_z, "\n"; # prints "123456" =head2 Using with Config::Tiny One common use case for this module is to make accessing hashes nicer, like for example those you get from L. Here's how you can create a new C object from a configuration file: use Util::H2O 0.24 qw/ h2o o2h /; # v0.24 for o2h (with bugfixes) use Config::Tiny 2.27; # v2.27 for writing file back out my $config = h2o -recurse, {%{ Config::Tiny->read($config_filename) }}; say $config->foo->bar; # prints the value of "bar" in section "[foo]" $config->foo->bar("Hello, World!"); # change value # write file back out Config::Tiny->new(o2h $config)->write($config_filename); =head2 Debugging Because the packages generated by C are dynamic, note that any debugging dumps of these objects will be somewhat incomplete because they won't show the methods. However, if you'd like somewhat nicer looking dumps of the I contained in the objects, one way you can do that is with L: use Util::H2O; use Data::Dump qw/dd/; use Data::Dump::Filtered qw/add_dump_filter/; add_dump_filter( sub { my ($ctx, $obj) = @_; return { bless=>'', comment=>'Util::H2O::h2o()' } if $ctx->class=~/^Util::H2O::/; return undef; # normal Data::Dump processing for all other objects }); my $x = h2o -recurse, { foo => "bar", quz => { abc => 123 } }; dd $x; Outputs: # Util::H2O::h2o() { foo => "bar", quz => # Util::H2O::h2o() { abc => 123 }, } =head2 An Autoloading Example If you wanted to create a class where (almost!) every method call is automatically translated to a hash access of the corresponding key, here's how you could do that: h2o -classify=>'HashLikeObj', -nolock, { AUTOLOAD => sub { my $self = shift; our $AUTOLOAD; ( my $key = $AUTOLOAD ) =~ s/.*:://; $self->{$key} = shift if @_; return $self->{$key}; } }; =head2 Upgrading to Moo Let's say you've used this module to whip up two simple classes: h2o -classify => 'My::Class', {}, qw/ foo bar details /; h2o -classify => 'My::Class::Details', {}, qw/ a b /; But now you need more features and would like to upgrade to an actual OO system like L. Here's how you'd write the above code using that, with some L thrown in: package My::Class2 { use Moo; use Types::Standard qw/ InstanceOf /; use namespace::clean; # optional but recommended has foo => (is=>'rw'); has bar => (is=>'rw'); has details => (is=>'rw', isa=>InstanceOf['My::Class2::Details']); } package My::Class2::Details { use Moo; use namespace::clean; has a => (is=>'rw'); has b => (is=>'rw'); } =head1 See Also Inspired in part by C from L. Many, many other modules exist to simplify object creation in Perl. This one is mine C<;-P> Similar modules include L, L, L, L, and L, the latter of which also contains a comprehensive list of similar modules. Also, see L for another minimalistic class generation module. For real OO work, I like L and L (see L). Further modules that might be useful in combination with this one: L for merging hashes before using this module (for example, to supply default values for keys); L for applying roles. See also L by OODLER, a module with additional functionality on top of this module. =head1 Special Thanks Thanks to oodler577 on GitHub (OODLER on CPAN), whose many suggestions have inspired a lot of the features in this module! =head1 Author, Copyright, and License Copyright (c) 2020-2023 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 Util-H2O-0.24/Makefile.PL0000644000175000017500000000233514536327431014263 0ustar haukexhaukex#!/usr/bin/env perl use ExtUtils::MakeMaker 6.52; WriteMakefile( NAME => 'Util::H2O', AUTHOR => 'Hauke D ', LICENSE => 'perl_5', VERSION_FROM => 'lib/Util/H2O.pm', ABSTRACT_FROM => 'lib/Util/H2O.pm', MIN_PERL_VERSION => '5.6.0', META_MERGE => { 'meta-spec' => { version => 2 }, provides => { 'Util::H2O' => { file => 'lib/Util/H2O.pm', version => '0.24', }, }, resources => { homepage => 'https://github.com/haukex/Util-H2O', repository => { type => 'git', url => 'https://github.com/haukex/Util-H2O.git', web => 'https://github.com/haukex/Util-H2O', }, bugtracker => { web => 'https://github.com/haukex/Util-H2O/issues', }, }, }, CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => '6.64', }, PREREQ_PM => { 'Carp' => 0, 'Exporter' => '5.58', 'Symbol' => 0, ( $] ge '5.008009' ? ( 'Hash::Util' => '0.06', ):()), }, TEST_REQUIRES => { 'Test::More' => '1.302096', 'Scalar::Util' => 0, }, ); sub MY::postamble { return <<'MAKE_FRAG'; .PHONY: authorcover authorcover: test cpanm Devel::Cover cover -test MAKE_FRAG } Util-H2O-0.24/Changes0000644000175000017500000000455514536332712013610 0ustar haukexhaukexRevision history for Perl extension Util::H2O. 0.24 Wed, Dec 13 2023 - fix a bug where o2h would die on scalars that looked like options (Thanks @oodler577!) 0.22 Sat, Jan 28 2023 commit d8d5d8b2acc0f6518c7e09b26df0ea486d118006 - fix a bug where -arrays was not passed into hashes of hashes 0.20 Sat, Jan 14 2023 commit 9d67f1da9c63f5d5d7de34ceebf0a4d5f8fc68c1 - added "-arrays" option to h2o and o2h - documentation updates 0.18 Sun, May 1 2022 commit d2e49333cde8aa4e3a05d4f457b5b5e66781d6c9 - added "o2h" function - added "-pass" option - updated tests, Cookbook, and other documentation 0.16 Sun, Oct 17 2021 commit 99b3152f5617bfe9bf1b86bc4d4ce798ac21f11c - allowed "-classify" into current package - added "Cookbook" to documentation 0.14 Mon, Aug 2 2021 commit 6c8da85d981bff4c3d462956fa68b5b632f5665c - WARNING: Potentially Incompatible Changes: - limited conditions under which a key DESTROY is allowed - added the "-destroy" option - added the "-isa" option 0.12 Mon, Jul 19 2021 commit 15fa3f951855185e0fc41d6db88fe3384cbd84a6 - added the "-ro" option for immutable objects/hashes - WARNING: Potentially Incompatible Changes: - the constructor generated by the "-new" option now locks the new object's keyset (unless "-lock" is disabled) - the "-recurse" option now passes down the value of the "-lock" option to nested hashes in addition to the new "-ro" - documented AUTOLOAD and added tests - module now issues a warning that hashes can't be locked on old Perls 0.10 Mon, Jun 1 2020 commit 6db2a1d4cdf1a82ad2efe00f402a9596fa14cbfa - added "-classify" option - added "-nolock" option 0.08 Sat, May 23 2020 commit da41ca7d38dc99254a9aeabe0aaab1b4a94585ac - WARNING: Potentially Incompatible Changes: - methods created with "-meth" are removed from the hash by default - minor doc updates 0.06 Sun, May 17 2020 commit 8ef1cd7fe1c003b02f121927bb1ff297a8e69aad - WARNING: Potentially Incompatible Changes: - added "-lock" option and made it the default (locks hash's keyset) 0.04 Sun, May 17 2020 commit d47e94d0c0f36b88e948adf9215f7d92c836d60c - added "-clean" and "-new" options 0.02 Sat, May 16 2020 commit bf7a809de7079ef72ec14170e091a356d3d432ca - added "-class" option - improved docs - fix "redefined" warnings on duplicate @additional_keys 0.01 Sat, May 16 2020 commit 7eb1833b10a40eb4f1f6fa5a60a8be7c69a293d1 - first public release Util-H2O-0.24/README.md0000644000175000017500000000367114360543713013572 0ustar haukexhaukexUtil::H2O ========= This is the distribution of the Perl module [`Util::H2O`](https://metacpan.org/pod/Util::H2O). It is a Perl extension for turning hashrefs into objects with accessors for keys. Please see the module's documentation (POD) for details (try the command `perldoc lib/Util/H2O.pm`) and the file `Changes` for version information. [![Travis CI Build Status](https://travis-ci.org/haukex/Util-H2O.svg)](https://travis-ci.org/haukex/Util-H2O) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/haukex/Util-H2O?svg=true)](https://ci.appveyor.com/project/haukex/util-h2o) [![Coverage Status](https://coveralls.io/repos/github/haukex/Util-H2O/badge.svg)](https://coveralls.io/github/haukex/Util-H2O) [![Kwalitee Score](https://cpants.cpanauthors.org/dist/Util-H2O.svg)](https://cpants.cpanauthors.org/dist/Util-H2O) [![CPAN Testers](https://badges.zero-g.net/cpantesters/Util-H2O.svg)](http://matrix.cpantesters.org/?dist=Util-H2O) Installation ------------ To install this module type the following: perl Makefile.PL make make test make install If you are running Windows, you may need to use `dmake`, `nmake`, or `gmake` instead of `make`. Dependencies ------------ Requirements: Perl v5.6 or higher (a more current version is *strongly* recommended) and several of its core modules; users of older Perls may need to upgrade some core modules. The full list of required modules can be found in the file `Makefile.PL`. This module should work on any platform supported by these modules. Author, Copyright and License ----------------------------- Copyright (c) 2020-2023 Hauke Daempfling . 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 Perl Artistic License, which should have been distributed with your copy of Perl. Try the command `perldoc perlartistic` or see Util-H2O-0.24/META.yml0000600000175000017500000000165114536334175013555 0ustar haukexhaukex--- abstract: 'Hash to Object: turns hashrefs into objects with accessors for keys' author: - 'Hauke D ' build_requires: ExtUtils::MakeMaker: '0' Scalar::Util: '0' Test::More: '1.302096' configure_requires: ExtUtils::MakeMaker: '6.64' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Util-H2O no_index: directory: - t - inc provides: Util::H2O: file: lib/Util/H2O.pm version: '0.24' requires: Carp: '0' Exporter: '5.58' Hash::Util: '0.06' Symbol: '0' perl: '5.006000' resources: bugtracker: https://github.com/haukex/Util-H2O/issues homepage: https://github.com/haukex/Util-H2O repository: https://github.com/haukex/Util-H2O.git version: '0.24' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Util-H2O-0.24/MANIFEST0000644000175000017500000000045514536334175013446 0ustar haukexhaukexChanges lib/Util/H2O.pm LICENSE.txt Makefile.PL MANIFEST This list of files README.md t/Util-H2O.t xt/author.t xt/mem.t xt/redef.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Util-H2O-0.24/META.json0000600000175000017500000000322514536334175013724 0ustar haukexhaukex{ "abstract" : "Hash to Object: turns hashrefs into objects with accessors for keys", "author" : [ "Hauke D " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Util-H2O", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "5.58", "Hash::Util" : "0.06", "Symbol" : "0", "perl" : "5.006000" } }, "test" : { "requires" : { "Scalar::Util" : "0", "Test::More" : "1.302096" } } }, "provides" : { "Util::H2O" : { "file" : "lib/Util/H2O.pm", "version" : "0.24" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/haukex/Util-H2O/issues" }, "homepage" : "https://github.com/haukex/Util-H2O", "repository" : { "type" : "git", "url" : "https://github.com/haukex/Util-H2O.git", "web" : "https://github.com/haukex/Util-H2O" } }, "version" : "0.24", "x_serialization_backend" : "JSON::PP version 2.97001" } Util-H2O-0.24/xt/0000700000175000017500000000000014536334175012732 5ustar haukexhaukexUtil-H2O-0.24/xt/mem.t0000755000175000017500000000170114121612736013701 0ustar haukexhaukex#!/usr/bin/env perl use warnings; use strict; use Test::More tests=>4; use Util::H2O; ## no critic (ProhibitBacktickOperators) my ($initial) = `ps -orss $$`=~/\bRSS\s+(\d+)\b/; for (1..1000) { my $h = { map {$_=>$_} 1..1000 } } my ($normal) = `ps -orss $$`=~/RSS\s+(\d+)/; ok $normal < $initial+1000, 'memory growth after normal hashrefs ('.($normal-$initial).'<1000)'; for (1..1000) { h2o { map {$_=>$_} 1..1000 } } my ($after) = `ps -orss $$`=~/RSS\s+(\d+)/; ok $after < $normal+2500, 'memory growth after h2o hashrefs ('.($after-$normal).'<2500)'; for (1..1000) { h2o(-meth, { map {$_=>sub{$_}} 1..1000 })->$_ } my ($after2) = `ps -orss $$`=~/RSS\s+(\d+)/; ok $after2 < $after+500, 'memory growth after h2o with methods ('.($after2-$after).'<500)'; for (1..100) { h2o -class=>"XYZ$_", { map {$_=>$_} 1..1000 } } my ($big) = `ps -orss $$`=~/RSS\s+(\d+)/; ok $big > $after2+40_000, 'memory growth after not cleaning ('.$big.'>'.($after2+40_000).')'; Util-H2O-0.24/xt/author.t0000755000175000017500000001766314360543720014444 0ustar haukexhaukex#!/usr/bin/env perl use warnings; use strict; =head1 Synopsis Author tests for the Perl module L. =head1 Author, Copyright, and License Copyright (c) 2020-2023 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 FindBin (); use File::Spec::Functions qw/ updir catfile abs2rel catdir /; use File::Glob 'bsd_glob'; our ($BASEDIR,@PERLFILES); BEGIN { $BASEDIR = catdir($FindBin::Bin,updir); @PERLFILES = ( catfile($BASEDIR,qw/ lib Util H2O.pm /), bsd_glob("$BASEDIR/{t,xt}/*.{t,pm}"), ); } use Test::More tests => 3*@PERLFILES + 6; BEGIN { use_ok 'Util::H2O' } note explain \@PERLFILES; use File::Temp qw/tempfile/; my $critfn; BEGIN { my $fh; ($fh,$critfn) = tempfile UNLINK=>1; print $fh <<'END_CRITIC'; severity = 3 verbose = 9 [ErrorHandling::RequireCarping] severity = 4 [RegularExpressions::RequireExtendedFormatting] severity = 2 [Variables::ProhibitReusedNames] severity = 4 END_CRITIC close $fh; } use Test::Perl::Critic -profile=>$critfn; use Test::MinimumVersion; use Test::Pod; use Test::DistManifest; use Pod::Simple::SimpleTree; use Capture::Tiny qw/capture_merged/; sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping) sub warns (&) { my @w; { local $SIG{__WARN__} = sub { push @w, shift }; shift->() } @w } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn) subtest 'MANIFEST' => sub { manifest_ok() }; pod_file_ok($_) for @PERLFILES; my @tasks; for my $file (@PERLFILES) { critic_ok($file); minimum_version_ok($file, '5.006'); open my $fh, '<', $file or die "$file: $!"; ## no critic (RequireCarping) while (<$fh>) { s/\A\s+|\s+\z//g; push @tasks, [abs2rel($file,$BASEDIR), $., $_] if /TO.?DO/i; } close $fh; } subtest 'namespace::clean' => sub { plan tests=>4; # This is just a copy of the test from the main tests with namespace::clean added in. { package Yet::Another; ## no critic (ProhibitMultiplePackages) use Util::H2O; use namespace::clean; h2o -classify, { hello=>sub{"World!"} }, qw/abc/; sub test { return "<".shift->abc.">" } } my $o = new_ok 'Yet::Another', [ abc=>"def" ]; is $o->hello, "World!", 'getter'; is $o->test, "", 'method'; ok !exists &Yet::Another::h2o, 'cleaned'; }; 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. # Strangely, this same test changed its behavior in this current commit (-classify=>{...}) when in the main test file, # but when I moved the test into this test file, it changed its behavior again. This feels really buggy! # perlbrew exec perl -e 'sub Foo::DESTROY{warn"x"}my$x=bless{},"Foo";local$SIG{__WARN__}=sub{print"<<".shift().">>"};$x=undef' # Both the "local" and the "$x=undef" appear to be significant in the above. # So for now, I have moved this test to the author tests so I can use Capture::Tiny. #is grep({/foobar/} warns { like capture_merged { my $exp; my $od = h2o -destroy=>sub { is ref $_[0], $exp, 'destructor called as expected' or diag explain $_[0]; die "this warning is expected: foobar" }, {}; ## no critic (RequireCarping) $exp = ref $od; $od = undef; #}), 0, 'warning from constructor was not captured by __WARN__'; }, qr/^this warning is expected: foobar at .+/s, 'destructor error becomes warning'; }; subtest 'synopsis code' => sub { plan tests=>8; my $verbatim = getverbatim($PERLFILES[0], 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', more=>'cowbell' }, 'synopsis \$hash'; is_deeply \$struct, { hello => { perl => "world!" } }, 'synopsis \$struct'; isa_ok \$one, 'Point'; is_deeply \$one, { x=>1, y=>2 }, 'synopsis \$one'; isa_ok \$two, 'Point'; is_deeply \$two, { x=>3, y=>4 }, 'synopsis \$two'; END_CODE }, "bar\nworld!\nbeans\n0.927\n", 'output of synopsis correct'; }; subtest 'cookbook code' => sub { plan tests=>22; my $codes = getverbatim($PERLFILES[0], qr/\b(?:cookbook)\b/i); is @$codes, 7, 'verbatim block count'; my ($c_map,$c_cfg,$c_db1,$c_db2,$c_auto,$c_up1,$c_up2) = @$codes; # pairmap is capture_merged { eval "{ use warnings; use strict; $c_map\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) }, "123456\n", 'pairmap example output correct'; # Config::Tiny is capture_merged { my ($tfh, $config_filename) = tempfile(UNLINK=>1); print $tfh "[foo]\nbar=quz\n"; close $tfh; my $code2 = <<"END CODE"; eval "{$code2\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) use warnings; use strict; use feature 'say'; use Config::Tiny 2.27; $c_cfg END CODE open my $fh, '<', $config_filename or die $!; ## no critic (RequireCarping) my $cfg = do { local $/=undef; <$fh> }; close $fh; is $cfg, "[foo]\nbar=Hello, World!\n", 'config file correct'; }, "quz\n", 'config output correct'; # test statement in docs about nested hashes my $config = Config::Tiny->new({%{ h2o -recurse, { hello => { world => "xyz" }} }}); isa_ok $config, 'Config::Tiny'; like ref($config->{hello}), $Util::H2O::_PACKAGE_REGEX, 'nested hash as expected'; ## no critic (ProtectPrivateVars) is $config->{hello}->world, "xyz", 'call method in nested hash'; # Debugging ( my $exp1 = "$c_db2\n" ) =~ s/^\ //mg; is capture_merged { eval "{ use warnings; use strict; $c_db1\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) }, $exp1, 'debugging output correct'; # Autoloading Example is capture_merged { eval "{ use warnings; use strict; $c_auto\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) }, "", 'autoloading output empty'; my $auto = new_ok 'HashLikeObj'; is $auto->foobar, undef, 'read unknown hash key'; $auto->abc(1234); is $auto->defghi(5678), 5678, 'setter rv'; is_deeply $auto, { abc=>1234, defghi=>5678 }, 'hash as expected'; # Upgrading to Moo is capture_merged { eval "{ use warnings; use strict; $c_up1\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) }, "", 'upgrading output 1 empty'; my $x = new_ok "My::Class", [ foo=>"bar", details => new_ok "My::Class::Details", [ a=>123, b=>456 ] ]; is_deeply $x, { foo=>"bar", details=>{a=>123,b=>456} }, 'data structure 1 is correct'; is capture_merged { eval "{ use warnings; use strict; $c_up2\n;1}" or die $@; ## no critic (ProhibitStringyEval, RequireCarping) }, "", 'upgrading output 2 empty'; my $y = new_ok "My::Class2", [ foo=>"bar", details => new_ok "My::Class2::Details", [ a=>123, b=>456 ] ]; is_deeply $y, { foo=>"bar", details=>{a=>123,b=>456} }, 'data structure 2 is correct'; ok exception { My::Class2->new( foo=>"bar", details=>My::Class::Details->new(a=>444,b=>555) ) }, 'type checking works'; }; diag "To-","Do Report: ", 0+@tasks, " To-","Dos found"; diag "### TO","DOs ###" if @tasks; diag "$$_[0]:$$_[1]: $$_[2]" for @tasks; diag "### ###" if @tasks; diag "To run coverage tests:\nperl Makefile.PL && make authorcover && firefox cover_db/coverage.html\n" . "rm -rf cover_db && make distclean && git clean -dxn"; sub getverbatim { my ($file,$regex) = @_; my $tree = Pod::Simple::SimpleTree->new->parse_file($file)->root; my ($curhead,@v); for my $e (@$tree) { next unless ref $e eq 'ARRAY'; if (defined $curhead) { if ($e->[0]=~/^\Q$curhead\E/) { $curhead = undef } elsif ($e->[0] eq 'Verbatim') { push @v, $e->[2] } } elsif ($e->[0]=~/^head\d\b/ && $e->[2]=~$regex) { $curhead = $e->[0] } } return \@v; } Util-H2O-0.24/xt/redef.t0000755000175000017500000000276114365171414014222 0ustar haukexhaukex#!/usr/bin/env perl use warnings; use strict; use Test::More; use Util::H2O; # trying to figure out the "redefine" CPAN Testers failures # https://www.cpantesters.org/distro/U/Util-H2O.html?oncpan=1&distmat=1&version=0.18&grade=3 # https://www.cpantesters.org/distro/U/Util-H2O.html?oncpan=1&distmat=1&version=0.20&grade=3 # 'Subroutine Util::H2O::_7f53e778fd48::DESTROY redefined at /home/cpan/pit/bare/conf/perl-5.22.0/.cpanplus/5.22.0/build/5VoT4ISXn_/Util-H2O-0.20/blib/lib/Util/H2O.pm line 440.' # https://github.com/haukex/Util-H2O/issues/17 # I suspect it was the fact that the `h2o -clean=>0, -meth, { DESTROY=>sub{} }` # test was running before the "redefine" test. # The following test code shows the failure on Perls 5.22 and up, # at least on my machine; on CPAN Testers there were also some failures on 5.20 # I added some delete_package calls to the tests to see if that helps. #use warnings FATAL=>'redefine'; sub warns (&) { my @w; { local $SIG{__WARN__} = sub { push @w, shift }; shift->() } @w } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn) my %packs; my @w = warns { for (1..100) { my $o = h2o -clean=>0, -meth, { DESTROY=>sub{} }; $packs{ref $o}++; } for (1..100) { my $o = h2o -clean=>1, {}; #print "Reused ",ref $o,"\n" if exists $packs{ref $o}; $packs{ref $o}++; } }; delete @packs{ grep {$packs{$_}<2} keys %packs }; note explain \%packs, \@w; ok grep { /redefined/i } @w, 'I was able to reproduce the warning' or diag explain \%packs, \@w; done_testing; Util-H2O-0.24/t/0000700000175000017500000000000014536334175012542 5ustar haukexhaukexUtil-H2O-0.24/t/Util-H2O.t0000755000175000017500000004744614536334072014262 0ustar haukexhaukex#!/usr/bin/env perl use warnings; use strict; =head1 Synopsis Tests for the Perl module L. =head1 Author, Copyright, and License Copyright (c) 2020-2023 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 tests => 343; use Scalar::Util qw/blessed/; use Symbol qw/delete_package/; sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping) 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 { use_ok 'Util::H2O' } is $Util::H2O::VERSION, '0.24'; diag "If all tests pass, you can ignore the \"this Perl is too old\" warnings" if $] lt '5.008009'; my $PACKRE = $Util::H2O::_PACKAGE_REGEX; ## no critic (ProtectPrivateVars) { my $hash = { foo => "bar", x => "y" }; my $o1 = h2o $hash, qw/ more keys /; is $o1, $hash; like blessed($o1), $PACKRE; is $o1->foo, 'bar'; is $o1->x, 'y'; ok exception { $o1->blah }; is $o1->x("z"), 'z'; is $o1->x, 'z'; is $o1->more, undef; is $o1->keys, undef; is $o1->more("quz"), 'quz'; is $o1->more, 'quz'; is_deeply $hash, { foo=>'bar', x=>'z', more=>'quz' }; is $o1->keys(undef), undef; is_deeply $hash, { foo=>'bar', x=>'z', more=>'quz', keys=>undef }; } { my $o2 = { hello => { perl => "world!" }, x=>{y=>{z=>"foo"}} }; h2o -recurse, $o2; is $o2->hello->perl, "world!"; is $o2->x->y->z, "foo"; like blessed($o2->x), $PACKRE; like blessed($o2->x->y), $PACKRE; note explain $o2; } # -recurse { my $o3 = h2o -recurse, { foo => { bar => "quz" } }, 'xyz'; is $o3->xyz, undef; is $o3->foo->bar, 'quz'; ok exception { $o3->foo->xyz }; } { my $code = sub {}; my $o4 = h2o { a=>[], h=>{}, c=>$code, a2=>[ {x=>'y'} ] }; is ref $o4->a, 'ARRAY'; is ref $o4->h, 'HASH'; is ref $o4->c, 'CODE'; is ref $o4->a2, 'ARRAY'; is ref $o4->a2->[0], 'HASH'; is $o4->a2->[0]{x}, 'y'; is $o4->c, $code; } { my $o = h2o -recurse, { foo => { bar => "quz" } }; SKIP: { skip "Won't work on old Perls", 2 if $] lt '5.008009'; ok exception { $o->{abc} = 123 }; ok exception { $o->foo->{def} = 456 }; } my $o2 = h2o -recurse, -nolock, { foo => { bar => "quz" } }; $o2->{abc} = 123; $o2->foo->{def} = 456; is_deeply [sort keys %$o2], [qw/ abc foo /]; is_deeply [sort keys %{$o2->foo}], [qw/ bar def /]; } # -arrays { my $o1 = h2o -arrays, { foo => { bar => "quz" }, hello => [ { abc=>"def" }, { ghi=>{ jkl=>"mno" } } ] }; is $o1->foo->bar, 'quz'; is ref $o1->hello, 'ARRAY'; is $o1->hello->[0]->abc, 'def'; is $o1->hello->[1]->ghi->jkl, 'mno'; my $o2 = h2o -arrays, { a=>[ { b=>[ [ 'c', { d=>{ e=>[ { f=>'g' } ] } } ] ] } ] }; is $o2->a->[0]->b->[0][0], 'c'; is $o2->a->[0]->b->[0][1]->d->e->[0]->f, 'g'; my $o3 = h2o -arrays, [ { foo=>'bar' }, { quz=>'baz' }, ]; is $o3->[0]->foo, 'bar'; is $o3->[1]->quz, 'baz'; } # -arrays with various ref types { my $sref = \"foo"; my $obj = bless { foo=>['hello', {bar=>'world'}] }, "SomeClass"; my $aref = [ { xyz=>'abc', obj=>$obj }, $obj ]; my $o1 = h2o -arrays, { sref => $sref, aref => $aref, oref => $obj, }; like blessed($o1), $PACKRE; is 0+$o1->sref, 0+$sref; is $o1->aref, $aref; like blessed($o1->aref->[0]), $PACKRE; is $o1->aref->[0]->obj, $obj; is $o1->aref->[1], $obj; is ref $o1->oref->{foo}, 'ARRAY'; is ref $o1->oref->{foo}[1], 'HASH'; } # -arrays + -pass { my $obj = bless {}, "SomeClass"; my $aref = [ { xyz=>'abc' }, $obj ]; my $o = h2o(-arrays, -pass=>'ref', $aref); is 0+$o, 0+$aref; is $o->[0]->xyz, 'abc'; is ref $o->[1], 'SomeClass'; } # -arrays + -lock + -ro { my $o = h2o -arrays, -lock=>1, -ro, { abc => [ { def => 'ghi' } ] }; SKIP: { skip "Won't work on old Perls", 2 if $] lt '5.008009'; ok exception { my $x = $o->{zzz} }; ok exception { my $y = $o->{abc}[0]{def}{yyy} }; } is $o->abc->[0]->def, 'ghi'; ok exception { $o->abc(123) }; ok exception { $o->abc->[0]->def(123) }; push @{ $o->abc }, { xyz => 777 }; is $o->abc->[1]{xyz}, 777; } # o2h { BEGIN { use_ok 'Util::H2O', 'o2h' } my $o = h2o -recurse, { a=>[ h2o {abc=>123} ], h=>{ x=>'y', z=>undef }, c=>sub {} }; like blessed($o), $PACKRE; like blessed($o->h), $PACKRE; is $o->h->x, 'y'; is $o->a->[0]->abc, 123; $o->h->z({ foo => h2o {def=>456} }); is ref $o->h->z, 'HASH'; is $o->h->z->{foo}->def, 456; my $h = o2h $o; is ref $h, 'HASH'; is ref $h->{a}, 'ARRAY'; like blessed($h->{a}[0]), $PACKRE; is ref $h->{h}, 'HASH'; is ref $h->{h}{z}, 'HASH'; like blessed($h->{h}{z}{foo}), $PACKRE; is $h->{h}{z}{foo}->def, 456; is ref $h->{c}, 'CODE'; is $h->{h}{x}, 'y'; # values that look like options my $o2 = h2o { foo => -bar, x => -arrays, y=>'z' }; is $o2->foo, '-bar'; my $h2 = o2h $o2; is ref $h2, 'HASH'; is_deeply $h2, { foo => '-bar', x => '-arrays', y=>'z' }; my $h3 = o2h -arrays, [ '--', 47 ]; is ref $h3, 'ARRAY'; is_deeply $h3, [ '--', 47 ]; is o2h(42), 42; is o2h(0), 0; # coverage ok exception { o2h(-42) }; is o2h('--', -42), -42; is o2h('--'), '--'; ok exception { o2h('-arrays', '--') }; } # o2h + -lock + -ro { my $o = h2o -recurse, -lock=>1, -ro, { abc => { def => { ghi => 555 } } }; SKIP: { skip "Won't work on old Perls", 2 if $] lt '5.008009'; ok exception { my $x = $o->{zzz} }; ok exception { my $y = $o->{abc}{def}{yyy} }; } my $h = o2h $o; is ref $h, 'HASH'; is ref $h->{abc}{def}, 'HASH'; $h->{zzz} = 543; $h->{abc}{def}{ghi} = 777; is_deeply $h, { abc => { def => { ghi => 777 } }, zzz => 543 }; } # o2h + -meth { my $o = h2o -meth, { foo => "bar", quz => sub { "baz" } }; is $o->foo, "bar"; is $o->quz, "baz"; my $h = o2h $o; is_deeply $h, { foo => "bar" }; } # o2h + -arrays { my @x = ( { foo => { bar => "quz" }, hello => [ { abc=>"def" }, { ghi=>{ jkl=>"mno" } } ] }, { a=>[ { b=>[ [ 'c', { d=>{ e=>[ { f=>'g' } ] } } ] ] } ] }, [ { foo=>'bar' }, { quz=>'baz' }, ], ); my @in = map { h2o -arrays, $_ } @x; my @out = map { o2h -arrays, $_ } @in; is_deeply $out[$_], $x[$_] for 0..$#x; is ref $out[0]{hello}[0], 'HASH'; is 0+$in[2], 0+$x[2]; isnt 0+$out[2], 0+$x[2]; } # -meth { my $o5 = h2o -meth, { abc => 123, def => sub { $_[0]->abc(789); 456 } }; is $o5->abc, 123; is $o5->def, 456; is $o5->abc, 789; } { my $o6 = h2o -meth, -recurse, { a => { b=>"c", d=>sub{"e"} }, f=>sub{"g"} }; is $o6->a->b, 'c'; is ref $o6->a->d, 'CODE'; is $o6->f, 'g'; } { my $o = h2o -meth, { x=>111, y=>sub{222} }; is $o->x, 111; is $o->y, 222; is_deeply [sort keys %$o], [qw/ x /]; is $o->{x}, 111; SKIP: { skip "Won't work on old Perls", 1 if $] lt '5.008009'; ok exception { my $x = $o->{y} }; } } { my $o = h2o -meth, { x=>111, y=>sub{222} }, qw/y/; is $o->x, 111; is $o->y, 222; is_deeply [sort keys %$o], [qw/ x /]; $o->{y} = 333; is_deeply $o, { x=>111, y=>333 }; is $o->y, 222; } { my $h = { foo => 123, bar => sub {} }; h2o -meth, $h; is_deeply $h, { foo => 123 }; } # -class { my $dest=0; my $o7 = h2o -class=>'Foo::Bar', -meth, { ijk=>'nop', rst => sub { $_[0]->ijk('wxy'); 'efg' }, DESTROY=>sub{$dest++} }; isa_ok $o7, 'Foo::Bar'; is $o7->ijk, 'nop'; is $o7->rst, 'efg'; is $o7->ijk, 'wxy'; is $dest, 0; $o7 = undef; is $dest, 1; my $o7a = bless {}, 'Foo::Bar'; is $o7a->ijk, undef; is $o7a->rst, 'efg'; is $o7a->ijk, 'wxy'; } # -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" } } { package IsaTest3; ## no critic (ProhibitMultiplePackages) our @ISA = ('IsaTest2'); ## no critic (ProhibitExplicitISA) sub bar { return "bar" } } { package IsaTest5; ## no critic (ProhibitMultiplePackages) sub quz { return "quz" } } my $o1 = h2o {}; is_deeply get_isa($o1), []; h2o -class=>'IsaTest1', {}; is_deeply \@IsaTest1::ISA, []; my $o2 = h2o -isa=>'IsaTest2', {}; is_deeply get_isa($o2), ['IsaTest2']; isa_ok $o2, 'IsaTest2'; ok $o2->can("foo"); is $o2->foo, "foo"; h2o -classify=>'IsaTest4', -isa=>'IsaTest3', { foo => sub { "Foo!" } }; my $o3 = IsaTest4->new(); isa_ok $o3, 'IsaTest4'; isa_ok $o3, 'IsaTest3'; isa_ok $o3, 'IsaTest2'; is_deeply \@IsaTest4::ISA, ['IsaTest3']; is $o3->bar, "bar"; is $o3->foo, "Foo!"; my $o4 = h2o -isa=>['IsaTest5','IsaTest3'], {}; ok $o4->can("foo"); ok $o4->can("bar"); ok $o4->can("quz"); } # -clean sub checksym { my $s = shift; my ($p,$n) = $s=~/\A(.+::)?(\w+)\z/ or die $s; ## no critic (RequireCarping) my $t = defined $p ? do { no strict 'refs'; \%{$p} } : \%::; ## no critic (ProhibitNoStrict) return exists $t->{$n.'::'}; } { my $o = h2o {}; my $c = ref $o; ok checksym $c; $o = undef; ok !checksym $c; } { my $o = h2o -clean=>0, {}; my $c = ref $o; ok checksym $c; $o = undef; ok checksym $c; delete_package($c); ok !checksym $c; } { my $o = h2o -class=>'TestClean1', {}; my $c = ref $o; ok checksym $c; $o = undef; ok checksym $c; } { my $o = h2o -class=>'TestClean2', -clean=>1, {}; my $c = ref $o; ok checksym $c; $o = undef; ok !checksym $c; } # -new { my $o = h2o -new, {}; my $on = $o->new; isa_ok $on, ref $o; } { my $n = h2o -class=>'Quz', -new, {}, qw/ abc /; isa_ok $n, 'Quz'; my $n2 = new_ok 'Quz'; is $n2->abc, undef; my $n3 = $n2->new(abc=>444); is $n3->abc, 444; like exception { Quz->new(abc=>4,5) }, qr/\bOdd\b/; like exception { Quz->new(def=>4) }, qr/\bUnknown argument\b/i; SKIP: { skip "Won't work on old Perls", 2 if $] lt '5.008009'; ok exception { my $x = $n->{new} }; ok exception { my $x = $n->{DESTROY} }; } } { my $o = h2o -meth, -new, { x=>111, y=>sub{222} }, qw/y/; my $n = $o->new( x=>333, y=>444 ); is_deeply $n, { x=>333, y=>444 }; is $n->y, 222; is $n->{y}, 444; my $n2 = $o->new( y=>sub{555} ); is $n2->x, undef; is $n2->y, 222; is $n2->{y}->(), 555; } # -classify { my $o = h2o -classify=>'Quz::Baz', { abc => 123, def => sub { $_[0]->abc(789); 456 } }; is $o->abc, 123; is $o->def, 456; is $o->abc, 789; my $n = new_ok 'Quz::Baz'; is $n->abc, undef; is $n->def, 456; is $n->abc, 789; my $n2 = $o->new( abc=>333 ); is $n2->abc, 333; is $n2->def, 456; is $n2->abc, 789; } # -classify into current package { { package Yet::Another; ## no critic (ProhibitMultiplePackages) use Util::H2O; h2o -classify, { hello=>sub{"World!"} }, qw/abc/; sub test { return "<".shift->abc.">" } } my $o = new_ok 'Yet::Another', [ abc=>"def" ]; is $o->hello, "World!"; is $o->test, ""; ok exists &Yet::Another::h2o; } SKIP: { skip "Won't work on really old Perls", 2 if $] lt '5.008'; my @w = warns { my $x = h2o -clean=>1, -classify, {}; isa_ok $x, 'main'; }; is grep({/\brefusing to delete package\b/i} @w), 1; } # -lock / -nolock { my $o = h2o { foo=>123 }, qw/ bar /; is $o->{foo}, 123; is $o->{bar}, undef; is_deeply [sort keys %$o], [qw/ foo /]; $o->{bar} = 456; is $o->{bar}, 456; is_deeply [sort keys %$o], [qw/ bar foo /]; SKIP: { skip "Won't work on old Perls", 2 if $] lt '5.008009'; ok exception { my $x = $o->{quz} }; ok exception { $o->{quz} = 789 }; } } { my $o = h2o -lock=>1, { foo=>123 }, qw/ bar /; SKIP: { skip "Won't work on old Perls", 2 if $] lt '5.008009'; ok exception { my $x = $o->{quz} }; ok exception { $o->{quz} = 789 }; } } { my $o = h2o -lock=>0, { foo=>123 }, qw/ bar /; is $o->{foo}, 123; is $o->{bar}, undef; is_deeply [sort keys %$o], [qw/ foo /]; $o->{bar} = 456; is $o->{quz}, undef; is $o->{bar}, 456; is_deeply [sort keys %$o], [qw/ bar foo /]; $o->{quz} = 789; is $o->{quz}, 789; is_deeply [sort keys %$o], [qw/ bar foo quz /]; ok exception { my $x = $o->quz }; } { my $o = h2o -nolock, { foo=>123 }, qw/ bar /; is $o->{foo}, 123; is $o->{bar}, undef; is_deeply [sort keys %$o], [qw/ foo /]; $o->{bar} = 456; is $o->{quz}, undef; is $o->{bar}, 456; is_deeply [sort keys %$o], [qw/ bar foo /]; $o->{quz} = 789; is $o->{quz}, 789; is_deeply [sort keys %$o], [qw/ bar foo quz /]; ok exception { my $x = $o->quz }; } { h2o -class=>'Baz', -new, {}, qw/ abc /; my $n = Baz->new(abc=>123); if ($] lt '5.008009') { $n->{def} = 456; is_deeply [sort keys %$n], [qw/ abc def /]; pass 'dummy'; # so the number of tests still fits } else { ok exception { $n->{def} = 456 }; is_deeply [sort keys %$n], [qw/ abc /]; } } { h2o -class=>'Baz2', -new, -nolock, {}, qw/ abc /; my $n = Baz2->new(abc=>123); $n->{def} = 456; is_deeply [sort keys %$n], [qw/ abc def /]; } # -ro SKIP: { skip "Won't work on old Perls", 36 if $] lt '5.008009'; my $o = h2o -ro, { foo=>123, bar=>undef }; is $o->foo, 123; is $o->bar, undef; ok exception { $o->foo(456) }; ok exception { $o->bar(789) }; ok exception { $o->{foo} = 456 }; ok exception { $o->{bar} = 789 }; ok exception { $o->{quz} = 111 }; is $o->foo, 123; is $o->bar, undef; is_deeply [sort keys %$o], [qw/ bar foo /]; my $or = h2o -ro, -recurse, { foo => { bar => 'quz' } }; ok exception { $or->foo(123) }; ok exception { $or->foo->bar(456) }; ok exception { $or->{foo} = 123 }; ok exception { $or->{foo}{bar} = 456 }; ok exception { $or->foo->{bar} = 456 }; my $on = h2o -ro, -new, {}, qw/foo bar/; ok exception { $on->{foo} = 'x' }; ok exception { $on->{bar} = 'y' }; ok exception { $on->foo("x") }; is_deeply [%$on], []; is $on->foo, undef; is $on->bar, undef; my $onn = $on->new(foo=>'quz'); isa_ok $onn, ref $on; ok exception { $onn->{foo} = 'x' }; ok exception { $onn->{bar} = 'y' }; ok exception { $onn->foo("x") }; is_deeply [%$onn], [ foo=>'quz' ]; is $onn->foo, 'quz'; is $onn->bar, undef; h2o -classify=>'ReadOnlyFoo', -ro, { add => sub { $_[0]->x + $_[0]->y }, }, qw/ x y /; my $x = ReadOnlyFoo->new(x=>123, y=>456); is $x->add, 579; ok exception { $x->x(111) }; ok exception { $x->y(222) }; ok exception { $x->{x}=111 }; ok exception { $x->{y}=222 }; is $x->add, 579; ok exception { h2o -ro, { foo=>123 }, qw/ bar / }; ok exception { h2o -ro, -nolock, { foo=>123 } }; } # -destroy { my $dest=0; my $o1 = h2o -destroy=>sub{$dest++}, {}; is $dest, 0; $o1=undef; is $dest, 1; my $o2 = h2o -new, -destroy=>sub{$dest++}, {}; is $dest, 1; $o2->new; is $dest, 2; h2o -classify=>'DestTest', -destroy=>sub{ isa_ok shift, 'DestTest'; $dest++; }, {}; # note this object is immediately DESTROYed is $dest, 3; my $o3 = DestTest->new(); is $dest, 3; $o3=undef; is $dest, 4; # This is here just for code coverage, the test for destructor errors being converted # to warnings that used to be here was buggy and moved to the author tests for now. my $od = h2o -destroy=>sub { die "You can safely ignore this warning during testing,\neven if it is followed by another \" at t/Util-H2O.t line ...\"." }, {}; ## no critic (RequireCarping) } { # -destroy + -isa my $superdest = 0; { package DestIsaTest; ## no critic (ProhibitMultiplePackages) sub DESTROY { $superdest++; return } } my $dest = 0; my $o1 = h2o -isa=>'DestIsaTest', -destroy=>sub{$dest++}, {}; is $dest, 0; is $superdest, 0; $o1=undef; is $dest, 1; is $superdest, 0; my $dest2 = 0; h2o -isa=>'DestIsaTest', -classify=>'DestIsaH2O', { DESTROY=>sub{$dest2++} }; is $dest2, 1; is $superdest, 0; { package DestIsaH2O2; ## no critic (ProhibitMultiplePackages) use Util::H2O; h2o -isa=>'DestIsaTest', -classify, { DESTROY=>sub{ my $self=shift; $dest2++; $self->SUPER::DESTROY(@_) } }; } is $dest2, 2; is $superdest, 1; } # DESTROY { ok h2o -class=>'DestroyTest1', -meth, { DESTROY=>sub{} }; # make sure to clean up after ourselves! ok my $o = h2o -clean=>0, -meth, { DESTROY=>sub{} }; my $c = ref $o; undef $o; delete_package($c); ok !checksym($c); ok exception { h2o -class=>'DestroyTest2', -clean=>1, -meth, { DESTROY=>sub{} } }; ok exception { h2o -class=>'DestroyTest3', -meth, { DESTROY=>'' } }; ok exception { h2o -class=>'DestroyTest4', -meth, { DESTROY=>undef } }; ok exception { h2o -class=>'DestroyTest5', { DESTROY=>sub{} } }; ok exception { h2o -class=>'DestroyTest6', -meth, destroy=>sub{}, { DESTROY=>sub{} } }; ok exception { h2o -clean=>0, -meth, { DESTROY=>'' } }; ok exception { h2o -clean=>0, -meth, { DESTROY=>undef } }; ok exception { h2o -clean=>0, { DESTROY=>sub{} } }; ok exception { h2o -clean=>0, -meth, -destroy=>sub{}, { DESTROY=>sub{} } }; ok exception { h2o -meth, { DESTROY=>sub{} } }; ok exception { h2o { DESTROY=>sub{} } }; ok exception { h2o { DESTROY=>undef } }; } # plain AUTOLOAD { my $o = h2o { AUTOLOAD => 123, baz => 789 }, 'abc'; ## no critic (ProhibitCommaSeparatedStatements) is $o->AUTOLOAD, 123; is $o->foo, 123; is $o->bar(456), 456; is $o->quz, 456; is $o->baz, 789; is $o->abc, undef; $o->abc('def'); is $o->xyz, 456; is $o->abc, 'def'; is $o->baz, 789; is $o->AUTOLOAD, 456; } # -meth with AUTOLOAD { my @auto; my $o = h2o -meth, { AUTOLOAD => sub { our $AUTOLOAD; push @auto, $AUTOLOAD, [@_]; return 'ijk'; } }, 'quz'; is $o->foo("bar"), 'ijk'; is $o->bar(), 'ijk'; is $o->quz("baz"), 'baz'; is_deeply \@auto, [ ref($o).'::foo', [ $o, "bar" ], ref($o).'::bar', [ $o ], ] or diag explain \@auto; is $o->quz, "baz"; is_deeply [keys %$o], ["quz"]; } my @redef_warns = warns { h2o { abc => "def" }, qw/ abc /; h2o {}, qw/ abc abc /; }; # There were spurious CPAN Testers failures here, see xt/redef.t for details ok !grep { /redefined/i } @redef_warns or diag explain \@redef_warns; ## no critic (ProhibitMixedBooleanOperators) SKIP: { skip "Tests only for old Perls", 4 if $] ge '5.008009'; my @w = warns { my $o1 = h2o {}; $o1->{bar} = 456; is_deeply [%$o1], [ bar=>456 ]; my $o2 = h2o -ro, { foo=>123 }; $o2->{foo} = 456; ok exception { $o2->foo(789) }; is_deeply [%$o2], [ foo=>456 ]; }; is grep({ /\btoo old\b/i } @w), 2; } { # -pass like blessed( h2o {} ), $PACKRE; like blessed( h2o -pass=>'undef', {} ), $PACKRE; # "undef" is h2o(-pass=>'undef', undef), undef; ok exception { h2o -pass=>'undef', [] }; ok exception { h2o -pass=>'undef', "foo" }; my $sref = \"foo"; my $aref = [ { xyz=>'abc' } ]; my $obj = bless {}, "SomeClass"; # "ref" like blessed( h2o -pass=>'ref', {} ), $PACKRE; is h2o(-pass=>'ref', $sref), $sref; is h2o(-pass=>'ref', $obj), $obj; is 0+h2o(-recurse, -pass=>'ref', $aref), 0+$aref; ok !blessed($aref->[0]); is ref($aref->[0]), 'HASH'; is h2o(-pass=>'ref', undef), undef; ok exception { h2o -pass=>'ref', "foo" }; ok exception { h2o -pass=>'ref', 1234 }; ok exception { h2o -pass=>'ref', -123 }; ok exception { h2o -pass=>'ref', "-foobar" }; # Note to self: I decided against implementing "any" because then # there is ambiguity when negative numbers or strings starting with # dashes look like options. ok exception { h2o -pass=>'any', {} }; } ok exception { h2o() }; ok exception { h2o("blah") }; ok exception { h2o(undef) }; ok exception { h2o([]) }; ok exception { h2o(-arrays, undef) }; ok exception { h2o(-meth,-recurse) }; ok exception { h2o(bless {}, "SomeClass") }; ok exception { h2o({DESTROY=>'foo'}) }; ok exception { h2o(-new, { new=>5 }) }; ok exception { h2o(-foobar) }; ok exception { h2o(-class) }; ok exception { h2o(-class=>'') }; ok exception { h2o(-class=>[]) }; ok exception { h2o(-classify) }; ok exception { h2o(-classify=>'') }; ok exception { h2o(-classify=>[]) }; ok exception { h2o(-destroy=>'') }; ok exception { h2o(-destroy=>undef) }; ok exception { h2o(-isa=>{}) }; ok exception { h2o -pass=>undef, {} }; ok exception { h2o -pass=>[], {} }; ok exception { h2o -pass=>"foo", {} }; ok exception { o2h(-foobar) }; ok exception { o2h(-arrays) }; ok exception { o2h(undef, undef) }; ok exception { o2h({x=>1},{y=>2}) }; diag "If all tests pass, you can ignore the \"this Perl is too old\" warnings" if $] lt '5.008009'; done_testing;