Added "-lock" option and made it the default

This is a change that creates a potential incompatibility with earlier
versions, but since this module is less than two days old the impact
should be minimal.

Changes

@@ -1,5 +1,9 @@
 Revision history for Perl extension Util::H2O.
 
+0.06	Sun, May 17 2020
+	- 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
 

Makefile.PL

@@ -12,7 +12,7 @@ WriteMakefile(
 		provides => {
 			'Util::H2O' => {
 				file => 'lib/Util/H2O.pm',
-				version => '0.04',
+				version => '0.06',
 			},
 		},
 		resources => {
@@ -34,6 +34,9 @@ WriteMakefile(
 		'Carp'                   => 0,
 		'Exporter'               => '5.58',
 		'Symbol'                 => 0,
+		( $] ge '5.008009' ? (
+		    'Hash::Util'         => '0.06',
+		):()),
 	},
 	TEST_REQUIRES => {
 		'Test::More'             => '1.302096',

lib/Util/H2O.pm

@@ -40,18 +40,34 @@ Util::H2O - Hash to Object: turns hashrefs into objects with accessors for keys
 
 =cut
 
-our $VERSION = '0.04';
+our $VERSION = '0.06';
 # For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file
 
 our @EXPORT = qw/ h2o /;  ## no critic (ProhibitAutomaticExportation)
 
+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('lock_ref_keys') }
+	else { *lock_ref_keys = sub {} }  # 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<keys %$hash>, 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<h2o I<@opts>, I<$hashref>, I<@additional_keys>>
@@ -91,8 +107,9 @@ C<-new>.
 Generates a constructor named C<new> 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 or other validation, you should
-probably switch to something like L<Moo> instead.
+features, like required arguments, validation, or other
+initialization, you should probably switch to something like L<Moo>
+instead.
 
 =item C<< -clean => I<bool> >>
 
@@ -101,15 +118,31 @@ destroyed. Defaults to I<false> when C<-class> is specified, I<true>
 otherwise. If this is I<false>, be aware that the packages will stay
 in Perl's symbol table and use memory accordingly.
 
+=item C<< -lock => I<bool> >>
+
+Whether or not to use L<Hash::Util>'s C<lock_ref_keys> to prevent
+modifications to the hash's keyset. Defaults to I<true> (versions of
+this module before v0.06 did not lock the keyset).
+
+Keysets of objects created by the constructor generated by the
+C<-new> option are I<not> locked.
+
+Note that on really old Perls, that is, before Perl v5.8.9,
+L<Hash::Util> and its C<lock_ref_keys> are not available, so the hash
+is never locked on those versions of Perl.
+
 =back
 
 =head3 C<$hashref>
 
 You must supply a plain (unblessed) hash reference here. Be aware
 that this function I<does> modify the original hashref(s) by blessing
-it. An accessor will be set up for each key in the hash; note that
-the keys must of course be valid Perl identifiers for you to be able
-to call the method normally.
+it and locking its keyset (the latter can be disabled with the
+C<-lock> option).
+
+An accessor will be set up for each key in the hash; note that the
+keys must of course be valid Perl identifiers for you to be able to
+call the method normally.
 
 When C<-clean> is I<true> (the default, unless you use C<-class>),
 the hash may not contain a key named C<DESTROY>. When C<-new> is
@@ -126,11 +159,12 @@ The (now blessed) C<$hashref>.
 =cut
 
 sub h2o {  ## no critic (RequireArgUnpacking, ProhibitExcessComplexity)
-	my ($recurse,$meth,$class,$new,$clean);
+	my ($recurse,$meth,$class,$new,$clean,$lock);
 	while ( @_ && $_[0] && !ref$_[0] ) {
 		if ($_[0] eq '-recurse' ) { $recurse = shift }  ## no critic (ProhibitCascadingIfElse)
 		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 '-new'  ) { $new     = shift }
 		elsif ($_[0] eq '-class') {
 			$class = (shift, shift);
@@ -140,6 +174,7 @@ sub h2o {  ## no critic (RequireArgUnpacking, ProhibitExcessComplexity)
 		else { croak "unknown option to h2o: '$_[0]'" }
 	}
 	$clean = !defined $class unless defined $clean;
+	$lock = 1 unless defined $lock;
 	my $hash = shift;
 	croak "h2o must be given a plain hashref" unless ref $hash eq 'HASH';
 	my %keys = map {$_=>1} @_, keys %$hash;
@@ -169,7 +204,9 @@ sub h2o {  ## no critic (RequireArgUnpacking, ProhibitExcessComplexity)
 		};
 		{ no strict 'refs'; *{$pack.'::new'} = $sub }  ## no critic (ProhibitNoStrict)
 	}
-	return bless $hash, $pack;
+	bless $hash, $pack;
+	lock_ref_keys $hash, keys %keys if $lock;
+	return $hash;
 }
 
 1;

t/Util-H2O.t

@@ -20,7 +20,7 @@ L<http://perldoc.perl.org/perlartistic.html>.
 
 =cut
 
-use Test::More tests => 69;
+use Test::More tests => 88;
 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.04';
+is $Util::H2O::VERSION, '0.06';
 
 my $PACKRE = qr/\AUtil::H2O::_[0-9A-Fa-f]+\z/;
 
@@ -150,6 +150,50 @@ sub checksym {
 	like exception { Quz->new(def=>4) }, qr/\bUnknown argument\b/i;
 }
 
+# -lock
+{
+	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 };
+}
+{
+	h2o -class=>'Baz', -new, {}, qw/ abc /;
+	my $n = Baz->new(abc=>123);
+	$n->{def} = 456;
+	is_deeply [sort keys %$n], [qw/ abc def /];
+}
+
 ok !grep { /redefined/i } warns {
 	h2o { abc => "def" }, qw/ abc /;
 	h2o {}, qw/ abc abc /;

xt/mem.t

@@ -16,7 +16,7 @@ ok $normal < $initial+1000, 'memory growth after normal hashrefs ('.($normal-$in
 for (1..1000) { h2o { map {$_=>$_} 1..1000 } }
 
 my ($after) = `ps -orss $$`=~/RSS\s+(\d+)/;
-ok $after < $normal+2000, 'memory growth after h2o hashrefs ('.($after-$normal).'<2000)';
+ok $after < $normal+2500, 'memory growth after h2o hashrefs ('.($after-$normal).'<2500)';
 
 for (1..1000) { h2o(-meth, { map {$_=>sub{$_}} 1..1000 })->$_ }