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