From 510177ab19f8f940bf8d8965d5b10c1cd7a598d0 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 11:39:58 +0000 Subject: perl-Devel-LexAlias-0.05 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..2d75a56 --- /dev/null +++ b/Changes @@ -0,0 +1,6 @@ +0.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 diff --git a/LexAlias.pm b/LexAlias.pm new file mode 100644 index 0000000..e1752ba --- /dev/null +++ b/LexAlias.pm @@ -0,0 +1,100 @@ +package 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 diff --git a/LexAlias.xs b/LexAlias.xs new file mode 100644 index 0000000..ca90748 --- /dev/null +++ b/LexAlias.xs @@ -0,0 +1,50 @@ +#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); + } + } + } +} diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..59680a6 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,8 @@ +Changes +MANIFEST +META.yml +META.json +Makefile.PL +LexAlias.pm +LexAlias.xs +t/Devel-LexAlias.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..b1963b4 --- /dev/null +++ b/META.yml @@ -0,0 +1,23 @@ +--- #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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..697033c --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,14 @@ +use 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, + }, +); diff --git a/t/Devel-LexAlias.t b/t/Devel-LexAlias.t new file mode 100644 index 0000000..ee80c4d --- /dev/null +++ b/t/Devel-LexAlias.t @@ -0,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;