1. Toby Inkster
  2. p5-lexical-underscore

Commits

Toby Inkster  committed c52891f

initial version

  • Participants
  • Branches default

Comments (0)

Files changed (16)

File Makefile.PL

View file
+use inc::Module::Package 'RDF:tobyink 0.009';
+
+dynamic_config;
+requires(PadWalker => 0) if $] >= 5.009;

File lib/lexical/underscore.pm

View file
+package lexical::underscore;
+
+use 5.008;
+use strict;
+use warnings;
+
+BEGIN {
+	$lexical::underscore::AUTHORITY = 'cpan:TOBYINK';
+	$lexical::underscore::VERSION   = '0.001';
+}
+
+use if $] >= 5.009, PadWalker => qw( peek_my );
+BEGIN {
+	*peek_my = sub { +{} } unless __PACKAGE__->can('peek_my');
+}
+
+sub lexical::underscore
+{	
+	my $level = @_ ? shift : 0;
+	my $lexicals = peek_my($level + 2);
+	exists $lexicals->{'$_'} ? $lexicals->{'$_'} : \$_;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+lexical::underscore - access your caller's lexical underscore
+
+=head1 SYNOPSIS
+
+   use 5.010;
+   use lexical::underscore;
+   use Test::More;
+   
+   sub is_uppercase {
+      my $var = @_ ? shift : ${lexical::underscore()};
+      return $var eq uc($var);
+   }
+   
+   my $thing = 'FOO';
+   my $works = 0;
+   
+   given ( $thing ) {
+      when ( is_uppercase ) { $works++ }
+   }
+   
+   ok($works);
+   done_testing();
+
+=head1 DESCRIPTION
+
+Starting with Perl 5.10, it is possible to create a lexical version of the Perl
+default variable C<< $_ >>. Certain Perl constructs like the C<given> keyword
+automatically use a lexical C<< $_ >> rather than the global C<< $_ >>.
+
+It is occasionallly useful for a sub to be able to access its caller's
+C<< $_ >> variable regardless of whether it was lexical or not. The C<< (_) >>
+sub prototype is the official way to do so, however there are sometimes
+disadvantages to this; in particular it can only appear as the final required
+argument in a prototype, and there is no way of the sub differentiating between
+an explicitly passed argument and C<< $_ >>.
+
+This caused me problems with L<Scalar::Does>, because I wanted to enable the
+C<does> function to be called as either:
+
+   does($thing, $role);
+   does($role);  # assumes $thing = $_
+
+With C<< _ >> in the prototype, C<< $_ >> was passed to the function at the end
+of its argument list; effectively C<< does($role, $thing) >>, making it
+impossible to tell which argument was the role.
+
+Enter C<lexical::underscore> which allows you to access your caller's lexical
+C<< $_ >> variable as easily as:
+
+   ${lexical::underscore()}
+
+You can access lexical C<< $_ >> further up the call stack using:
+
+   ${lexical::underscore($level)}
+
+If you happen to ask for C<< $_ >> at a level where no lexical C<< $_ >> is
+available, you get the global C<< $_ >> instead.
+
+This module does work on Perl 5.8 but as there is no lexical C<< $_ >>, always
+returns the global C<< $_ >>.
+
+=head2 Technical Details
+
+The C<lexical::underscore> function returns a scalar reference to either a
+lexical C<< $_ >> variable somewhere up the call stack (using L<PadWalker>
+magic), or to the global C<< $_ >> if there was no lexical version.
+
+Wrapping C<lexical::underscore> in C<< ${ ... } >> dereferences the scalar
+reference, allowing you to access (and even assign to) it.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=lexical-underscore>.
+
+=head1 SEE ALSO
+
+L<PadWalker>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

File meta/changes.pret

View file
+# This file acts as the project's changelog.
+
+`lexical-underscore 0.001 cpan:TOBYINK`
+	issued  2012-11-11;
+	label   "Initial release".
+

File meta/doap.pret

View file
+# This file contains general metadata about the project.
+
+@prefix : <http://usefulinc.com/ns/doap#>.
+
+`lexical-underscore`
+	:programming-language "Perl" ;
+	:shortdesc            "access your caller's lexical underscore";
+	:homepage             <https://metacpan.org/release/lexical-underscore>;
+	:download-page        <https://metacpan.org/release/lexical-underscore>;
+	:bug-database         <http://rt.cpan.org/Dist/Display.html?Queue=lexical-underscore>;
+	:repository           [ a :HgRepository; <https://bitbucket.org/tobyink/p5-lexical-underscore> ];
+	:created              2012-11-11;
+	:license              <http://dev.perl.org/licenses/>;
+	:maintainer           cpan:TOBYINK;
+	:developer            cpan:TOBYINK.
+
+<http://dev.perl.org/licenses/>
+	dc:title  "the same terms as the perl 5 programming language system itself".
+

File meta/makefile.pret

View file
+# This file provides instructions for packaging.
+
+`lexical-underscore`
+	perl_version_from m`lexical::underscore`;
+	version_from      m`lexical::underscore`;
+	readme_from       m`lexical::underscore`;
+	test_requires     p`Test::More 0.61`;
+.
+

File meta/people.pret

View file
+# This file contains data about the project developers.
+
+@prefix : <http://xmlns.com/foaf/0.1/>.
+
+cpan:TOBYINK
+	:name  "Toby Inkster";
+	:mbox  <mailto:tobyink@cpan.org>.
+

File t/01basic.t

View file
+use Test::More;
+BEGIN {
+	$] >= 5.010 or plan skip_all => "test requires Perl 5.010";
+	plan tests => 6;
+};
+
+use lexical::underscore;
+
+sub foo {
+	my $_ = 101;
+	bar();
+	is($_, 42);
+}
+
+sub bar {
+	$_ = 102;
+	baz();
+}
+
+sub baz {
+	my $_ = 103;
+	quux();
+}
+
+sub quux {
+	my $_ = 104;
+	
+	is(${ lexical::underscore() }, 103);
+	is(${ lexical::underscore(-1) }, 104);
+	is(${ lexical::underscore(0) }, 103);
+	is(${ lexical::underscore(1) }, 102);
+	is(${ lexical::underscore(2) }, 101);
+	
+	${ lexical::underscore(2) } = 42;
+}
+
+foo();

File t/02synopsis.t

View file
+use Test::More;
+BEGIN {
+	$] >= 5.010 or plan skip_all => "test requires Perl 5.010";
+};
+
+	use 5.010;
+	use lexical::underscore;
+	#use Test::More;
+	
+	sub is_uppercase {
+		my $var = @_ ? shift : ${lexical::underscore()};
+		return $var eq uc($var);
+	}
+	
+	my $thing = 'FOO';
+	my $works = 0;
+	
+	given ( $thing ) {
+		when ( is_uppercase ) { $works++ }
+	}
+	
+	ok($works);
+	done_testing();

