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.18 ();
  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 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 corresponding to the topic L<Scope::Context> object.
 137
 138 =head2 C<uid>
 139
 140     my $uid = $cxt->uid;
 141
 142 Read-only accessor to the L<Scope::Upper> UID of the topic L<Scope::Context> object.
 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 topic context is still valid (that is, it designates a scope that is higher than the topic context in the call stack).
 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 topic context 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<want>
 198
 199     my $want = $cxt->want;
 200
 201 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 corresponding to the topic L<Scope::Context> object.
 202
 203 =cut
 204
 205 sub want {
 206  my $self = shift;
 207
 208  $self->assert_valid;
 209
 210  Scope::Upper::want_at($self->cxt);
 211 }
 212
 213 =head2 C<up>
 214
 215     my $up_cxt = $cxt->up;
 216     my $up_cxt = $cxt->up($frames);
 217     my $up_cxt = Scope::Context->up;
 218
 219 Returns a new L<Scope::Context> object pointing to the C<$frames>-th upper scope above the topic context.
 220
 221 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 for the current context.
 222
 223 If omitted, C<$frames> defaults to C<1>.
 224
 225     sub {
 226      {
 227       {
 228        my $up = Scope::Context->new->up(2); # = Scope::Context->up(2)
 229        # $up points two contextes above this one, which is the sub.
 230       }
 231      }
 232     }
 233
 234 =cut
 235
 236 sub up {
 237  my ($self, $frames) = @_;
 238
 239  if (Scalar::Util::blessed($self)) {
 240   $self->assert_valid;
 241  } else {
 242   $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
 243  }
 244
 245  $frames = 1 unless defined $frames;
 246
 247  my $cxt = $self->cxt;
 248  $cxt = Scope::Upper::UP($cxt) for 1 .. $frames;
 249
 250  $self->new($cxt);
 251 }
 252
 253 =head2 C<sub>
 254
 255     my $sub_cxt = $cxt->sub;
 256     my $sub_cxt = $cxt->sub($frames);
 257     my $sub_cxt = Scope::Context->sub;
 258
 259 Returns a new L<Scope::Context> object pointing to the C<$frames>-th subroutine scope above the topic context.
 260
 261 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.
 262
 263 If omitted, C<$frames> defaults to C<0>, which results in the closest sub enclosing the topic context.
 264
 265     outer();
 266
 267     sub outer {
 268      inner();
 269     }
 270
 271     sub inner {
 272      my $sub = Scope::Context->new->sub(1); # = Scope::Context->sub(1)
 273      # $sub points to the context for the outer() sub.
 274     }
 275
 276 =cut
 277
 278 sub sub {
 279  my ($self, $frames) = @_;
 280
 281  if (Scalar::Util::blessed($self)) {
 282   $self->assert_valid;
 283  } else {
 284   $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
 285  }
 286
 287  $frames = 0 unless defined $frames;
 288
 289  my $cxt = Scope::Upper::SUB($self->cxt);
 290  $cxt = Scope::Upper::SUB(Scope::Upper::UP($cxt)) for 1 .. $frames;
 291
 292  $self->new($cxt);
 293 }
 294
 295 =head2 C<eval>
 296
 297     my $eval_cxt = $cxt->eval;
 298     my $eval_cxt = $cxt->eval($frames);
 299     my $eval_cxt = Scope::Context->eval;
 300
 301 Returns a new L<Scope::Context> object pointing to the C<$frames>-th C<eval> scope above the topic context.
 302
 303 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.
 304
 305 If omitted, C<$frames> defaults to C<0>, which results in the closest eval enclosing the topic context.
 306
 307     eval {
 308      sub {
 309       my $eval = Scope::Context->new->eval; # = Scope::Context->eval
 310       # $eval points to the eval context.
 311      }->()
 312     }
 313
 314 =cut
 315
 316 sub eval {
 317  my ($self, $frames) = @_;
 318
 319  if (Scalar::Util::blessed($self)) {
 320   $self->assert_valid;
 321  } else {
 322   $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
 323  }
 324
 325  $frames = 0 unless defined $frames;
 326
 327  my $cxt = Scope::Upper::EVAL($self->cxt);
 328  $cxt = Scope::Upper::EVAL(Scope::Upper::UP($cxt)) for 1 .. $frames;
 329
 330  $self->new($cxt);
 331 }
 332
 333 =head2 C<reap>
 334
 335     $cxt->reap($code);
 336
 337 Execute C<$code> when the topic context ends.
 338
 339 See L<Scope::Upper/reap> for details.
 340
 341 =cut
 342
 343 sub reap {
 344  my ($self, $code) = @_;
 345
 346  $self->assert_valid;
 347
 348  &Scope::Upper::reap($code, $self->cxt);
 349 }
 350
 351 =head2 C<localize>
 352
 353     $cxt->localize($what, $value);
 354
 355 Localize the variable described by C<$what> to the value C<$value> when the control flow returns to the scope pointed by the topic context.
 356
 357 See L<Scope::Upper/localize> for details.
 358
 359 =cut
 360
 361 sub localize {
 362  my ($self, $what, $value) = @_;
 363
 364  $self->assert_valid;
 365
 366  Scope::Upper::localize($what, $value, $self->cxt);
 367 }
 368
 369 =head2 C<localize_elem>
 370
 371     $cxt->localize_elem($what, $key, $value);
 372
 373 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 topic context.
 374
 375 See L<Scope::Upper/localize_elem> for details.
 376
 377 =cut
 378
 379 sub localize_elem {
 380  my ($self, $what, $key, $value) = @_;
 381
 382  $self->assert_valid;
 383
 384  Scope::Upper::localize_elem($what, $key, $value, $self->cxt);
 385 }
 386
 387 =head2 C<localize_delete>
 388
 389     $cxt->localize_delete($what, $key);
 390
 391 Delete the element C<$key> from the variable C<$what> when the control flow returns to the scope pointed by the topic context.
 392
 393 See L<Scope::Upper/localize_delete> for details.
 394
 395 =cut
 396
 397 sub localize_delete {
 398  my ($self, $what, $key) = @_;
 399
 400  $self->assert_valid;
 401
 402  Scope::Upper::localize_delete($what, $key, $self->cxt);
 403 }
 404
 405 =head2 C<unwind>
 406
 407     $cxt->unwind(@values);
 408
 409 Immediately returns the scalars listed in C<@values> from the closest subroutine enclosing the topic context.
 410
 411 See L<Scope::Upper/unwind> for details.
 412
 413 =cut
 414
 415 sub unwind {
 416  my $self = shift;
 417
 418  $self->assert_valid;
 419
 420  Scope::Upper::unwind(@_ => $self->cxt);
 421 }
 422
 423 =head2 C<uplevel>
 424
 425     my @ret = $cxt->uplevel($code, @args);
 426
 427 Executes the code reference C<$code> with arguments C<@args> in the same setting as the closest subroutine enclosing the topic context, then returns to the current scope the values returned by C<$code>.
 428
 429 See L<Scope::Upper/uplevel> for details.
 430
 431 =cut
 432
 433 sub uplevel {
 434  my $self = shift;
 435  my $code = shift;
 436
 437  $self->assert_valid;
 438
 439  &Scope::Upper::uplevel($code => @_ => $self->cxt);
 440 }
 441
 442 =head1 DEPENDENCIES
 443
 444 L<Carp> (core module since perl 5), L<Scalar::Util> (since 5.7.3).
 445
 446 L<Scope::Upper> 0.18.
 447
 448 =head1 SEE ALSO
 449
 450 L<Scope::Upper>.
 451
 452 L<Continuation::Escape>.
 453
 454 =head1 AUTHOR
 455
 456 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 457
 458 You can contact me by mail or on C<irc.perl.org> (vincent).
 459
 460 =head1 BUGS
 461
 462 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>.
 463 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 464
 465 =head1 SUPPORT
 466
 467 You can find documentation for this module with the perldoc command.
 468
 469     perldoc Scope::Context
 470
 471 =head1 COPYRIGHT & LICENSE
 472
 473 Copyright 2011 Vincent Pit, all rights reserved.
 474
 475 This program is free software; you can redistribute it and/or modify it
 476 under the same terms as Perl itself.
 477
 478 =cut
 479
 480 1; # End of Scope::Context