Devel-LexAlias-0.05/0000755000175000017500000000000012075512114014313 5ustar richardcrichardcDevel-LexAlias-0.05/Changes0000644000175000017500000000032112075512015015602 0ustar richardcrichardc0.05 Wednesday 16th January, 2013 Apply fix for DEBUGGING perls from Reini Urban RT#74862 Apply rewrite for 5.17 pad reorganiztion from ? RT#79267 0.04 25th July, 2002 Initial release Devel-LexAlias-0.05/t/0000755000175000017500000000000012075512114014556 5ustar richardcrichardcDevel-LexAlias-0.05/t/Devel-LexAlias.t0000644000175000017500000000247712075502541017517 0ustar richardcrichardc#!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; Devel-LexAlias-0.05/Makefile.PL0000644000175000017500000000055112075512015016266 0ustar richardcrichardcuse strict; use ExtUtils::MakeMaker; my $module = 'LexAlias.pm'; WriteMakefile( 'NAME' => 'Devel::LexAlias', 'VERSION_FROM' => $module, 'ABSTRACT_FROM' => $module, 'AUTHOR' => 'Richard Clamp ', 'LICENSE' => 'perl', 'PREREQ_PM' => { 'Test::More' => 0, 'Devel::Caller' => 0.03, }, ); Devel-LexAlias-0.05/MANIFEST0000644000175000017500000000013312075512015015441 0ustar richardcrichardcChanges MANIFEST META.yml META.json Makefile.PL LexAlias.pm LexAlias.xs t/Devel-LexAlias.t Devel-LexAlias-0.05/LexAlias.xs0000644000175000017500000000267012075512015016376 0ustar richardcrichardc#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef PadARRAY typedef AV PADNAMELIST; typedef SV PADNAME; # if PERL_VERSION < 8 || (PERL_VERSION == 8 && !PERL_SUBVERSION) typedef AV PAD; # endif # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) # define PadlistNAMES(pl) (*PadlistARRAY(pl)) # define PadnamelistARRAY(pnl) ((PADNAME **)AvARRAY(pnl)) # define PadnamelistMAX(pnl) AvFILLp(pnl) # define PadARRAY AvARRAY # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) #endif /* 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; PADNAMELIST* padn = cv ? PadlistNAMES(CvPADLIST(cv)) : PL_comppad_name; PAD* padv = cv ? PadlistARRAY(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 <= PadnamelistMAX(padn); ++i) { PADNAME* namesv = PadnamelistARRAY(padn)[i]; char* name_str; if (namesv && (name_str = PadnamePV(namesv))) { if (!strcmp(name, name_str)) { SvREFCNT_dec(PadARRAY(padv)[i]); PadARRAY(padv)[i] = new_sv; SvREFCNT_inc(new_sv); SvPADMY_on(new_sv); } } } } Devel-LexAlias-0.05/LexAlias.pm0000644000175000017500000000415212075512015016355 0ustar richardcrichardcpackage Devel::LexAlias; require DynaLoader; use Devel::Caller qw(caller_cv); require 5.005003; @ISA = qw(Exporter DynaLoader); @EXPORT_OK = qw(lexalias); $VERSION = '0.05'; 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 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, L =head1 AUTHOR Richard Clamp Erichardc@unixbeard.netE with close reference to PadWalker by Robin Houston =head1 COPYRIGHT Copyright (c) 2002, 2013, 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 Devel-LexAlias-0.05/META.yml0000664000175000017500000000110212075512114015560 0ustar richardcrichardc--- #YAML:1.0 name: Devel-LexAlias version: 0.05 abstract: alias lexical variables author: - Richard Clamp license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Devel::Caller: 0.03 Test::More: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4