]> git.vpit.fr Git - perl/modules/Scope-Context.git/blob - lib/Scope/Context.pm
Initial commit
[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.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