]> git.vpit.fr Git - perl/modules/Scope-Context.git/blob - lib/Scope/Context.pm
8fafca8b5a3e8ed92217088cb4f1a0c7de30ccae
[perl/modules/Scope-Context.git] / 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<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 pointed by the invocant.
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 scope pointed by the invocant.
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 representing 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  my $cxt;
240  if (Scalar::Util::blessed($self)) {
241   $self->assert_valid;
242   $cxt = $self->cxt;
243  } else {
244   $cxt = Scope::Upper::UP(Scope::Upper::SUB());
245  }
246
247  $frames = 1 unless defined $frames;
248
249  $cxt = Scope::Upper::UP($cxt) for 1 .. $frames;
250
251  $self->new($cxt);
252 }
253
254 =head2 C<sub>
255
256     my $sub_cxt = $cxt->sub;
257     my $sub_cxt = $cxt->sub($frames);
258     my $sub_cxt = Scope::Context->sub;
259
260 Returns a new L<Scope::Context> object pointing to the C<$frames>-th subroutine scope above the scope pointed by the invocant.
261
262 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.
263
264 If omitted, C<$frames> defaults to C<0>, which results in the closest sub enclosing the scope pointed by the invocant.
265
266     outer();
267
268     sub outer {
269      inner();
270     }
271
272     sub inner {
273      my $sub = Scope::Context->new->sub(1); # = Scope::Context->sub(1)
274      # $sub points to the context for the outer() sub.
275     }
276
277 =cut
278
279 sub sub {
280  my ($self, $frames) = @_;
281
282  my $cxt;
283  if (Scalar::Util::blessed($self)) {
284   $self->assert_valid;
285   $cxt = $self->cxt;
286  } else {
287   $cxt = Scope::Upper::UP(Scope::Upper::SUB());
288  }
289
290  $frames = 0 unless defined $frames;
291
292  $cxt = Scope::Upper::SUB($cxt);
293  $cxt = Scope::Upper::SUB(Scope::Upper::UP($cxt)) for 1 .. $frames;
294
295  $self->new($cxt);
296 }
297
298 =head2 C<eval>
299
300     my $eval_cxt = $cxt->eval;
301     my $eval_cxt = $cxt->eval($frames);
302     my $eval_cxt = Scope::Context->eval;
303
304 Returns a new L<Scope::Context> object pointing to the C<$frames>-th C<eval> scope above the scope pointed by the invocant.
305
306 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.
307
308 If omitted, C<$frames> defaults to C<0>, which results in the closest eval enclosing the scope pointed by the invocant.
309
310     eval {
311      sub {
312       my $eval = Scope::Context->new->eval; # = Scope::Context->eval
313       # $eval points to the eval context.
314      }->()
315     }
316
317 =cut
318
319 sub eval {
320  my ($self, $frames) = @_;
321
322  my $cxt;
323  if (Scalar::Util::blessed($self)) {
324   $self->assert_valid;
325   $cxt = $self->cxt;
326  } else {
327   $cxt = Scope::Upper::UP(Scope::Upper::SUB());
328  }
329
330  $frames = 0 unless defined $frames;
331
332  $cxt = Scope::Upper::EVAL($cxt);
333  $cxt = Scope::Upper::EVAL(Scope::Upper::UP($cxt)) for 1 .. $frames;
334
335  $self->new($cxt);
336 }
337
338 =head2 C<reap>
339
340     $cxt->reap($code);
341
342 Execute C<$code> when the scope pointed by the invocant ends.
343
344 See L<Scope::Upper/reap> for details.
345
346 =cut
347
348 sub reap {
349  my ($self, $code) = @_;
350
351  $self->assert_valid;
352
353  &Scope::Upper::reap($code, $self->cxt);
354 }
355
356 =head2 C<localize>
357
358     $cxt->localize($what, $value);
359
360 Localize the variable described by C<$what> to the value C<$value> when the control flow returns to the scope pointed by the invocant.
361
362 See L<Scope::Upper/localize> for details.
363
364 =cut
365
366 sub localize {
367  my ($self, $what, $value) = @_;
368
369  $self->assert_valid;
370
371  Scope::Upper::localize($what, $value, $self->cxt);
372 }
373
374 =head2 C<localize_elem>
375
376     $cxt->localize_elem($what, $key, $value);
377
378 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.
379
380 See L<Scope::Upper/localize_elem> for details.
381
382 =cut
383
384 sub localize_elem {
385  my ($self, $what, $key, $value) = @_;
386
387  $self->assert_valid;
388
389  Scope::Upper::localize_elem($what, $key, $value, $self->cxt);
390 }
391
392 =head2 C<localize_delete>
393
394     $cxt->localize_delete($what, $key);
395
396 Delete the element C<$key> from the variable C<$what> when the control flow returns to the scope pointed by the invocant.
397
398 See L<Scope::Upper/localize_delete> for details.
399
400 =cut
401
402 sub localize_delete {
403  my ($self, $what, $key) = @_;
404
405  $self->assert_valid;
406
407  Scope::Upper::localize_delete($what, $key, $self->cxt);
408 }
409
410 =head2 C<unwind>
411
412     $cxt->unwind(@values);
413
414 Immediately returns the scalars listed in C<@values> from the closest subroutine enclosing the scope pointed by the invocant.
415
416 See L<Scope::Upper/unwind> for details.
417
418 =cut
419
420 sub unwind {
421  my $self = shift;
422
423  $self->assert_valid;
424
425  Scope::Upper::unwind(@_ => $self->cxt);
426 }
427
428 =head2 C<yield>
429
430     $cxt->yield(@values);
431
432 Immediately returns the scalars listed in C<@values> from the scope pointed by the invocant, whatever it may be (except a substitution eval context).
433
434 See L<Scope::Upper/yield> for details.
435
436 =cut
437
438 sub yield {
439  my $self = shift;
440
441  $self->assert_valid;
442
443  Scope::Upper::yield(@_ => $self->cxt);
444 }
445
446 =head2 C<uplevel>
447
448     my @ret = $cxt->uplevel($code, @args);
449
450 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>.
451
452 See L<Scope::Upper/uplevel> for details.
453
454 =cut
455
456 sub uplevel {
457  my $self = shift;
458  my $code = shift;
459
460  $self->assert_valid;
461
462  &Scope::Upper::uplevel($code => @_ => $self->cxt);
463 }
464
465 =head1 DEPENDENCIES
466
467 L<Carp> (core module since perl 5), L<Scalar::Util> (since 5.7.3).
468
469 L<Scope::Upper> 0.21.
470
471 =head1 SEE ALSO
472
473 L<Scope::Upper>.
474
475 L<Continuation::Escape>.
476
477 =head1 AUTHOR
478
479 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
480
481 You can contact me by mail or on C<irc.perl.org> (vincent).
482
483 =head1 BUGS
484
485 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>.
486 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
487
488 =head1 SUPPORT
489
490 You can find documentation for this module with the perldoc command.
491
492     perldoc Scope::Context
493
494 =head1 COPYRIGHT & LICENSE
495
496 Copyright 2011,2012,2013 Vincent Pit, all rights reserved.
497
498 This program is free software; you can redistribute it and/or modify it
499 under the same terms as Perl itself.
500
501 =cut
502
503 1; # End of Scope::Context