Implement context_info() accessors

diff --git a/MANIFEST b/MANIFEST
index 63ed67e0f15e2d034ac0734b5797c5caaa317bec..d8cad158c418b417ad8fd1d1b5672ddebb79a650 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -13,6 +13,7 @@ t/11-target.t
 t/12-actions.t
 t/13-valid.t
 t/14-cmp.t
 t/12-actions.t
 t/13-valid.t
 t/14-cmp.t

+t/15-info.t

 t/91-pod.t
 t/92-pod-coverage.t
 t/93-pod-spelling.t
 t/91-pod.t
 t/92-pod-coverage.t
 t/93-pod-spelling.t

diff --git a/lib/Scope/Context.pm b/lib/Scope/Context.pm
index 8fafca8b5a3e8ed92217088cb4f1a0c7de30ccae..aa422e1b950a8ecc682e3ff1b4863588aae82e7e 100644 (file)
--- a/lib/Scope/Context.pm
+++ b/lib/Scope/Context.pm
@@ -194,6 +194,110 @@ sub assert_valid {
  1;
 }
 
  1;
 }
 

+=head2 C<package>
+
+    $cxt->package;
+
+Returns the namespace in use when the scope denoted by the invocant begins.
+
+=head2 C<file>
+
+    $cxt->file;
+
+Returns the name of the file where the scope denoted by the invocant belongs to.
+
+=head2 C<line>
+
+    $cxt->line;
+
+Returns the line number where the scope denoted by the invocant begins.
+
+=head2 C<sub_name>
+
+    $cxt->sub_name;
+
+Returns the name of the subroutine called for this context, or C<undef> if this is not a subroutine context.
+
+=head2 C<sub_has_args>
+
+    $cxt->sub_has_args;
+
+Returns a boolean indicating whether a new instance of C<@_> was set up for this context, or C<undef> if this is not a subroutine context.
+
+=head2 C<gimme>
+
+    $cxt->gimme;
+
+Returns the context (in the sense of L<perlfunc/wantarray>) in which the scope denoted by the invocant is executed.
+
+=head2 C<eval_text>
+
+    $cxt->eval_text;
+
+Returns the contents of the string being compiled for this context, or C<undef> if this is not an eval context.
+
+=head2 C<is_require>
+
+    $cxt->is_require;
+
+Returns a boolean indicating whether this eval context was created by C<require>, or C<undef> if this is not an eval context.
+
+=head2 C<hints_bits>
+
+    $cxt->hints_bits;
+
+Returns the value of the lexical hints bit mask (available as C<$^H> at compile time) in use when the scope denoted by the invocant begins.
+
+=head2 C<warnings_bits>
+
+    $cxt->warnings_bits;
+
+Returns the bit string representing the warnings (available as C<${^WARNING_BITS}> at compile time) in use when the scope denoted by the invocant begins.
+
+=head2 C<hints_hash>
+
+    $cxt->hints_hash;
+
+Returns a reference to the lexical hints hash (available as C<%^H> at compile time) in use when the scope denoted by the invocant begins.
+This method is available only on perl 5.10 and greater.
+
+=cut
+
+BEGIN {
+ my %infos = (
+  package       => 0,
+  file          => 1,
+  line          => 2,
+  sub_name      => 3,
+  sub_has_args  => 4,
+  gimme         => 5,
+  eval_text     => 6,
+  is_require    => 7,
+  hints_bits    => 8,
+  warnings_bits => 9,
+  (hints_hash   => 10) x ("$]" >= 5.010),
+ );
+
+ for my $name (sort { $infos{$a} <=> $infos{$b} } keys %infos) {
+  my $idx = $infos{$name};
+  local $@;
+  eval <<"  TEMPLATE";
+   sub $name {
+    my \$self = shift;
+
+    \$self->assert_valid;
+
+    my \$info = \$self->{info};
+    \$info = \$self->{info} = [ Scope::Upper::context_info(\$self->cxt) ]
+                                                                        unless \$info;
+
+    return \$info->[$idx];
+   }
+  TEMPLATE
+  die $@ if $@;
+ }
+}
+

 =head2 C<want>
 
     my $want = $cxt->want;
 =head2 C<want>
 
     my $want = $cxt->want;

diff --git a/t/02-can.t b/t/02-can.t
index 5af4e46100571c6a197dcaf9c969112c3a90439b..595aaacc6e7b6f5135dd04e58cfa6d33f8b84b0d 100644 (file)
--- a/t/02-can.t
+++ b/t/02-can.t
@@ -9,13 +9,23 @@ my @methods = qw<
  new here
  cxt
  uid is_valid assert_valid
  new here
  cxt
  uid is_valid assert_valid

+
+ package file line
+ sub_name sub_has_args
+ gimme
+ eval_text is_require
+ hints_bits warnings_bits
+

  want
  up sub eval
  want
  up sub eval

+

  reap localize localize_elem localize_delete
  unwind yield
  uplevel
 >;
 
  reap localize localize_elem localize_delete
  unwind yield
  uplevel
 >;
 

+push @methods, 'hints_hash' if "$]" >= 5.010;
+

 plan tests => scalar(@methods);
 
 require Scope::Context;
 plan tests => scalar(@methods);
 
 require Scope::Context;

diff --git a/t/15-info.t b/t/15-info.t
new file mode 100644 (file)
index 0000000..8c01137
--- /dev/null
+++ b/t/15-info.t
@@ -0,0 +1,61 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 5 + 2 + 3 + 2;
+
+use Scope::Context;
+
+{
+ package Scope::Context::TestA;
+ {
+  my $line = __LINE__;
+  package Scope::Context::TestB;
+  my $cxt  = Scope::Context->new;
+  package Scope::Context::TestC;
+  ::is $cxt->package,   'Scope::Context::TestA';
+  ::is $cxt->file,      __FILE__;
+  ::is $cxt->line,      $line;
+  ::is $cxt->sub_name,  undef;
+  ::is $cxt->eval_text, undef;
+ }
+}
+
+sub flurbz {
+ my $cxt = Scope::Context->new;
+ [ $cxt->sub_name, $cxt->sub_has_args ]
+}
+
+{
+ my $info = flurbz();
+ is($info->[0], 'main::flurbz');
+ is($info->[1], !!1);
+}
+
+{
+ {
+  is(Scope::Context->new->gimme, undef, 'gimme in void context');
+ }
+ my $s = do {
+  is(Scope::Context->new->gimme, !!'', 'gimme in scalar context');
+ };
+ my @a = do {
+  is(Scope::Context->new->gimme, !!1, 'gimme in list context');
+ }
+}
+
+{
+ my $src  = <<' SRC';
+  my $cxt = Scope::Context->new;
+  [ $cxt->eval_text, $cxt->is_require ];
+ SRC
+ my $info = do {
+  local $@;
+  eval $src;
+ };
+ my $eval_text = $info->[0];
+ s/[\s;]*$//g for $eval_text, $src;
+ is $eval_text, $src, 'eval_text in eval';
+ is $info->[1], !!'', 'is_require in eval';
+}