r6863 - in /branches/upstream/libdevel-lexalias-perl: ./ current/ current/LexAlias.pm current/LexAlias.xs current/MANIFEST current/Makefile.PL current/README current/t/ current/t/Devel-LexAlias.t
sukria at users.alioth.debian.org
sukria at users.alioth.debian.org
Fri Aug 17 19:40:24 UTC 2007
Author: sukria
Date: Fri Aug 17 19:40:24 2007
New Revision: 6863
URL: http://svn.debian.org/wsvn/?sc=1&rev=6863
Log:
[svn-inject] Installing original source of libdevel-lexalias-perl
Added:
branches/upstream/libdevel-lexalias-perl/
branches/upstream/libdevel-lexalias-perl/current/
branches/upstream/libdevel-lexalias-perl/current/LexAlias.pm
branches/upstream/libdevel-lexalias-perl/current/LexAlias.xs
branches/upstream/libdevel-lexalias-perl/current/MANIFEST
branches/upstream/libdevel-lexalias-perl/current/Makefile.PL
branches/upstream/libdevel-lexalias-perl/current/README
branches/upstream/libdevel-lexalias-perl/current/t/
branches/upstream/libdevel-lexalias-perl/current/t/Devel-LexAlias.t
Added: branches/upstream/libdevel-lexalias-perl/current/LexAlias.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-lexalias-perl/current/LexAlias.pm?rev=6863&op=file
==============================================================================
--- branches/upstream/libdevel-lexalias-perl/current/LexAlias.pm (added)
+++ branches/upstream/libdevel-lexalias-perl/current/LexAlias.pm Fri Aug 17 19:40:24 2007
@@ -1,0 +1,100 @@
+package Devel::LexAlias;
+require DynaLoader;
+use Devel::Caller qw(caller_cv);
+
+require 5.005003;
+
+ at ISA = qw(Exporter DynaLoader);
+ at EXPORT_OK = qw(lexalias);
+
+$VERSION = '0.04';
+
+bootstrap Devel::LexAlias $VERSION;
+
+sub lexalias {
+ my $cv = shift;
+ unless (ref $cv eq 'CODE') {
+ $cv = caller_cv($cv + 1);
+ }
+
+ return _lexalias($cv, @_);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Devel::LexAlias - alias lexical variables
+
+=head1 SYNOPSIS
+
+ use Devel::LexAlias qw(lexalias);
+
+ sub steal_my_x {
+ my $foo = 1;
+ lexalias(1, '$x', \$foo);
+ }
+
+ sub foo {
+ my $x = 22;
+ print $x; # prints 22
+
+ steal_my_x;
+ print $x; # prints 1
+ }
+
+=head1 DESCRIPTION
+
+Devel::LexAlias provides the ability to alias a lexical variable in a
+subroutines scope to one of your choosing.
+
+If you don't know why you'd want to do this, I'd suggest that you skip
+this module. If you think you have a use for it, I'd insist on it.
+
+Still here?
+
+=over
+
+=item lexalias( $where, $name, $variable )
+
+C<$where> refers to the subroutine in which to alias the lexical, it
+can be a coderef or a call level such that you'd give to C<caller>
+
+C<$name> is the name of the lexical within that subroutine
+
+C<$variable> is a reference to the variable to install at that location
+
+=back
+
+=head1 BUGS
+
+lexalias delves into the internals of the interpreter to perform its
+actions and is so very sensitive to bad data, which will likely result
+in flaming death, or a core dump. Consider this a warning.
+
+There is no checking that you are attaching a suitable variable back
+into the pad as implied by the name of the variable, so it is possible
+to do the following:
+
+ lexalias( $sub, '$foo', [qw(an array)] );
+
+The behaviour of this is untested, I imagine badness is very close on
+the horizon though.
+
+=head1 SEE ALSO
+
+peek_sub from L<PadWalker>, L<Devel::Peek>
+
+=head1 AUTHOR
+
+Richard Clamp E<lt>richardc at unixbeard.netE<gt> with close reference to
+PadWalker by Robin Houston
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002, Richard Clamp. All Rights Reserved. This module
+is free software. It may be used, redistributed and/or modified under
+the same terms as Perl itself.
+
+=cut
Added: branches/upstream/libdevel-lexalias-perl/current/LexAlias.xs
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-lexalias-perl/current/LexAlias.xs?rev=6863&op=file
==============================================================================
--- branches/upstream/libdevel-lexalias-perl/current/LexAlias.xs (added)
+++ branches/upstream/libdevel-lexalias-perl/current/LexAlias.xs Fri Aug 17 19:40:24 2007
@@ -1,0 +1,40 @@
+/* $Id: LexAlias.xs,v 1.7 2002/07/25 14:25:22 richardc Exp $ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* cargo-culted from PadWalker */
+
+MODULE = Devel::LexAlias PACKAGE = Devel::LexAlias
+
+void
+_lexalias(SV* cv_ref, char *name, SV* new_rv)
+ CODE:
+{
+ CV *cv = SvROK(cv_ref) ? (CV*) SvRV(cv_ref) : NULL;
+ AV* padn = cv ? (AV*) AvARRAY(CvPADLIST(cv))[0] : PL_comppad_name;
+ AV* padv = cv ? (AV*) AvARRAY(CvPADLIST(cv))[1] : PL_comppad;
+ SV* new_sv;
+ I32 i;
+
+ if (!SvROK(new_rv)) croak("ref is not a reference");
+ new_sv = SvRV(new_rv);
+
+ for (i = 0; i <= av_len(padn); ++i) {
+ SV** name_ptr = av_fetch(padn, i, 0);
+ if (name_ptr) {
+ SV* name_sv = *name_ptr;
+
+ if (SvPOKp(name_sv)) {
+ char *name_str = SvPVX(name_sv);
+
+ if (!strcmp(name, name_str)) {
+ SV* old_sv = (SV*) av_fetch(padv, i, 0);
+ av_store(padv, i, new_sv);
+ SvREFCNT_inc(new_sv);
+ }
+ }
+ }
+ }
+}
Added: branches/upstream/libdevel-lexalias-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-lexalias-perl/current/MANIFEST?rev=6863&op=file
==============================================================================
--- branches/upstream/libdevel-lexalias-perl/current/MANIFEST (added)
+++ branches/upstream/libdevel-lexalias-perl/current/MANIFEST Fri Aug 17 19:40:24 2007
@@ -1,0 +1,6 @@
+README
+MANIFEST
+Makefile.PL
+LexAlias.pm
+LexAlias.xs
+t/Devel-LexAlias.t
Added: branches/upstream/libdevel-lexalias-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-lexalias-perl/current/Makefile.PL?rev=6863&op=file
==============================================================================
--- branches/upstream/libdevel-lexalias-perl/current/Makefile.PL (added)
+++ branches/upstream/libdevel-lexalias-perl/current/Makefile.PL Fri Aug 17 19:40:24 2007
@@ -1,0 +1,15 @@
+use ExtUtils::MakeMaker;
+my $module = 'LexAlias.pm';
+WriteMakefile(
+ 'NAME' => 'Devel::LexAlias',
+ 'VERSION_FROM' => $module,
+ 'PREREQ_PM' => { 'Test::More' => 0,
+ 'Devel::Caller' => 0.03 },
+ );
+
+sub MY::postamble {
+ return <<EOF
+README: $module
+\tpod2text $module > README
+EOF
+}
Added: branches/upstream/libdevel-lexalias-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-lexalias-perl/current/README?rev=6863&op=file
==============================================================================
--- branches/upstream/libdevel-lexalias-perl/current/README (added)
+++ branches/upstream/libdevel-lexalias-perl/current/README Fri Aug 17 19:40:24 2007
@@ -1,0 +1,62 @@
+NAME
+ Devel::LexAlias - alias lexical variables
+
+SYNOPSIS
+ use Devel::LexAlias qw(lexalias);
+
+ sub steal_my_x {
+ my $foo = 1;
+ lexalias(1, '$x', \$foo);
+ }
+
+ sub foo {
+ my $x = 22;
+ print $x; # prints 22
+
+ steal_my_x;
+ print $x; # prints 1
+ }
+
+DESCRIPTION
+ Devel::LexAlias provides the ability to alias a lexical variable in a
+ subroutines scope to one of your choosing.
+
+ If you don't know why you'd want to do this, I'd suggest that you skip
+ this module. If you think you have a use for it, I'd insist on it.
+
+ Still here?
+
+ lexalias( $where, $name, $variable )
+ $where refers to the subroutine in which to alias the lexical, it
+ can be a coderef or a call level such that you'd give to "caller"
+
+ $name is the name of the lexical within that subroutine
+
+ $variable is a reference to the variable to install at that location
+
+BUGS
+ lexalias delves into the internals of the interpreter to perform its
+ actions and is so very sensitive to bad data, which will likely result
+ in flaming death, or a core dump. Consider this a warning.
+
+ There is no checking that you are attaching a suitable variable back
+ into the pad as implied by the name of the variable, so it is possible
+ to do the following:
+
+ lexalias( $sub, '$foo', [qw(an array)] );
+
+ The behaviour of this is untested, I imagine badness is very close on
+ the horizon though.
+
+SEE ALSO
+ peek_sub from PadWalker, Devel::Peek
+
+AUTHOR
+ Richard Clamp <richardc at unixbeard.net> with close reference to PadWalker
+ by Robin Houston
+
+COPYRIGHT
+ Copyright (c) 2002, Richard Clamp. All Rights Reserved. This module is
+ free software. It may be used, redistributed and/or modified under the
+ same terms as Perl itself.
+
Added: branches/upstream/libdevel-lexalias-perl/current/t/Devel-LexAlias.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-lexalias-perl/current/t/Devel-LexAlias.t?rev=6863&op=file
==============================================================================
--- branches/upstream/libdevel-lexalias-perl/current/t/Devel-LexAlias.t (added)
+++ branches/upstream/libdevel-lexalias-perl/current/t/Devel-LexAlias.t Fri Aug 17 19:40:24 2007
@@ -1,0 +1,72 @@
+#!perl -w
+use strict;
+use Test::More tests => 11;
+
+use Devel::LexAlias qw(lexalias);
+
+# testing for predictive destruction. especially around ithreads
+my $expect;
+sub Foo::DESTROY {
+ my ($destroyed) = @{ shift() };
+ is( $destroyed, $expect, "expected destruction of $expect" );
+}
+
+sub inner {
+ my $inner = bless ['$inner'], 'Foo';
+ $expect = '$outer';
+ lexalias(1, '$outer', \$inner);
+ $expect = '';
+}
+
+sub outer {
+ my $outer = bless [ '$outer' ], 'Foo';
+ inner;
+ is ( $outer->[0], '$inner', "alias worked" );
+ $expect = '$inner';
+}
+outer;
+
+sub steal_foo {
+ my $foo = 1;
+ lexalias(\&foo, '$x', \$foo);
+ lexalias(\&foo, '@y', [qw( foo bar baz )]);
+
+ eval { lexalias(\&foo, '$x', $foo) };
+ ok( $@, "blew an error" );
+ like( $@, qr/^ref is not a reference/, "useful error" );
+}
+
+sub bar {
+ my $foo = 2;
+ lexalias(2, '$x', \$foo);
+}
+
+sub steal_above {
+ bar();
+ lexalias(1, '@y', [qw( foo bar bray )]);
+}
+
+
+sub foo {
+ my $x = 22;
+ my @y = qw( a b c );
+
+ is( $x, 22, "x before" );
+ is_deeply( \@y, [qw( a b c )], "y before" );
+
+ steal_foo;
+
+ is( $x, 1, "x after" );
+ is_deeply( \@y, [qw( foo bar baz )], "y after" );
+
+ steal_above;
+
+ is( $x, 2, "x above after" );
+ is_deeply( \@y, [qw( foo bar bray )], "y after" );
+
+}
+
+foo;
+print "# out of foo\n";
+
+exit 0;
More information about the Pkg-perl-cvs-commits
mailing list