lib/Scope/Context.pm

   1 package Scope::Context;
   2
   3 use 5.006;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp         ();
   9 use Scalar::Util ();
  10
  11 use Scope::Upper 0.21 ();
  12
  13 =head1 NAME
  14
  15 Scope::Context - Object-oriented interface for inspecting or acting upon upper scope frames.
  16
  17 =head1 VERSION
  18
  19 Version 0.01
  20
  21 =cut
  22
  23 our $VERSION = '0.01';
  24
  25 =head1 SYNOPSIS
  26
  27     use Scope::Context;
  28
  29     for (1 .. 5) {
  30      sub {
  31       eval {
  32        # Create Scope::Context objects for different upper frames.
  33        my ($block, $sub, $eval, $loop);
  34        {
  35         $block = Scope::Context->new;
  36         $sub   = $block->sub;    # = $block->up
  37         $eval  = $block->eval;   # = $block->up(2)
  38         $loop  = $eval->up;      # = $block->up(3)
  39        }
  40
  41        eval {
  42         # This will throw an exception, since $block has expired.
  43         $block->localize('$x' => 1);
  44        };
  45
  46        # This prints "hello" when the eval block above ends.
  47        $eval->reap(sub { print "hello\n" });
  48
  49        # Ignore $SIG{__DIE__} just for the loop body.
  50        $loop->localize_delete('%SIG', '__DIE__');
  51
  52        # Execute the callback as if it ran in place of the sub.
  53        my @values = $sub->uplevel(sub {
  54         return @_, 2;
  55        }, 1);
  56
  57        # Immediately return (1, 2, 3) from the sub, bypassing the eval.
  58        $sub->unwind(@values, 3);
  59
  60        # Not reached.
  61       }
  62
  63       # Not reached.
  64      }->();
  65
  66      # unwind() returns here. "hello\n" was printed, and now
  67      # $SIG{__DIE__} is undefined.
  68     }
  69
  70 =head1 DESCRIPTION
  71
  72 This class provides an object-oriented interface to L<Scope::Upper>'s functionalities.
  73 A L<Scope::Context> object represents a currently active dynamic scope (or context), and encapsulates the corresponding L<Scope::Upper>-compatible context identifier.
  74 All of L<Scope::Upper>'s functions are then made available as methods.
  75 This gives you a prettier and safer interface when you are not reaching for extreme performance, but rest assured that the overhead of this module is minimal anyway.
  76
  77 The L<Scope::Context> methods actually do more than their subroutine counterparts from L<Scope::Upper> : before each call, the target context will be checked to ensure it is still active (which means that it is still present in the current call stack), and an exception will be thrown if you attempt to act on a context that has already expired.
  78 This means that :
  79
  80     my $cxt;
  81     {
  82      $cxt = Scope::Context->new;
  83     }
  84     $cxt->reap(sub { print "hello\n });
  85
  86 will croak when L</reap> is called.
  87
  88 =head1 METHODS
  89
  90 =head2 C<new>
  91
  92     my $cxt = Scope::Context->new;
  93     my $cxt = Scope::Context->new($scope_upper_cxt);
  94
  95 Creates a new immutable L<Scope::Context> object from the L<Scope::Upper>-comptabile context identifier C<$context>.
  96 If omitted, C<$context> defaults to the current context.
  97
  98 =cut
  99
 100 sub new {
 101  my ($self, $cxt) = @_;
 102
 103  my $class = Scalar::Util::blessed($self);
 104  unless (defined $class) {
 105   $class = defined $self ? $self : __PACKAGE__;
 106  }
 107
 108  $cxt = Scope::Upper::UP() unless defined $cxt;
 109
 110  bless {
 111   cxt => $cxt,
 112   uid => Scope::Upper::uid($cxt),
 113  }, $class;
 114 }
 115
 116 =head2 C<here>
 117
 118 A synonym for L</new>.
 119
 120 =cut
 121
 122 BEGIN {
 123  *here = \&new;
 124 }
 125
 126 sub _croak {
 127  shift;
 128  require Carp;
 129  Carp::croak(@_);
 130 }
 131
 132 =head2 C<cxt>
 133
 134     my $scope_upper_cxt = $cxt->cxt;
 135
 136 Read-only accessor to the L<Scope::Upper> context identifier associated with the invocant.
 137
 138 =head2 C<uid>
 139
 140     my $uid = $cxt->uid;
 141
 142 Read-only accessor to the L<Scope::Upper> unique identifier representing the L<Scope::Upper> context associated with the invocant.
 143
 144 =cut
 145
 146 BEGIN {
 147  local $@;
 148  eval "sub $_ { \$_[0]->{$_} }; 1" or die $@ for qw<cxt uid>;
 149 }
 150
 151 =pod
 152
 153 This class also overloads the C<==> operator, which will return true if and only if its two operands are L<Scope::Context> objects that have the same UID.
 154
 155 =cut
 156
 157 use overload (
 158  '==' => sub {
 159   my ($left, $right) = @_;
 160
 161   unless (Scalar::Util::blessed($right) and $right->isa(__PACKAGE__)) {
 162    $left->_croak('Cannot compare a Scope::Context object with something else');
 163   }
 164
 165   $left->uid eq $right->uid;
 166  },
 167  fallback => 1,
 168 );
 169
 170 =head2 C<is_valid>
 171
 172     my $is_valid = $cxt->is_valid;
 173
 174 Returns true if and only if the invocant is still valid (that is, it designates a scope that is higher on the call stack than the current scope).
 175
 176 =cut
 177
 178 sub is_valid { Scope::Upper::validate_uid($_[0]->uid) }
 179
 180 =head2 C<assert_valid>
 181
 182     $cxt->assert_valid;
 183
 184 Throws an exception if the invocant has expired and is no longer valid.
 185 Returns true otherwise.
 186
 187 =cut
 188
 189 sub assert_valid {
 190  my $self = shift;
 191
 192  $self->_croak('Context has expired') unless $self->is_valid;
 193
 194  1;
 195 }
 196
 197 =head2 C<package>
 198
 199     $cxt->package;
 200
 201 Returns the namespace in use when the scope denoted by the invocant begins.
 202
 203 =head2 C<file>
 204
 205     $cxt->file;
 206
 207 Returns the name of the file where the scope denoted by the invocant belongs to.
 208
 209 =head2 C<line>
 210
 211     $cxt->line;
 212
 213 Returns the line number where the scope denoted by the invocant begins.
 214
 215 =head2 C<sub_name>
 216
 217     $cxt->sub_name;
 218
 219 Returns the name of the subroutine called for this context, or C<undef> if this is not a subroutine context.
 220
 221 =head2 C<sub_has_args>
 222
 223     $cxt->sub_has_args;
 224
 225 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.
 226
 227 =head2 C<gimme>
 228
 229     $cxt->gimme;
 230
 231 Returns the context (in the sense of L<perlfunc/wantarray>) in which the scope denoted by the invocant is executed.
 232
 233 =head2 C<eval_text>
 234
 235     $cxt->eval_text;
 236
 237 Returns the contents of the string being compiled for this context, or C<undef> if this is not an eval context.
 238
 239 =head2 C<is_require>
 240
 241     $cxt->is_require;
 242
 243 Returns a boolean indicating whether this eval context was created by C<require>, or C<undef> if this is not an eval context.
 244
 245 =head2 C<hints_bits>
 246
 247     $cxt->hints_bits;
 248
 249 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.
 250
 251 =head2 C<warnings_bits>
 252
 253     $cxt->warnings_bits;
 254
 255 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.
 256
 257 =head2 C<hints_hash>
 258
 259     $cxt->hints_hash;
 260
 261 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.
 262 This method is available only on perl 5.10 and greater.
 263
 264 =cut
 265
 266 BEGIN {
 267  my %infos = (
 268   package       => 0,
 269   file          => 1,
 270   line          => 2,
 271   sub_name      => 3,
 272   sub_has_args  => 4,
 273   gimme         => 5,
 274   eval_text     => 6,
 275   is_require    => 7,
 276   hints_bits    => 8,
 277   warnings_bits => 9,
 278   (hints_hash   => 10) x ("$]" >= 5.010),
 279  );
 280
 281  for my $name (sort { $infos{$a} <=> $infos{$b} } keys %infos) {
 282   my $idx = $infos{$name};
 283   local $@;
 284   eval <<"  TEMPLATE";
 285    sub $name {
 286     my \$self = shift;
 287
 288     \$self->assert_valid;
 289
 290     my \$info = \$self->{info};
 291     \$info = \$self->{info} = [ Scope::Upper::context_info(\$self->cxt) ]
 292                                                                         unless \$info;
 293
 294     return \$info->[$idx];
 295    }
 296   TEMPLATE
 297   die $@ if $@;
 298  }
 299 }
 300
 301 =head2 C<want>
 302
 303     my $want = $cxt->want;
 304
 305 Returns the Perl context (in the sense of C<wantarray> : C<undef> for void context, C<''> for scalar context, and true for list context) in which is executed the scope pointed by the invocant.
 306
 307 =cut
 308
 309 sub want {
 310  my $self = shift;
 311
 312  $self->assert_valid;
 313
 314  Scope::Upper::want_at($self->cxt);
 315 }
 316
 317 =head2 C<up>
 318
 319     my $up_cxt = $cxt->up;
 320     my $up_cxt = $cxt->up($frames);
 321     my $up_cxt = Scope::Context->up;
 322
 323 Returns a new L<Scope::Context> object pointing to the C<$frames>-th upper scope above the scope pointed by the invocant.
 324
 325 This method can also be invoked as a class method, in which case it is equivalent to calling L</up> on a L<Scope::Context> object representing the current context.
 326
 327 If omitted, C<$frames> defaults to C<1>.
 328
 329     sub {
 330      {
 331       {
 332        my $up = Scope::Context->new->up(2); # = Scope::Context->up(2)
 333        # $up points two contextes above this one, which is the sub.
 334       }
 335      }
 336     }
 337
 338 =cut
 339
 340 sub up {
 341  my ($self, $frames) = @_;
 342
 343  my $cxt;
 344  if (Scalar::Util::blessed($self)) {
 345   $self->assert_valid;
 346   $cxt = $self->cxt;
 347  } else {
 348   $cxt = Scope::Upper::UP(Scope::Upper::SUB());
 349  }
 350
 351  $frames = 1 unless defined $frames;
 352
 353  $cxt = Scope::Upper::UP($cxt) for 1 .. $frames;
 354
 355  $self->new($cxt);
 356 }
 357
 358 =head2 C<sub>
 359
 360     my $sub_cxt = $cxt->sub;
 361     my $sub_cxt = $cxt->sub($frames);
 362     my $sub_cxt = Scope::Context->sub;
 363
 364 Returns a new L<Scope::Context> object pointing to the C<$frames>-th subroutine scope above the scope pointed by the invocant.
 365
 366 This method can also be invoked as a class method, in which case it is equivalent to calling L</sub> on a L<Scope::Context> object for the current context.
 367
 368 If omitted, C<$frames> defaults to C<0>, which results in the closest sub enclosing the scope pointed by the invocant.
 369
 370     outer();
 371
 372     sub outer {
 373      inner();
 374     }
 375
 376     sub inner {
 377      my $sub = Scope::Context->new->sub(1); # = Scope::Context->sub(1)
 378      # $sub points to the context for the outer() sub.
 379     }
 380
 381 =cut
 382
 383 sub sub {
 384  my ($self, $frames) = @_;
 385
 386  my $cxt;
 387  if (Scalar::Util::blessed($self)) {
 388   $self->assert_valid;
 389   $cxt = $self->cxt;
 390  } else {
 391   $cxt = Scope::Upper::UP(Scope::Upper::SUB());
 392  }
 393
 394  $frames = 0 unless defined $frames;
 395
 396  $cxt = Scope::Upper::SUB($cxt);
 397  $cxt = Scope::Upper::SUB(Scope::Upper::UP($cxt)) for 1 .. $frames;
 398
 399  $self->new($cxt);
 400 }
 401
 402 =head2 C<eval>
 403
 404     my $eval_cxt = $cxt->eval;
 405     my $eval_cxt = $cxt->eval($frames);
 406     my $eval_cxt = Scope::Context->eval;
 407
 408 Returns a new L<Scope::Context> object pointing to the C<$frames>-th C<eval> scope above the scope pointed by the invocant.
 409
 410 This method can also be invoked as a class method, in which case it is equivalent to calling L</eval> on a L<Scope::Context> object for the current context.
 411
 412 If omitted, C<$frames> defaults to C<0>, which results in the closest eval enclosing the scope pointed by the invocant.
 413
 414     eval {
 415      sub {
 416       my $eval = Scope::Context->new->eval; # = Scope::Context->eval
 417       # $eval points to the eval context.
 418      }->()
 419     }
 420
 421 =cut
 422
 423 sub eval {
 424  my ($self, $frames) = @_;
 425
 426  my $cxt;
 427  if (Scalar::Util::blessed($self)) {
 428   $self->assert_valid;
 429   $cxt = $self->cxt;
 430  } else {
 431   $cxt = Scope::Upper::UP(Scope::Upper::SUB());
 432  }
 433
 434  $frames = 0 unless defined $frames;
 435
 436  $cxt = Scope::Upper::EVAL($cxt);
 437  $cxt = Scope::Upper::EVAL(Scope::Upper::UP($cxt)) for 1 .. $frames;
 438
 439  $self->new($cxt);
 440 }
 441
 442 =head2 C<reap>
 443
 444     $cxt->reap($code);
 445
 446 Execute C<$code> when the scope pointed by the invocant ends.
 447
 448 See L<Scope::Upper/reap> for details.
 449
 450 =cut
 451
 452 sub reap {
 453  my ($self, $code) = @_;
 454
 455  $self->assert_valid;
 456
 457  &Scope::Upper::reap($code, $self->cxt);
 458 }
 459
 460 =head2 C<localize>
 461
 462     $cxt->localize($what, $value);
 463
 464 Localize the variable described by C<$what> to the value C<$value> when the control flow returns to the scope pointed by the invocant.
 465
 466 See L<Scope::Upper/localize> for details.
 467
 468 =cut
 469
 470 sub localize {
 471  my ($self, $what, $value) = @_;
 472
 473  $self->assert_valid;
 474
 475  Scope::Upper::localize($what, $value, $self->cxt);
 476 }
 477
 478 =head2 C<localize_elem>
 479
 480     $cxt->localize_elem($what, $key, $value);
 481
 482 Localize the element C<$key> of the variable C<$what> to the value C<$value> when the control flow returns to the scope pointed by the invocant.
 483
 484 See L<Scope::Upper/localize_elem> for details.
 485
 486 =cut
 487
 488 sub localize_elem {
 489  my ($self, $what, $key, $value) = @_;
 490
 491  $self->assert_valid;
 492
 493  Scope::Upper::localize_elem($what, $key, $value, $self->cxt);
 494 }
 495
 496 =head2 C<localize_delete>
 497
 498     $cxt->localize_delete($what, $key);
 499
 500 Delete the element C<$key> from the variable C<$what> when the control flow returns to the scope pointed by the invocant.
 501
 502 See L<Scope::Upper/localize_delete> for details.
 503
 504 =cut
 505
 506 sub localize_delete {
 507  my ($self, $what, $key) = @_;
 508
 509  $self->assert_valid;
 510
 511  Scope::Upper::localize_delete($what, $key, $self->cxt);
 512 }
 513
 514 =head2 C<unwind>
 515
 516     $cxt->unwind(@values);
 517
 518 Immediately returns the scalars listed in C<@values> from the closest subroutine enclosing the scope pointed by the invocant.
 519
 520 See L<Scope::Upper/unwind> for details.
 521
 522 =cut
 523
 524 sub unwind {
 525  my $self = shift;
 526
 527  $self->assert_valid;
 528
 529  Scope::Upper::unwind(@_ => $self->cxt);
 530 }
 531
 532 =head2 C<yield>
 533
 534     $cxt->yield(@values);
 535
 536 Immediately returns the scalars listed in C<@values> from the scope pointed by the invocant, whatever it may be (except a substitution eval context).
 537
 538 See L<Scope::Upper/yield> for details.
 539
 540 =cut
 541
 542 sub yield {
 543  my $self = shift;
 544
 545  $self->assert_valid;
 546
 547  Scope::Upper::yield(@_ => $self->cxt);
 548 }
 549
 550 =head2 C<uplevel>
 551
 552     my @ret = $cxt->uplevel($code, @args);
 553
 554 Executes the code reference C<$code> with arguments C<@args> in the same setting as the closest subroutine enclosing the scope pointed by the invocant, then returns to the current scope the values returned by C<$code>.
 555
 556 See L<Scope::Upper/uplevel> for details.
 557
 558 =cut
 559
 560 sub uplevel {
 561  my $self = shift;
 562  my $code = shift;
 563
 564  $self->assert_valid;
 565
 566  &Scope::Upper::uplevel($code => @_ => $self->cxt);
 567 }
 568
 569 =head1 DEPENDENCIES
 570
 571 L<Carp> (core module since perl 5), L<Scalar::Util> (since 5.7.3).
 572
 573 L<Scope::Upper> 0.21.
 574
 575 =head1 SEE ALSO
 576
 577 L<Scope::Upper>.
 578
 579 L<Continuation::Escape>.
 580
 581 =head1 AUTHOR
 582
 583 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 584
 585 You can contact me by mail or on C<irc.perl.org> (vincent).
 586
 587 =head1 BUGS
 588
 589 Please report any bugs or feature requests to C<bug-scope-context at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Scope-Context>.
 590 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 591
 592 =head1 SUPPORT
 593
 594 You can find documentation for this module with the perldoc command.
 595
 596     perldoc Scope::Context
 597
 598 =head1 COPYRIGHT & LICENSE
 599
 600 Copyright 2011,2012,2013 Vincent Pit, all rights reserved.
 601
 602 This program is free software; you can redistribute it and/or modify it
 603 under the same terms as Perl itself.
 604
 605 =cut
 606
 607 1; # End of Scope::Context