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