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 [ $context ]>
  91
  92 Creates a new immutable L<Scope::Context> object from the L<Scope::Upper>-comptabile context C<$context>.
  93 If omitted, C<$context> defaults to the current context.
  94
  95 =cut
  96
  97 sub new {
  98  my ($self, $cxt) = @_;
  99
 100  my $class = Scalar::Util::blessed($self);
 101  unless (defined $class) {
 102   $class = defined $self ? $self : __PACKAGE__;
 103  }
 104
 105  $cxt = Scope::Upper::UP() unless defined $cxt;
 106
 107  bless {
 108   cxt => $cxt,
 109   uid => Scope::Upper::uid($cxt),
 110  }, $class;
 111 }
 112
 113 =head2 C<here>
 114
 115 A synonym for L</new>.
 116
 117 =cut
 118
 119 BEGIN {
 120  *here = \&new;
 121 }
 122
 123 sub _croak {
 124  shift;
 125  require Carp;
 126  Carp::croak(@_);
 127 }
 128
 129 =head2 C<cxt>
 130
 131 Read-only accessor to the L<Scope::Upper> context corresponding to the topic L<Scope::Context> object.
 132
 133 =head2 C<uid>
 134
 135 Read-only accessor to the L<Scope::Upper> UID of the topic L<Scope::Context> object.
 136
 137 =cut
 138
 139 BEGIN {
 140  local $@;
 141  eval "sub $_ { \$_[0]->{$_} }; 1" or die $@ for qw<cxt uid>;
 142 }
 143
 144 =pod
 145
 146 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.
 147
 148 =cut
 149
 150 use overload (
 151  '==' => sub {
 152   my ($left, $right) = @_;
 153
 154   unless (Scalar::Util::blessed($right) and $right->isa(__PACKAGE__)) {
 155    $left->_croak('Cannot compare a Scope::Context object with something else');
 156   }
 157
 158   $left->uid eq $right->uid;
 159  },
 160  fallback => 1,
 161 );
 162
 163 =head2 C<is_valid>
 164
 165 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).
 166
 167 =cut
 168
 169 sub is_valid { Scope::Upper::validate_uid($_[0]->uid) }
 170
 171 =head2 C<assert_valid>
 172
 173 Throws an exception if the topic context has expired and is no longer valid.
 174 Returns true otherwise.
 175
 176 =cut
 177
 178 sub assert_valid {
 179  my $self = shift;
 180
 181  $self->_croak('Context has expired') unless $self->is_valid;
 182
 183  1;
 184 }
 185
 186 =head2 C<want>
 187
 188 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.
 189
 190 =cut
 191
 192 sub want {
 193  my $self = shift;
 194
 195  $self->assert_valid;
 196
 197  Scope::Upper::want_at($self->cxt);
 198 }
 199
 200 =head2 C<up [ $frames ]>
 201
 202 Returns a new L<Scope::Context> object pointing to the C<$frames>-th upper scope above the topic context.
 203
 204 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.
 205
 206 If omitted, C<$frames> defaults to C<1>.
 207
 208     sub {
 209      {
 210       {
 211        my $up = Scope::Context->new->up(2); # = Scope::Context->up(2)
 212        # $up points two contextes above this one, which is the sub.
 213       }
 214      }
 215     }
 216
 217 =cut
 218
 219 sub up {
 220  my ($self, $frames) = @_;
 221
 222  if (Scalar::Util::blessed($self)) {
 223   $self->assert_valid;
 224  } else {
 225   $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
 226  }
 227
 228  $frames = 1 unless defined $frames;
 229
 230  my $cxt = $self->cxt;
 231  $cxt = Scope::Upper::UP($cxt) for 1 .. $frames;
 232
 233  $self->new($cxt);
 234 }
 235
 236 =head2 C<sub [ $frames ]>
 237
 238 Returns a new L<Scope::Context> object pointing to the C<$frames>-th subroutine scope above the topic context.
 239
 240 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.
 241
 242 If omitted, C<$frames> defaults to C<0>, which results in the closest sub enclosing the topic context.
 243
 244     outer();
 245
 246     sub outer {
 247      inner();
 248     }
 249
 250     sub inner {
 251      my $sub = Scope::Context->new->sub(1); # = Scope::Context->sub(1)
 252      # $sub points to the context for the outer() sub.
 253     }
 254
 255 =cut
 256
 257 sub sub {
 258  my ($self, $frames) = @_;
 259
 260  if (Scalar::Util::blessed($self)) {
 261   $self->assert_valid;
 262  } else {
 263   $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
 264  }
 265
 266  $frames = 0 unless defined $frames;
 267
 268  my $cxt = Scope::Upper::SUB($self->cxt);
 269  $cxt = Scope::Upper::SUB(Scope::Upper::UP($cxt)) for 1 .. $frames;
 270
 271  $self->new($cxt);
 272 }
 273
 274 =head2 C<eval [ $frames ]>
 275
 276 Returns a new L<Scope::Context> object pointing to the C<$frames>-th C<eval> scope above the topic context.
 277
 278 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.
 279
 280 If omitted, C<$frames> defaults to C<0>, which results in the closest eval enclosing the topic context.
 281
 282     eval {
 283      sub {
 284       my $eval = Scope::Context->new->eval; # = Scope::Context->eval
 285       # $eval points to the eval context.
 286      }->()
 287     }
 288
 289 =cut
 290
 291 sub eval {
 292  my ($self, $frames) = @_;
 293
 294  if (Scalar::Util::blessed($self)) {
 295   $self->assert_valid;
 296  } else {
 297   $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
 298  }
 299
 300  $frames = 0 unless defined $frames;
 301
 302  my $cxt = Scope::Upper::EVAL($self->cxt);
 303  $cxt = Scope::Upper::EVAL(Scope::Upper::UP($cxt)) for 1 .. $frames;
 304
 305  $self->new($cxt);
 306 }
 307
 308 =head2 C<reap $code>
 309
 310 Execute C<$code> when the topic context ends.
 311
 312 See L<Scope::Upper/reap> for details.
 313
 314 =cut
 315
 316 sub reap {
 317  my ($self, $code) = @_;
 318
 319  $self->assert_valid;
 320
 321  &Scope::Upper::reap($code, $self->cxt);
 322 }
 323
 324 =head2 C<localize $what, $value>
 325
 326 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.
 327
 328 See L<Scope::Upper/localize> for details.
 329
 330 =cut
 331
 332 sub localize {
 333  my ($self, $what, $value) = @_;
 334
 335  $self->assert_valid;
 336
 337  Scope::Upper::localize($what, $value, $self->cxt);
 338 }
 339
 340 =head2 C<localize_elem $what, $key, $value>
 341
 342 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.
 343
 344 See L<Scope::Upper/localize_elem> for details.
 345
 346 =cut
 347
 348 sub localize_elem {
 349  my ($self, $what, $key, $value) = @_;
 350
 351  $self->assert_valid;
 352
 353  Scope::Upper::localize_elem($what, $key, $value, $self->cxt);
 354 }
 355
 356 =head2 C<localize_delete $what, $key>
 357
 358 Delete the element C<$key> from the variable C<$what> when the control flow returns to the scope pointed by the topic context.
 359
 360 See L<Scope::Upper/localize_delete> for details.
 361
 362 =cut
 363
 364 sub localize_delete {
 365  my ($self, $what, $key) = @_;
 366
 367  $self->assert_valid;
 368
 369  Scope::Upper::localize_delete($what, $key, $self->cxt);
 370 }
 371
 372 =head2 C<unwind @values>
 373
 374 Immediately returns the scalars listed in C<@values> from the closest subroutine enclosing the topic context.
 375
 376 See L<Scope::Upper/unwind> for details.
 377
 378 =cut
 379
 380 sub unwind {
 381  my $self = shift;
 382
 383  $self->assert_valid;
 384
 385  Scope::Upper::unwind(@_ => $self->cxt);
 386 }
 387
 388 =head2 C<uplevel $code, @args>
 389
 390 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>.
 391
 392 See L<Scope::Upper/uplevel> for details.
 393
 394 =cut
 395
 396 sub uplevel {
 397  my $self = shift;
 398  my $code = shift;
 399
 400  $self->assert_valid;
 401
 402  &Scope::Upper::uplevel($code => @_ => $self->cxt);
 403 }
 404
 405 =head1 DEPENDENCIES
 406
 407 L<Carp> (core module since perl 5), L<Scalar::Util> (since 5.7.3).
 408
 409 L<Scope::Upper> 0.18.
 410
 411 =head1 SEE ALSO
 412
 413 L<Scope::Upper>.
 414
 415 L<Continuation::Escape>.
 416
 417 =head1 AUTHOR
 418
 419 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 420
 421 You can contact me by mail or on C<irc.perl.org> (vincent).
 422
 423 =head1 BUGS
 424
 425 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>.
 426 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 427
 428 =head1 SUPPORT
 429
 430 You can find documentation for this module with the perldoc command.
 431
 432     perldoc Scope::Context
 433
 434 =head1 COPYRIGHT & LICENSE
 435
 436 Copyright 2011 Vincent Pit, all rights reserved.
 437
 438 This program is free software; you can redistribute it and/or modify it
 439 under the same terms as Perl itself.
 440
 441 =cut
 442
 443 1; # End of Scope::Context