Added "-classify" and "-nolock" options

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

Makefile.PL

@@ -12,7 +12,7 @@ WriteMakefile(
 		provides => {
 			'Util::H2O' => {
 				file => 'lib/Util/H2O.pm',
-				version => '0.08',
+				version => '0.10',
 			},
 		},
 		resources => {

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<classname> >>
+
+Short form of the options C<< -new, -meth, -class => I<classname> >>.
+
 =item C<-new>
 
 Generates a constructor named C<new> in the package. The constructor
@@ -141,6 +145,10 @@ L<Hash::Util> and its C<lock_ref_keys> 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;

t/Util-H2O.t

@@ -20,7 +20,7 @@ L<http://perldoc.perl.org/perlartistic.html>.
 
 =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;