File t/03perl58.t

View file
+# There is no lexical underscore on Perl 5.8 but the module
+# should fall back to the global underscore.
+#
+
+use Test::More;
+BEGIN {
+	plan tests => 6;
+};
+
+use lexical::underscore;
+
+sub foo {
+	$_ = 101;
+	bar();
+	is($_, 42);
+}
+
+sub bar {
+	$_ = 102;
+	baz();
+}
+
+sub baz {
+	$_ = 103;
+	quux();
+}
+
+sub quux {
+	$_ = 104;
+	
+	is(${ lexical::underscore() }, 104);
+	is(${ lexical::underscore(-1) }, 104);
+	is(${ lexical::underscore(0) }, 104);
+	is(${ lexical::underscore(1) }, 104);
+	is(${ lexical::underscore(2) }, 104);
+	
+	${ lexical::underscore(2) } = 42;
+}
+
+foo();

File xt/01pod.t

View file
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

File xt/02pod_coverage.t

View file
+use XT::Util;
+use Test::More;
+use Test::Pod::Coverage;
+
+plan skip_all => __CONFIG__->{skip_all}
+	if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+	my @modules = @{ __CONFIG__->{modules} };
+	pod_coverage_ok($_, "$_ is covered") for @modules;
+	done_testing(scalar @modules);
+}
+else
+{
+	all_pod_coverage_ok();
+}
+

File xt/03meta_uptodate.config

View file
+{"package":"lexical-underscore"}
+

File xt/03meta_uptodate.t

View file
+use XT::Util;
+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok(__CONFIG__->{package}, __CONFIG__->{version_from});
+

File xt/04eol.t

View file
+use Test::EOL;
+all_perl_files_ok();

File xt/05tabs.t

View file
+use Test::Tabs;
+all_perl_files_ok();

File xt/06versions.t

View file
+use XT::Util;
+use Test::More;
+use Test::HasVersion;
+
+plan skip_all => __CONFIG__->{skip_all}
+	if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+	my @modules = @{ __CONFIG__->{modules} };
+	pm_version_ok($_, "$_ is covered") for @modules;
+	done_testing(scalar @modules);
+}
+else
+{
+	all_pm_version_ok();
+}
+