diff --git a/Changes b/Changes index 452ca37..528d031 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,10 @@ Revision history for Perl extension Util::H2O. -0.08 Sat, May 23 2020 +0.10 Mon, Jun 1 2020 + - 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 diff --git a/Makefile.PL b/Makefile.PL index 79e6124..cd45264 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -12,7 +12,7 @@ WriteMakefile( provides => { 'Util::H2O' => { file => 'lib/Util/H2O.pm', - version => '0.08', + version => '0.10', }, }, resources => { diff --git a/lib/Util/H2O.pm b/lib/Util/H2O.pm index 3c85418..9550ead 100644 --- a/lib/Util/H2O.pm +++ b/lib/Util/H2O.pm @@ -31,7 +31,7 @@ Util::H2O - Hash to Object: turns hashrefs into objects with accessors for keys } }; $obj->cool; # prints "beans" - h2o -class=>'Point',-new,-meth, { # whip up a class + 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); @@ -40,7 +40,7 @@ Util::H2O - Hash to Object: turns hashrefs into objects with accessors for keys =cut -our $VERSION = '0.08'; +our $VERSION = '0.10'; # For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file our @EXPORT = qw/ h2o /; ## no critic (ProhibitAutomaticExportation) @@ -112,6 +112,10 @@ name, you will get "redefined" warnings. Therefore, if you want to create multiple objects in the same package, you should probably use C<-new>. +=item C<< -classify => I >> + +Short form of the options C<< -new, -meth, -class => I >>. + =item C<-new> Generates a constructor named C in the package. The constructor @@ -141,6 +145,10 @@ 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. +=item C<-nolock> + +Short form of the option C<< lock=>0 >>. + =back =head3 C<$hashref> @@ -175,12 +183,19 @@ sub h2o { ## no critic (RequireArgUnpacking, ProhibitExcessComplexity) 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 '-new' ) { $new = shift } 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); + croak "invalid -classify option value" + if !defined $class || ref $class || !length $class; + $meth = 1; $new = 1; + } else { croak "unknown option to h2o: '$_[0]'" } } $clean = !defined $class unless defined $clean; diff --git a/t/Util-H2O.t b/t/Util-H2O.t index ed50f6d..1d7bdb2 100755 --- a/t/Util-H2O.t +++ b/t/Util-H2O.t @@ -20,7 +20,7 @@ L. =cut -use Test::More tests => 100; +use Test::More tests => 128; use Scalar::Util qw/blessed/; sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping) @@ -30,7 +30,7 @@ sub warns (&) { my @w; { local $SIG{__WARN__} = sub { push @w, shift }; shift->( diag "This is Perl $] at $^X on $^O"; BEGIN { use_ok 'Util::H2O' } -is $Util::H2O::VERSION, '0.08'; +is $Util::H2O::VERSION, '0.10'; my $PACKRE = qr/\AUtil::H2O::_[0-9A-Fa-f]+\z/; @@ -189,8 +189,35 @@ sub checksym { 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; +} -# -lock +# -lock / -nolock { my $o = h2o { foo=>123 }, qw/ bar /; is $o->{foo}, 123; @@ -227,6 +254,20 @@ sub checksym { 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); @@ -250,5 +291,8 @@ ok exception { h2o(-new, { new=>5 }) }; ok exception { h2o(-class) }; ok exception { h2o(-class=>'') }; ok exception { h2o(-class=>[]) }; +ok exception { h2o(-classify) }; +ok exception { h2o(-classify=>'') }; +ok exception { h2o(-classify=>[]) }; done_testing;