add get_or_add_package_symbol, for the vivify behavior

[gitmo/Package-Stash.git] / lib / Package / Stash.pm

diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm
index d3c3071..6396ed5 100644 (file)
--- a/lib/Package/Stash.pm
+++ b/lib/Package/Stash.pm
@@ -98,7 +98,7 @@ sub namespace {
     }
 }
 
-=head2 add_package_symbol $variable $value $filename $firstlinenum $lastlinenum
+=head2 add_package_symbol $variable $value %opts
 
 Adds a new package symbol, for the symbol given as C<$variable>, and optionally
 gives it an initial value of C<$value>. C<$variable> should be the name of
@@ -108,12 +108,16 @@ variable including the sigil, so
 
 will create C<%Foo::foo>.
 
-The optional $filename, $firstlinenum, and $lastlinenum arguments can be used
-to indicate where the symbol should be regarded as having been defined.
+Valid options (all optional) are C<filename>, C<first_line_num>, and
+C<last_line_num>.
+
+C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
+be used to indicate where the symbol should be regarded as having been defined.
 Currently these values are only used if the symbol is a subroutine ('C<&>'
-sigil) and only if C<$^P & 0x10> is true.  In which case the special
-C<%DB::sub> hash is updated to record the values of $filename, $firstlinenum,
-and $lastlinenum for the subroutine.
+sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
+hash is updated to record the values of C<filename>, C<first_line_num>, and
+C<last_line_num> for the subroutine. If these are not passed, their values are
+inferred (as much as possible) from C<caller> information.
 
 This is especially useful for debuggers and profilers, which use C<%DB::sub> to
 determine where the source code for a subroutine can be found.  See
@@ -136,7 +140,7 @@ sub _valid_for_type {
 }
 
 sub add_package_symbol {
-    my ($self, $variable, $initial_value) = @_; # extra args unpacked below
+    my ($self, $variable, $initial_value, %opts) = @_;
 
     my ($name, $sigil, $type) = ref $variable eq 'HASH'
         ? @{$variable}{qw[name sigil type]}
@@ -150,15 +154,16 @@ sub add_package_symbol {
 
         # cheap fail-fast check for PERLDBf_SUBLINE and '&'
         if ($^P and $^P & 0x10 && $sigil eq '&') {
-            my (undef, undef, undef, $filename, $firstlinenum, $lastlinenum) = @_;
+            my $filename = $opts{filename};
+            my $first_line_num = $opts{first_line_num};
 
-            (undef, $filename, $firstlinenum) = caller
+            (undef, $filename, $first_line_num) = caller
                 if not defined $filename;
-            $lastlinenum = $firstlinenum ||= 0
-                if not defined $lastlinenum;
+
+            my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 
             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
-            $DB::sub{$pkg . '::' . $name} = "$filename:$firstlinenum-$lastlinenum";
+            $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
         }
     }
 
@@ -221,7 +226,7 @@ Returns the value of the given package variable (including sigil).
 =cut
 
 sub get_package_symbol {
-    my ($self, $variable) = @_;
+    my ($self, $variable, %opts) = @_;
 
     my ($name, $sigil, $type) = ref $variable eq 'HASH'
         ? @{$variable}{qw[name sigil type]}
@@ -236,10 +241,10 @@ sub get_package_symbol {
         # accessed... in the case of @ISA, this might never happen
         # for instance, assigning like that and then calling $obj->isa
         # will fail. see t/005-isa.t
-        if ($type eq 'ARRAY' && $name ne 'ISA') {
+        if ($opts{vivify} && $type eq 'ARRAY' && $name ne 'ISA') {
             $self->add_package_symbol($variable, []);
         }
-        elsif ($type eq 'HASH') {
+        elsif ($opts{vivify} && $type eq 'HASH') {
             $self->add_package_symbol($variable, {});
         }
         else {
@@ -264,6 +269,18 @@ sub get_package_symbol {
     }
 }
 
+=head2 get_or_add_package_symbol $variable
+
+Like C<get_package_symbol>, except that it will return an empty hashref or
+arrayref if the variable doesn't exist.
+
+=cut
+
+sub get_or_add_package_symbol {
+    my $self = shift;
+    $self->get_package_symbol(@_, vivify => 1);
+}
+
 =head2 remove_package_symbol $variable
 
 Removes the package variable described by C<$variable> (which includes the