--- /dev/null
+blib*
+pm_to_blib*
+
+Makefile
+Makefile.old
+Build
+_build*
+
+MYMETA.json
+MYMETA.yml
+
+*.tar.gz
+Scope-Context-*
+
+core.*
+*.[co]
+*.so
+*.bs
+*.out
+*.def
+*.exp
+
+cover_db
+*.gcda
+*.gcov
+*.gcno
+
+Debian_CPANTS.txt
--- /dev/null
+Revision history for Scope-Context
+
+0.01 2011-10-11
+ First version, released on an unsuspecting world.
--- /dev/null
+Changes
+Makefile.PL
+MANIFEST
+META.json
+META.yml
+README
+lib/Scope/Context.pm
+samples/synopsis.pl
+t/00-load.t
+t/02-can.t
+t/10-basic.t
+t/11-target.t
+t/12-actions.t
+t/13-valid.t
+t/14-cmp.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
--- /dev/null
+{
+ "abstract" : "Object-oriented interface for inspecting or acting upon upper scope frames.",
+ "author" : [
+ "Vincent Pit <perl@profvince.com>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "ExtUtils::MakeMaker version 6.59, CPAN::Meta::Converter version 2.112621",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Scope-Context",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : 0,
+ "Scalar::Util" : 0,
+ "Scope::Upper" : "0.18",
+ "Test::More" : 0
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : 0
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Scalar::Util" : 0,
+ "Scope::Upper" : "0.18",
+ "perl" : "5.006"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Scope-Context"
+ },
+ "homepage" : "http://search.cpan.org/dist/Scope-Context/",
+ "license" : [
+ "http://dev.perl.org/licenses/"
+ ],
+ "repository" : {
+ "url" : "http://git.profvince.com/?p=perl%2Fmodules%2FScope-Context.git"
+ }
+ },
+ "version" : "0.01"
+}
--- /dev/null
+---
+abstract: 'Object-oriented interface for inspecting or acting upon upper scope frames.'
+author:
+ - 'Vincent Pit <perl@profvince.com>'
+build_requires:
+ ExtUtils::MakeMaker: 0
+ Scalar::Util: 0
+ Scope::Upper: 0.18
+ Test::More: 0
+configure_requires:
+ ExtUtils::MakeMaker: 0
+dynamic_config: 0
+generated_by: 'ExtUtils::MakeMaker version 6.59, CPAN::Meta::Converter version 2.112621'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Scope-Context
+no_index:
+ directory:
+ - t
+ - inc
+requires:
+ Scalar::Util: 0
+ Scope::Upper: 0.18
+ perl: 5.006
+resources:
+ bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Scope-Context
+ homepage: http://search.cpan.org/dist/Scope-Context/
+ license: http://dev.perl.org/licenses/
+ repository: http://git.profvince.com/?p=perl%2Fmodules%2FScope-Context.git
+version: 0.01
--- /dev/null
+use 5.006;
+
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+my $dist = 'Scope-Context';
+
+(my $name = $dist) =~ s{-}{::}g;
+
+(my $file = $dist) =~ s{-}{/}g;
+$file = "lib/$file.pm";
+
+my %PREREQ_PM = (
+ 'Scope::Upper' => '0.18',
+ 'Scalar::Util' => 0,
+);
+
+my %META = (
+ configure_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+ 'ExtUtils::MakeMaker' => 0,
+ 'Test::More' => 0,
+ %PREREQ_PM,
+ },
+ dynamic_config => 0,
+ resources => {
+ bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
+ homepage => "http://search.cpan.org/dist/$dist/",
+ license => 'http://dev.perl.org/licenses/',
+ repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git",
+ },
+);
+
+WriteMakefile(
+ NAME => $name,
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => $file,
+ ABSTRACT_FROM => $file,
+ PL_FILES => {},
+ PREREQ_PM => \%PREREQ_PM,
+ MIN_PERL_VERSION => 5.006,
+ META_MERGE => \%META,
+ dist => {
+ PREOP => "pod2text -u $file > \$(DISTVNAME)/README",
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+ },
+ clean => {
+ FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
+ }
+);
--- /dev/null
+NAME
+ Scope::Context - Object-oriented interface for inspecting or acting upon
+ upper scope frames.
+
+VERSION
+ Version 0.01
+
+SYNOPSIS
+ use Scope::Context;
+
+ for (1 .. 5) {
+ sub {
+ eval {
+ # create Scope::Context objects
+ my ($block, $sub, $eval, $loop);
+ {
+ $block = Scope::Context->new;
+ $sub = $block->sub; # = $block->up
+ $eval = $block->eval; # = $block->up(2)
+ $loop = $eval->up; # = $block->up(3)
+ }
+
+ eval {
+ # This will throw an exception, since $block has expired.
+ $block->localize('$x' => 1);
+ };
+
+ # This prints "hello" when the eval block above ends.
+ $eval->reap(sub { print "hello\n" });
+
+ # Ignore $SIG{__DIE__} just for the loop.
+ $loop->localize_delete('%SIG', '__DIE__');
+
+ # Execute the callback as if it ran in place of the sub.
+ my @values = $sub->uplevel(sub {
+ return @_, 2;
+ }, 1);
+
+ # Immediately return (1, 2, 3) from the sub, bypassing the eval.
+ $sub->unwind(@values, 3);
+ }
+ }->();
+ }
+
+DESCRIPTION
+ This class provides an object-oriented interface to Scope::Upper's
+ functionalities. A Scope::Context object represents a currently active
+ dynamic scope (or context), and encapsulates the corresponding
+ Scope::Upper-compatible context identifier. All of Scope::Upper's
+ functions are then made available as methods. 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.
+
+ The Scope::Context methods actually do more than their subroutine
+ counterparts from 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. This
+ means that :
+
+ my $sc;
+ {
+ $sc = Scope::Context->new;
+ }
+ $sc->reap(sub { print "hello\n });
+
+ will croak when "reap" is called.
+
+METHODS
+ "new [ $context ]"
+ Creates a new immutable Scope::Context object from the
+ Scope::Upper-comptabile context $context. If omitted, $context defaults
+ to the current context.
+
+ "here"
+ A synonym for "new".
+
+ "cxt"
+ Read-only accessor to the Scope::Upper context corresponding to the
+ topic Scope::Context object.
+
+ "uid"
+ Read-only accessor to the Scope::Upper UID of the topic Scope::Context
+ object.
+
+ This class also overloads the "==" operator, which will return true if
+ and only if its two operands are Scope::Context objects that have the
+ same UID.
+
+ "is_valid"
+ 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).
+
+ "assert_valid"
+ Throws an exception if the topic context has expired and is no longer
+ valid. Returns true otherwise.
+
+ "want"
+ Returns the Perl context (in the sense of "wantarray" : "undef" for void
+ context, '' for scalar context, and true for list context) in which is
+ executed the scope corresponding to the topic Scope::Context object.
+
+ "up [ $frames ]"
+ Returns a new Scope::Context object pointing to the $frames-th upper
+ scope above the topic context.
+
+ This method can also be invoked as a class method, in which case it is
+ equivalent to calling "up" on a Scope::Context object for the current
+ context.
+
+ If omitted, $frames defaults to 1.
+
+ sub {
+ {
+ {
+ my $up = Scope::Context->new->up(2); # = Scope::Context->up(2)
+ # $up points two contextes above this one, which is the sub.
+ }
+ }
+ }
+
+ "sub [ $frames ]"
+ Returns a new Scope::Context object pointing to the $frames-th
+ subroutine scope above the topic context.
+
+ This method can also be invoked as a class method, in which case it is
+ equivalent to calling "sub" on a Scope::Context object for the current
+ context.
+
+ If omitted, $frames defaults to 0, which results in the closest sub
+ enclosing the topic context.
+
+ outer();
+
+ sub outer {
+ inner();
+ }
+
+ sub inner {
+ my $sub = Scope::Context->new->sub(1); # = Scope::Context->sub
+ # $sub points to the context for the outer() sub.
+ }
+
+ "eval [ $frames ]"
+ Returns a new Scope::Context object pointing to the $frames-th "eval"
+ scope above the topic context.
+
+ This method can also be invoked as a class method, in which case it is
+ equivalent to calling "eval" on a Scope::Context object for the current
+ context.
+
+ If omitted, $frames defaults to 0, which results in the closest eval
+ enclosing the topic context.
+
+ eval {
+ sub {
+ my $eval = Scope::Context->new->eval; # = Scope::Context->eval
+ # $eval points to the eval context.
+ }->()
+ }
+
+ "reap $code"
+ Execute $code when the topic context ends.
+
+ See "reap" in Scope::Upper for details.
+
+ "localize $what, $value"
+ Localize the variable described by $what to the value $value when the
+ control flow returns to the scope pointed by the topic context.
+
+ See "localize" in Scope::Upper for details.
+
+ "localize_elem $what, $key, $value"
+ Localize the element $key of the variable $what to the value $value when
+ the control flow returns to the scope pointed by the topic context.
+
+ See "localize_elem" in Scope::Upper for details.
+
+ "localize_delete $what, $key"
+ Delete the element $key from the variable $what when the control flow
+ returns to the scope pointed by the topic context.
+
+ See "localize_delete" in Scope::Upper for details.
+
+ "unwind @values"
+ Immediately returns the scalars listed in @values from the closest
+ subroutine enclosing the topic context.
+
+ See "unwind" in Scope::Upper for details.
+
+ "uplevel $code, @args"
+ Executes the code reference $code with arguments @args in the same
+ setting as the closest subroutine enclosing the topic context, then
+ returns to the current scope the values returned by $code.
+
+ See "uplevel" in Scope::Upper for details.
+
+DEPENDENCIES
+ Carp (core module since perl 5), Scalar::Util (since 5.7.3).
+
+ Scope::Upper 0.18.
+
+SEE ALSO
+ Scope::Upper.
+
+ Continuation::Escape.
+
+AUTHOR
+ Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
+
+ You can contact me by mail or on "irc.perl.org" (vincent).
+
+BUGS
+ Please report any bugs or feature requests to "bug-scope-context at
+ rt.cpan.org", or through the web interface at
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Scope-Context>. I will
+ be notified, and then you'll automatically be notified of progress on
+ your bug as I make changes.
+
+SUPPORT
+ You can find documentation for this module with the perldoc command.
+
+ perldoc Scope::Context
+
+COPYRIGHT & LICENSE
+ Copyright 2011 Vincent Pit, all rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
--- /dev/null
+package Scope::Context;
+
+use 5.006;
+
+use strict;
+use warnings;
+
+use Carp ();
+use Scalar::Util ();
+
+use Scope::Upper 0.18 ();
+
+=head1 NAME
+
+Scope::Context - Object-oriented interface for inspecting or acting upon upper scope frames.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+ use Scope::Context;
+
+ for (1 .. 5) {
+ sub {
+ eval {
+ # create Scope::Context objects
+ my ($block, $sub, $eval, $loop);
+ {
+ $block = Scope::Context->new;
+ $sub = $block->sub; # = $block->up
+ $eval = $block->eval; # = $block->up(2)
+ $loop = $eval->up; # = $block->up(3)
+ }
+
+ eval {
+ # This will throw an exception, since $block has expired.
+ $block->localize('$x' => 1);
+ };
+
+ # This prints "hello" when the eval block above ends.
+ $eval->reap(sub { print "hello\n" });
+
+ # Ignore $SIG{__DIE__} just for the loop.
+ $loop->localize_delete('%SIG', '__DIE__');
+
+ # Execute the callback as if it ran in place of the sub.
+ my @values = $sub->uplevel(sub {
+ return @_, 2;
+ }, 1);
+
+ # Immediately return (1, 2, 3) from the sub, bypassing the eval.
+ $sub->unwind(@values, 3);
+ }
+ }->();
+ }
+
+=head1 DESCRIPTION
+
+This class provides an object-oriented interface to L<Scope::Upper>'s functionalities.
+A L<Scope::Context> object represents a currently active dynamic scope (or context), and encapsulates the corresponding L<Scope::Upper>-compatible context identifier.
+All of L<Scope::Upper>'s functions are then made available as methods.
+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.
+
+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.
+This means that :
+
+ my $sc;
+ {
+ $sc = Scope::Context->new;
+ }
+ $sc->reap(sub { print "hello\n });
+
+will croak when L</reap> is called.
+
+=head1 METHODS
+
+=head2 C<new [ $context ]>
+
+Creates a new immutable L<Scope::Context> object from the L<Scope::Upper>-comptabile context C<$context>.
+If omitted, C<$context> defaults to the current context.
+
+=cut
+
+sub new {
+ my ($self, $cxt) = @_;
+
+ my $class = Scalar::Util::blessed($self);
+ unless (defined $class) {
+ $class = defined $self ? $self : __PACKAGE__;
+ }
+
+ $cxt = Scope::Upper::UP() unless defined $cxt;
+
+ bless {
+ cxt => $cxt,
+ uid => Scope::Upper::uid($cxt),
+ }, $class;
+}
+
+=head2 C<here>
+
+A synonym for L</new>.
+
+=cut
+
+BEGIN {
+ *here = \&new;
+}
+
+sub _croak {
+ shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
+=head2 C<cxt>
+
+Read-only accessor to the L<Scope::Upper> context corresponding to the topic L<Scope::Context> object.
+
+=head2 C<uid>
+
+Read-only accessor to the L<Scope::Upper> UID of the topic L<Scope::Context> object.
+
+=cut
+
+BEGIN {
+ local $@;
+ eval "sub $_ { \$_[0]->{$_} }; 1" or die $@ for qw<cxt uid>;
+}
+
+=pod
+
+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.
+
+=cut
+
+use overload (
+ '==' => sub {
+ my ($left, $right) = @_;
+
+ unless (Scalar::Util::blessed($right) and $right->isa(__PACKAGE__)) {
+ $left->_croak('Cannot compare a Scope::Context object with something else');
+ }
+
+ $left->uid eq $right->uid;
+ },
+ fallback => 1,
+);
+
+=head2 C<is_valid>
+
+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).
+
+=cut
+
+sub is_valid { Scope::Upper::validate_uid($_[0]->uid) }
+
+=head2 C<assert_valid>
+
+Throws an exception if the topic context has expired and is no longer valid.
+Returns true otherwise.
+
+=cut
+
+sub assert_valid {
+ my $self = shift;
+
+ $self->_croak('Context has expired') unless $self->is_valid;
+
+ 1;
+}
+
+=head2 C<want>
+
+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.
+
+=cut
+
+sub want {
+ my $self = shift;
+
+ $self->assert_valid;
+
+ Scope::Upper::want_at($self->cxt);
+}
+
+=head2 C<up [ $frames ]>
+
+Returns a new L<Scope::Context> object pointing to the C<$frames>-th upper scope above the topic context.
+
+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.
+
+If omitted, C<$frames> defaults to C<1>.
+
+ sub {
+ {
+ {
+ my $up = Scope::Context->new->up(2); # = Scope::Context->up(2)
+ # $up points two contextes above this one, which is the sub.
+ }
+ }
+ }
+
+=cut
+
+sub up {
+ my ($self, $frames) = @_;
+
+ if (Scalar::Util::blessed($self)) {
+ $self->assert_valid;
+ } else {
+ $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
+ }
+
+ $frames = 1 unless defined $frames;
+
+ my $cxt = $self->cxt;
+ $cxt = Scope::Upper::UP($cxt) for 1 .. $frames;
+
+ $self->new($cxt);
+}
+
+=head2 C<sub [ $frames ]>
+
+Returns a new L<Scope::Context> object pointing to the C<$frames>-th subroutine scope above the topic context.
+
+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.
+
+If omitted, C<$frames> defaults to C<0>, which results in the closest sub enclosing the topic context.
+
+ outer();
+
+ sub outer {
+ inner();
+ }
+
+ sub inner {
+ my $sub = Scope::Context->new->sub(1); # = Scope::Context->sub
+ # $sub points to the context for the outer() sub.
+ }
+
+=cut
+
+sub sub {
+ my ($self, $frames) = @_;
+
+ if (Scalar::Util::blessed($self)) {
+ $self->assert_valid;
+ } else {
+ $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
+ }
+
+ $frames = 0 unless defined $frames;
+
+ my $cxt = Scope::Upper::SUB($self->cxt);
+ $cxt = Scope::Upper::SUB(Scope::Upper::UP($cxt)) for 1 .. $frames;
+
+ $self->new($cxt);
+}
+
+=head2 C<eval [ $frames ]>
+
+Returns a new L<Scope::Context> object pointing to the C<$frames>-th C<eval> scope above the topic context.
+
+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.
+
+If omitted, C<$frames> defaults to C<0>, which results in the closest eval enclosing the topic context.
+
+ eval {
+ sub {
+ my $eval = Scope::Context->new->eval; # = Scope::Context->eval
+ # $eval points to the eval context.
+ }->()
+ }
+
+=cut
+
+sub eval {
+ my ($self, $frames) = @_;
+
+ if (Scalar::Util::blessed($self)) {
+ $self->assert_valid;
+ } else {
+ $self = $self->new(Scope::Upper::UP(Scope::Upper::SUB()));
+ }
+
+ $frames = 0 unless defined $frames;
+
+ my $cxt = Scope::Upper::EVAL($self->cxt);
+ $cxt = Scope::Upper::EVAL(Scope::Upper::UP($cxt)) for 1 .. $frames;
+
+ $self->new($cxt);
+}
+
+=head2 C<reap $code>
+
+Execute C<$code> when the topic context ends.
+
+See L<Scope::Upper/reap> for details.
+
+=cut
+
+sub reap {
+ my ($self, $code) = @_;
+
+ $self->assert_valid;
+
+ &Scope::Upper::reap($code, $self->cxt);
+}
+
+=head2 C<localize $what, $value>
+
+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.
+
+See L<Scope::Upper/localize> for details.
+
+=cut
+
+sub localize {
+ my ($self, $what, $value) = @_;
+
+ $self->assert_valid;
+
+ Scope::Upper::localize($what, $value, $self->cxt);
+}
+
+=head2 C<localize_elem $what, $key, $value>
+
+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.
+
+See L<Scope::Upper/localize_elem> for details.
+
+=cut
+
+sub localize_elem {
+ my ($self, $what, $key, $value) = @_;
+
+ $self->assert_valid;
+
+ Scope::Upper::localize_elem($what, $key, $value, $self->cxt);
+}
+
+=head2 C<localize_delete $what, $key>
+
+Delete the element C<$key> from the variable C<$what> when the control flow returns to the scope pointed by the topic context.
+
+See L<Scope::Upper/localize_delete> for details.
+
+=cut
+
+sub localize_delete {
+ my ($self, $what, $key) = @_;
+
+ $self->assert_valid;
+
+ Scope::Upper::localize_delete($what, $key, $self->cxt);
+}
+
+=head2 C<unwind @values>
+
+Immediately returns the scalars listed in C<@values> from the closest subroutine enclosing the topic context.
+
+See L<Scope::Upper/unwind> for details.
+
+=cut
+
+sub unwind {
+ my $self = shift;
+
+ $self->assert_valid;
+
+ Scope::Upper::unwind(@_ => $self->cxt);
+}
+
+=head2 C<uplevel $code, @args>
+
+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>.
+
+See L<Scope::Upper/uplevel> for details.
+
+=cut
+
+sub uplevel {
+ my $self = shift;
+ my $code = shift;
+
+ $self->assert_valid;
+
+ &Scope::Upper::uplevel($code => @_ => $self->cxt);
+}
+
+=head1 DEPENDENCIES
+
+L<Carp> (core module since perl 5), L<Scalar::Util> (since 5.7.3).
+
+L<Scope::Upper> 0.18.
+
+=head1 SEE ALSO
+
+L<Scope::Upper>.
+
+L<Continuation::Escape>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+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>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Scope::Context
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2011 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of Scope::Context
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use blib;
+
+use Scope::Context;
+
+for my $run (1 .. 2) {
+ my @values = sub {
+ local $@;
+
+ eval {
+ # create Scope::Context objects
+ my ($block, $sub, $eval, $loop);
+ {
+ $block = Scope::Context->new;
+ $sub = $block->sub; # = $block->up
+ $eval = $block->eval; # = $block->up(2)
+ $loop = $eval->up; # = $block->up(3)
+ }
+
+ eval {
+ # This will throw an exception, since $block has expired.
+ $block->localize('$x' => 1);
+ };
+ print "Caught an error at run $run: $@" if $@;
+
+ # This prints "hello" when the eval block above ends.
+ $eval->reap(sub { print "End of eval scope at run $run\n" });
+
+ # Ignore $SIG{__DIE__} just for the loop.
+ $loop->localize_delete('%SIG', '__DIE__');
+
+ # Execute the callback as if it ran in place of the sub.
+ my @values = $sub->uplevel(sub {
+ return @_, 2;
+ }, 1);
+
+ # Immediately return (1, 2, 3) from the sub, bypassing the eval.
+ $sub->unwind(@values, 3);
+
+ # Not reached.
+ return 'XXX';
+ };
+
+ # Not reached.
+ die $@ if $@;
+ }->();
+
+ print "Values returned at run $run: @values\n";
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'Scope::Context' );
+}
+
+diag( "Testing Scope::Context $Scope::Context::VERSION, Perl $], $^X" );
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+my @methods = qw<
+ new here
+ cxt
+ uid is_valid assert_valid
+ want
+ up sub eval
+ reap localize localize_elem localize_delete unwind uplevel
+>;
+
+plan tests => scalar(@methods);
+
+require Scope::Context;
+
+for (@methods) {
+ ok(Scope::Context->can($_), 'Scope::Context objects can ' . $_);
+}
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+
+use Scope::Context;
+
+for my $method (qw<new here>) {
+ local $@;
+ eval {
+ my $here = Scope::Context->$method;
+ isa_ok $here, 'Scope::Context', "$method return value isa Scope::Context";
+ };
+ is $@, '', "creating a new object with ->$method does not croak";
+}
+
+{
+ local $@;
+ eval {
+ my $here = Scope::Context->new;
+ my $also_here = Scope::Context->new($here->cxt);
+ isa_ok $here, 'Scope::Context', '$here isa Scope::Context';
+ isa_ok $also_here, 'Scope::Context', '$also_here isa Scope::Context';
+ };
+ is $@, '', 'creating a new object from a given context does not croak';
+}
+
+for my $method (qw<new here>) {
+ local $@;
+ eval {
+ my $here = $Scope::Context::{$method}->();
+ isa_ok $here, 'Scope::Context', "$method return value isa Scope::Context";
+ };
+ is $@, '', "creating a new object with Scope::Context::$method does not croak";
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+use Scope::Context;
+
+use Scope::Upper qw<HERE>;
+
+# Constructor
+
+{
+ my $here = Scope::Context->new;
+ is $here->cxt, HERE, 'default context';
+}
+
+{
+ my $cxt = HERE;
+ {
+ my $here = Scope::Context->new($cxt);
+ is $here->cxt, $cxt, 'forced context';
+ }
+}
+
+# up
+
+{
+ my $cxt = HERE;
+ {
+ my $here = Scope::Context->new;
+ my $up = $here->up;
+ is $up->cxt, $cxt, 'up(undef)';
+ }
+}
+
+{
+ my $cxt = HERE;
+ {
+ my $here = Scope::Context->new;
+ my $up1 = $here->up(1);
+ is $up1->cxt, $cxt, 'up(1)';
+ }
+}
+
+{
+ my $cxt = HERE;
+ {
+ {
+ my $up2 = Scope::Context->up(2);
+ is $up2->cxt, $cxt, 'up(2)';
+ }
+ }
+}
+
+# sub
+
+{
+ sub {
+ my $cxt = HERE;
+ {
+ my $sub = Scope::Context->new->sub;
+ is $sub->cxt, $cxt, 'sub(undef)';
+ }
+ }->();
+}
+
+{
+ sub {
+ my $cxt = HERE;
+ {
+ my $sub = Scope::Context->new->sub(0);
+ is $sub->cxt, $cxt, 'sub(0)';
+ }
+ }->();
+}
+
+{
+ sub {
+ my $cxt = HERE;
+ sub {
+ my $sub = Scope::Context->sub(1);
+ is $sub->cxt, $cxt, 'sub(1)';
+ }->();
+ }->();
+}
+
+# eval
+
+{
+ local $@;
+ eval {
+ my $cxt = HERE;
+ {
+ my $eval = Scope::Context->new->eval;
+ is $eval->cxt, $cxt, 'eval(undef)';
+ }
+ };
+ die $@ if $@;
+}
+
+{
+ local $@;
+ eval {
+ my $cxt = HERE;
+ {
+ my $eval = Scope::Context->new->eval(0);
+ is $eval->cxt, $cxt, 'eval(0)';
+ }
+ };
+ die $@ if $@;
+}
+
+{
+ local $@;
+ eval {
+ my $cxt = HERE;
+ eval {
+ my $eval = Scope::Context->eval(1);
+ is $eval->cxt, $cxt, 'eval(1)';
+ };
+ die $@ if $@;
+ };
+ die $@ if $@;
+}
+
+# want
+
+{
+ my $want;
+ {
+ local $@;
+ my @res = eval {
+ $want = Scope::Context->up->want;
+ };
+ die $@ if $@;
+ };
+ is $want, undef, 'want: void context';
+}
+
+{
+ local $@;
+ my $want;
+ my $scalar = eval {
+ my @res = do {
+ $want = Scope::Context->eval->want;
+ };
+ 'XXX';
+ };
+ die $@ if $@;
+ is $want, !1, 'scalar context';
+}
+
+{
+ my $want;
+ my @list = sub {
+ sub {
+ $want = Scope::Context->sub->up->want;
+ }->();
+ 'YYY';
+ }->();
+ is $want, 1, 'want: list context';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 * 3 + 2;
+
+use Scope::Context;
+
+{
+ my $flag;
+ {
+ {
+ my $up = Scope::Context->up;
+ $up->reap(sub { $flag = -1 });
+ is $flag, undef, 'reap: not yet 1';
+ $flag = 1;
+ }
+ is $flag, 1, 'reap: not yet 2';
+ $flag = 2;
+ }
+ is $flag, -1, 'reap: done';
+}
+
+{
+ our $x;
+ {
+ local $x = 1;
+ {
+ local $x = 2;
+ my $up = Scope::Context->up(2);
+ $up->localize('$x', -1);
+ is $x, 2, 'localize: not yet 1';
+ $x = 3;
+ }
+ is $x, 1, 'localize: not yet 2';
+ $x = 4;
+ }
+ is $x, -1, 'localize: done';
+}
+
+{
+ our %h;
+ {
+ local $h{x} = 1;
+ {
+ local $h{x} = 2;
+ my $up = Scope::Context->up(2);
+ $up->localize_elem('%h', 'x', -1);
+ is $h{x}, 2, 'localize_elem: not yet 1';
+ $h{x} = 3;
+ }
+ is $h{x}, 1, 'localize_elem: not yet 2';
+ $h{x} = 4;
+ }
+ is $h{x}, -1, 'localize_elem: done';
+}
+
+{
+ our %h = (x => 0);
+ {
+ local $h{x} = 1;
+ {
+ local $h{x} = 2;
+ my $up = Scope::Context->up(2);
+ $up->localize_delete('%h', 'x');
+ is $h{x}, 2, 'localize_delete: not yet 1';
+ $h{x} = 3;
+ }
+ is $h{x}, 1, 'localize_delete: not yet 2';
+ $h{x} = 4;
+ }
+ ok !exists($h{x}), 'localize_delete: done';
+}
+
+{
+ my @res = sub {
+ sub {
+ my $up = Scope::Context->sub(1);
+ $up->unwind(1, 2, 3);
+ fail 'unwind: not reached 1';
+ }->();
+ fail 'unwind: not reached 2';
+ return qw<x y z t>;
+ }->();
+ is_deeply \@res, [ 1, 2, 3 ], 'unwind: done';
+}
+
+{
+ sub outer {
+ inner(@_);
+ }
+ sub inner {
+ my $up = Scope::Context->sub(1);
+ my $name = $up->uplevel(
+ sub { (caller 0)[$_[0]] } => 3
+ );
+ is $name, 'main::outer', 'uplevel: done';
+ }
+ outer();
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 + 9;
+
+use Scope::Context;
+
+my $fail_rx = qr/^Context has expired at \Q$0\E line [0-9]+/;
+
+{
+ my $sc;
+ {
+ $sc = Scope::Context->new;
+ ok $sc->is_valid, 'freshly created context is valid';
+ ok $sc->up->is_valid, 'up context is valid as well';
+ {
+ ok $sc->is_valid, 'also valid in a subblock';
+ }
+ }
+ ok !$sc->is_valid, 'context has expired';
+
+ my @methods = qw<
+ up sub eval
+ reap localize localize_elem localize_delete unwind uplevel
+ >;
+ for my $action (@methods) {
+ local $@;
+ eval {
+ $sc->$action;
+ };
+ my $line = __LINE__-2;
+ like $@, qr/^Context has expired at \Q$0\E line \Q$line\E/,
+ "$action\->up croaks";
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+use Scope::Context;
+
+{
+ my $sc = Scope::Context->new;
+ {
+ my $block = Scope::Context->new;
+ my $up = $block->up;
+ cmp_ok $up, '==', $sc, '$up == $sc';
+ cmp_ok $block, '!=', $sc, '$block != $sc';
+ }
+}
+
+{
+ my @scs;
+ for (1, 2) {
+ push @scs, Scope::Context->new;
+ }
+ cmp_ok $scs[0], '!=', $scs[1], 'different iterations, different contextes';
+}
+
+{
+ my $here = Scope::Context->new;
+ my $dummy = bless [], 'Scope::Context::Test::DummyClass';
+ for my $rhs ($here->cxt, $dummy) {
+ local $@;
+ eval { my $res = $here == $rhs };
+ my $line = __LINE__-1;
+ like $@, qr/^Cannot compare a Scope::Context object with something else at \Q$0\E line $line/, "Scope::Context == overload does not compare with $rhs";
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Portability::Files";
+plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@;
+run_tests();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; };
+plan(skip_all => 'Test::Kwalitee not installed') if $@;
+
+SKIP: {
+ eval { Test::Kwalitee->import(); };
+ if (my $err = $@) {
+ 1 while chomp $err;
+ require Test::Builder;
+ my $Test = Test::Builder->new;
+ my $plan = $Test->has_plan;
+ $Test->skip_all($err) if not defined $plan or $plan eq 'no_plan';
+ skip $err => $plan - $Test->current_test;
+ }
+}
projects / perl / modules / Scope-Context.git / commitdiff