Data-Alias-1.21/0000755000175000017500000000000013212443455012672 5ustar zeframzeframData-Alias-1.21/.gitignore0000644000175000017500000000013712242751153014662 0ustar zeframzefram/Makefile /pm_to_blib /blib /MYMETA.json /MYMETA.yml /Data-Alias-* /Alias.c /Alias.o /Alias.bs Data-Alias-1.21/MANIFEST0000644000175000017500000000174612217331164014030 0ustar zeframzefram.gitignore Alias.xs Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Data/Alias.pm Makefile.PL MANIFEST META.yml README t/01_deref.t t/03_copy.t t/04_alias_parse.t t/04_swap.t t/05_alias_parse2.t t/06_alias_scope.t t/07_alias_anon_array.t t/08_alias_anon_hash.t t/09_alias_push.t t/10_alias_unshift.t t/11_alias_splice.t t/12_alias_pkg_scalar.t t/13_alias_pkg_array.t t/14_alias_pkg_hash.t t/15_alias_pkg_misc.t t/16_alias_refs.t t/17_alias_lex_inner.t t/19_alias_aelem.t t/20_alias_helem.t t/21_alias_list_basic.t t/22_alias_list_slice.t t/23_alias_list_whole.t t/24_alias_cond.t t/25_alias_weakref.t t/26_alias_local.t t/28_alias_const.t t/29_alias_dorassign.t t/devel_callparser.t t/lib/assign.pm t/lib/Test/Builder.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/padrange.t t/pod_cvg.t t/pod_syn.t t/threads.t Data-Alias-1.21/Makefile.PL0000644000175000017500000000062011661277703014651 0ustar zeframzeframuse inc::Module::Install; use Config; my %fussy_OS = ( MSWin32 => "Win32", aix => "AIX", ); $fussy_OS{$^O} and $] < 5.008009 and die "ERROR: [OS unsupported] " . "Data::Alias on $fussy_OS{$^O} requires perl 5.8.9 or later.\n"; name 'Data-Alias'; all_from 'lib/Data/Alias.pm'; die "ERROR: Data::Alias does not support old 5.005-style threads\n" if $Config{use5005threads}; WriteAll; Data-Alias-1.21/META.yml0000644000175000017500000000064613212443276014152 0ustar zeframzefram--- abstract: Comprehensive set of aliasing operations author: - 'Matthijs van Duin ' - 'Andrew Main (Zefram) ' distribution_type: module generated_by: Module::Install version 0.67 license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 name: Data-Alias no_index: directory: - inc - t requires: perl: 5.8.1 version: 1.21 Data-Alias-1.21/README0000644000175000017500000000204313212443366013552 0ustar zeframzeframNAME Data::Alias - Comprehensive set of aliasing operations DESCRIPTION Aliasing is the phenomenon where two different expressions actually refer to the same thing. Modifying one will modify the other, and if you take a reference to both, the two values are the same. Data::Alias is a module that allows you to apply "aliasing semantics" to a section of code, causing aliases to be made whereever Perl would normally make copies instead. You can use this to improve efficiency and readability, when compared to using references. INSTALLATION perl Makefile.PL make make test make install AUTHOR Matthijs van Duin developed the module originally, and maintained it until 2007. Andrew Main (Zefram) updated it to work with Perl versions 5.11.0 and later. COPYRIGHT Copyright (C) 2003-2007 Matthijs van Duin. Copyright (C) 2010, 2011, 2013, 2015, 2017 Andrew Main (Zefram) . LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-Alias-1.21/lib/0000755000175000017500000000000013212443455013440 5ustar zeframzeframData-Alias-1.21/lib/Data/0000755000175000017500000000000013212443455014311 5ustar zeframzeframData-Alias-1.21/lib/Data/Alias.pm0000644000175000017500000003532213212443360015700 0ustar zeframzeframpackage Data::Alias; use 5.008001; use strict; use warnings; our $VERSION = '1.21'; use base 'Exporter'; use base 'DynaLoader'; our @EXPORT = qw(alias); our @EXPORT_OK = qw(alias copy deref); our %EXPORT_TAGS = (all => \@EXPORT_OK); bootstrap Data::Alias $VERSION; pop our @ISA; =head1 NAME Data::Alias - Comprehensive set of aliasing operations =head1 SYNOPSIS use Data::Alias; alias { # aliasing instead of copying whenever possible }; alias $x = $y; # alias $x to $y alias @x = @y; # alias @x to @y alias $x[0] = $y; # similar for array and hash elements alias push @x, $y; # push alias to $y onto @x $x = alias [ $y, $z ]; # construct array of aliases alias my ($x, $y) = @_; # named aliases to arguments alias { ($x, $y) = ($y, $x) }; # swap $x and $y alias { my @t = @x; @x = @y; @y = @t }; # swap @x and @y use Data::Alias qw/ alias copy /; alias { copy $x = $y }; # force copying inside alias-BLOCK use Data::Alias qw/ deref /; my @refs = (\$x, \@y, \%z); foo(deref @refs) # same as foo($x, @y, %z) =head1 DESCRIPTION Aliasing is the phenomenon where two different expressions actually refer to the same thing. Modifying one will modify the other, and if you take a reference to both, the two values are the same. Aliasing occurs in Perl for example in for-loops and sub-calls: for $var ($x) { # here $var is an alias to $x } foo($y); sub foo { # here $_[0] is an alias to $y } Data::Alias is a module that allows you to apply "aliasing semantics" to a section of code, causing aliases to be made wherever Perl would normally make copies instead. You can use this to improve efficiency and readability, when compared to using references. The exact details of aliasing semantics are below under L. Perl 5.22 added some support for aliasing to the Perl core. It has a different syntax, and a different set of operations, from that supplied by this module; see L. The core's aliasing facilities are implemented more robustly than this module and are better supported. If you can rely on having a sufficiently recent Perl version, you should prefer to use the core facility rather than use this module. If you are already using this module and are now using a sufficiently recent Perl, you should attempt to migrate to the core facility. =head1 SYNTAX =head2 alias I | alias I Exported by default. Enables aliasing semantics within the expression or block. Returns an alias to the expression, or the block's return value. C is context-transparent, meaning that whichever context it is placed in (list, scalar, void), the expression/block is evaluated in the same context. =head2 copy I | copy I Restores normal (copying) semantics within the expression or block, and makes a copy of the result value (unless in void context). Like C, C is context-transparent. =head2 deref I Accepts a list of references to scalars, arrays, or hashes. Applies the applicable dereferencing operator to each. This means that: deref $scalarref, $arrayref, $hashref behaves like: $$scalarref, @$arrayref, %$hashref Where an array or hash reference is given, the returned list does not include the array or hash as an lvalue; the array/hash is expanded and the list includes its elements. Scalars, including the elements of an array/hash, I treated as lvalues, and can be enreferenced using the C<\> operator or aliased to using the C operator. This is slightly different from what you'd get using the built-in dereference operators: C<@$arrayref> references the array as an lvalue, so C<\> or C can operate on the array itself rather than just its elements. =head1 EXAMPLES A common usage of aliasing is to make an abbreviation for an expression, to avoid having to repeat that (possibly verbose or ugly) expression over and over: alias my $fi = $self->{FrobnitzIndex}; $fi = $fi > 0 ? $fi - $adj : $fi + $adj; sub rc4 { alias my ($i, $j, $S) = @_; my $a = $S->[($i += 1) &= 255]; my $b = $S->[($j += $S->[$i]) &= 255]; $S->[(($S->[$j] = $a) + ($S->[$i] = $b)) & 255] } In the second example, the rc4 function updates its first two arguments (two state values) in addition to returning a value. Aliasing can also be used to avoid copying big strings. This example would work fine without C but would be much slower when passed a big string: sub middlesection ($) { alias my $s = shift; substr $s, length($s)/4, length($s)/2 } You can also apply aliasing semantics to an entire block. Here this is used to swap two arrays in O(1) time: alias { my @temp = @x; @x = @y; @y = @temp; }; The C function is typically used to temporarily reinstate normal semantics, but can also be used to explicitly copy a value when perl would normally not do so: my $ref = \copy $x; =head1 DETAILS This section describes exactly what the aliasing semantics are of operations. Anything not listed below has unaltered behaviour. =over 4 =item scalar assignment to variable or element. Makes the left-side of the assignment an alias to the right-side expression, which can be anything. alias my $lexvar = $foo; alias $pkgvar = $foo; alias $array[$i] = $foo; alias $hash{$k} = $foo; An attempt to do alias-assignment to an element of a tied (or "magical") array or hash will result in a "Can't put alias into tied array/hash" error. =item scalar assignment to dereference If $ref is a reference or undef, this simply does C<$ref = \$foo>. Otherwise, the indicated package variable (via glob or symbolic reference) is made an alias to the right-side expression. alias $$ref = $foo; =item scalar assignment to glob Works mostly the same as normal glob-assignment, however it does not set the import-flag. (If you don't know what this means, you probably don't care) alias *glob = $reference; =item scalar assignment to anything else Not supported. alias substr(...) = $foo; # ERROR! alias lvalsub() = $foo; # ERROR! =item conditional scalar assignment Here C<$var> (and C<$var2>) are aliased to C<$foo> if the applicable condition is satisfied. C<$bool> and C<$foo> can be any expression. C<$var> and C<$var2> can be anything that is valid on the left-side of an alias-assignment. alias $bool ? $var : $var2 = $foo; alias $var &&= $foo; alias $var ||= $foo; alias $var //= $foo; # (perl 5.9.x or later) =item whole aggregate assignment from whole aggregate This occurs where the expressions on both sides of the assignment operator are purely complete arrays or hashes. The entire aggregate is aliased, not merely the contents. This means for example that C<\@lexarray == \@foo>. alias my @lexarray = @foo; alias my %lexhash = %foo; alias @pkgarray = @foo; alias %pkghash = %foo; Making the left-side a dereference is also supported: alias @$ref = @foo; alias %$ref = %foo; and analogously to assignment to scalar dereference, these will change C<$ref> to reference the aggregate, if C<$ref> was undef or already a reference. If C<$ref> is a string or glob, the corresponding package variable is aliased. Anything more complex than a whole-aggregate expression on either side, even just enclosing the aggregate expression in parentheses, will prevent the assignment qualifying for this category. It will instead go into one of the following two categories. Parenthesisation is the recommended way to avoid whole-aggregate aliasing where it is unwanted. If you want to merely replace the contents of the left-side aggregate with aliases to the contents of the right-side aggregate, parenthesise the left side. =item whole aggregate assignment from list If the left-side expression is purely a complete array or hash, and the right-side expression is not purely a matching aggregate, then a new aggregate is implicitly constructed. This means: alias my @lexfoo = (@foo); alias my @array = ($x, $y, $z); alias my %hash = (x => $x, y => $y); is translated to: alias my @lexfoo = @{ [@foo] }; alias my @array = @{ [$x, $y, $z] }; alias my %hash = %{ {x => $x, y => $y} }; If you want to merely replace the contents of the aggregate with aliases to the contents of another aggregate, rather than create a new aggregate, you can force list-assignment by parenthesizing the left side, see below. =item list assignment List assignment is any assignment where the left-side is an array-slice, hash-slice, or list in parentheses. This behaves essentially like many scalar assignments in parallel. alias my (@array) = ($x, $y, $z); alias my (%hash) = (x => $x, y => $y); alias my ($x, $y, @rest) = @_; alias @x[0, 1] = @x[1, 0]; Any scalars that appear on the left side must be valid targets for scalar assignment. When an array or hash appears on the left side, normally as the last item, its contents are replaced by the list of all remaining right-side elements. C can also appear on the left side to skip one corresponding item in the right-side list. Beware when putting a parenthesised list on the left side. Just like Perl parses C as C<(print(1+2))*10>, it would parse C as C<(alias($x, $y)) = ($y, $x)> which does not do any aliasing, and results in the "Useless use of alias" warning, if warnings are enabled. To circumvent this issue, you can either one of the following: alias +($x, $y) = ($y, $x); alias { ($x, $y) = ($y, $x) }; =item Anonymous aggregate constructors Return a reference to a new anonymous array or hash, populated with aliases. This means that for example C<\$hashref-E{x} == \$x>. my $arrayref = alias [$x, $y, $z]; my $hashref = alias {x => $x, y => $y}; Note that this also works: alias my $arrayref = [$x, $y, $z]; alias my $hashref = {x => $x, y => $y}; but this makes the lhs an alias to the temporary, and therefore read-only, reference made by C<[]> or C<{}>. Therefore later attempts to assign to C<$arrayref> or C<$hashref> results in an error. The anonymous aggregate that is referenced behaves the same in both cases obviously. =item Array insertions These work as usual, except the inserted elements are aliases. alias push @array, $foo; alias unshift @array, $foo; alias splice @array, 1, 2, $foo; An attempt to do any of these on tied (or "magical") array will result in a "Can't push/unshift/splice alias onto tied array" error. =item Returning an alias Returns aliases from the current C or C. Normally this only happens for lvalue subs, but C can be used in any sub. Lvalue subs only work for scalar return values, but C can handle a list of return values. A sub call will very often copy the return value(s) immediately after they have been returned. C can't prevent that. To pass an alias through a sub return and into something else, the call site must process the return value using an aliasing operation, or at least a non-copying one. For example, ordinary assignment with the sub call on the right hand side will copy, but if the call site is in the scope of an C pragma then the assignment will instead alias the return value. When alias-returning a list of values from a subroutine, each individual value in the list is aliased. The list as a whole is not aliasable; it is not an array. At the call site, a list of aliases can be captured into separate variables or into an array, by an aliasing list assignment. =item Subroutines and evaluations Placing a subroutine or C inside C causes it to be compiled with aliasing semantics entirely. Additionally, the return from such a sub or eval, whether explicit using C or implicitly the last statement, will be an alias rather than a copy. alias { sub foo { $x } }; my $subref = alias sub { $x }; my $xref1 = \foo; my $xref2 = \alias eval '$x'; my $xref3 = \$subref->(); Explicitly returning an alias can also be done using C inside any subroutine or evaluation. sub foo { alias return $x; } my $xref = \foo; =item Localization Use of local inside C usually behaves the same as local does in general, however there is a difference if the variable is tied: in this case, Perl doesn't localise the variable at all but instead preserves the tie by saving a copy of the current value, and restoring this value at end of scope. alias local $_ = $string; The aliasing semantics of C avoids copying by always localizing the variable itself, regardless of whether it is tied. =back =head1 IMPLEMENTATION This module does B use a source filter, and is therefore safe to use within eval STRING. Instead, Data::Alias hooks into the Perl parser, and replaces operations within the scope of C by aliasing variants. For those familiar with perl's internals: it triggers on a ck_rv2cv which resolves to the imported C sub, and does a parser hack to allow the C syntax. When the ck_entersub is triggered that corresponds to it, the op is marked to be found later. The actual work is done in a peep-hook, which processes the marked entersub and its children, replacing the pp_addrs with aliasing replacements. The peep hook will also take care of any subs defined within the lexical (but not dynamical) scope between the ck_rv2cv and the ck_entersub. =head1 KNOWN ISSUES =over 4 =item Lexical variables When aliasing existing lexical variables, the effect is limited in scope to the current subroutine and any closures create after the aliasing is done, even if the variable itself has wider scope. While partial fixes are possible, it cannot be fixed in any reliable or consistent way, and therefore I'm keeping the current behaviour. When aliasing a lexical that was declared outside the current subroutine, a compile-time warning is generated "Aliasing of outer lexical variable has limited scope" (warnings category "closure"). =back =head1 ACKNOWLEDGEMENTS Specials thanks go to Elizabeth Mattijsen, Juerd Waalboer, and other members of the Amsterdam Perl Mongers, for their valuable feedback. =head1 AUTHOR Matthijs van Duin developed the module originally, and maintained it until 2007. Andrew Main (Zefram) updated it to work with Perl versions 5.11.0 and later. =head1 LICENSE Copyright (C) 2003-2007 Matthijs van Duin. Copyright (C) 2010, 2011, 2013, 2015, 2017 Andrew Main (Zefram) . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut __PACKAGE__ Data-Alias-1.21/Changes0000644000175000017500000001640513212443316014167 0ustar zeframzeframversion 1.21; 2017-12-08 * update for context stack changes in Perl 5.23.8 * update to accommodate PERL_OP_PARENT builds of Perl 5.21.11 or later (which is the default from Perl 5.25.1) * update for removal of LEX_KNOWNEXT in Perl 5.25.1 * update test suite to not rely on . in @INC, which is no longer necessarily there from Perl 5.25.7 * use cleaner wrap_op_checker() API to control op checking version 1.20; 2015-10-21 * bugfix: avoid some C undefined behaviour from unsequenced side effects that in practice bit when using a newer gcc (4.9 rather than 4.7) with the parser token stack change in Perl 5.21.9 * add doc note advising users to prefer the core aliasing facility on Perl 5.22 version 1.19; 2015-10-21 * bugfix: properly maintain op_last when munging ops * update for the parser's PL_expect changes in Perl 5.21.4 * update for op_private stricture in Perl 5.21.4 * update for sub references directly in stash in Perl 5.21.4 * update for IS_PADGV()'s limited visibility in Perl 5.21.4 * update for increased specialness of OP_PUSHMARK in Perl 5.21.6 * update for distinct PADNAMELIST type in Perl 5.21.7 * update for multideref optimisation in Perl 5.21.7, by a disgusting hack that depends on a flaw in the optimisation (which may disappear in the future) and which disables the optimisation entirely * add MYMETA.json to .gitignore version 1.18; 2013-09-21 * bugfix: store peep chain link reliably under threads * update tests for Perl 5.19.4's removal of the special treatment of aliased undef in arrays * in doc, switch to consistent use of British English spellings * doc typo fix version 1.17; 2013-08-04 * bugfix: correct the dtrace-related macro squashing for Perls prior to 5.13.8, where the macros had the wrong number of parameters and prevented compilation * bugfix: use core's PL_no_localize_ref string constant as data string rather than format string * update to handle the new padrange op type in Perl 5.17.6 * update to handle the new op allocation mechanism in Perl 5.17.2 * clarify and expand documentation around list-like assignments * clarify documentation of deref() regarding lvalueness * remove the bulk of the documentation from the README file version 1.16; 2011-11-17 * bugfix: use supported API to put destructor calls on the save stack (the unsupported way used before was wrong for 64-bit systems on perl 5.13.1 and later) * document the behaviour of "alias return" in more detail * convert .cvsignore to .gitignore version 1.15; 2011-06-21 * port to Perl 5.15.0, where the op type aelemfast has been split into aelemfast and aelemfast_lex * test compatibility with Devel::CallParser version 1.14; 2011-04-27 * bugfix: never unhook peephole optimiser, because unhooking is liable to fail if anything else hooked it * bugfix: revise check for dorassign opcode to cope with FreeBSD's mutant Perl 5.8 that has it * test POD syntax and coverage version 1.13; 2011-04-25 * bugfix: prevent the lexer getting confused if the first thing inside an alias{} block is an open paren * bugfix: don't crash if an rv2cv op is built with PL_parser null * bugfix: handle variant structure of entersub op which lacks (ex-)list op as direct child * bugfix: squash bogus dtrace-related macro definitions that are picked up due to defining PERL_CORE * switch all pp functions to internal linkage * avoid some compiler warnings * include .cvsignore file in distribution 1.12 Tue Feb 22 20:47 GMT 2011 - Updated to work with Perl version 5.13.10, where GvGP() and GvCV() are not directly-assignable lvalues 1.11 Thu Jan 13 20:23 GMT 2011 - Don't rely on details of core's pp_* functions to determine whether an opcode exists, because they can change unpredictably (and do change in Perl 5.13.9) 1.10 Sun Nov 21 09:04 GMT 2010 - Updated to work with Perl version 5.13.7, where lex_end() has disappeared and mod() is now in the public API under the name op_lvalue() 1.09 Mon Nov 15 21:36 GMT 2010 - Modify source filter test to use Filter::Util::Call directly instead of the deprecated Switch, and to not fail if it is not available, thus allowing tests to pass on Perl versions 5.13.1 and above where Switch is no longer in the core distribution - Updated to work with Perl version 5.13.6, where global variables are managed in a different way from before 1.08 Fri Oct 22 09:39 BST 2010 - Updated to work with Perl versions 5.11.0 up to 5.13.0, including particularly the major change in when rv2cv ops get built in 5.11.2 1.07 Mon Sep 10 22:25 CEST 2007 - Fixed reference miscounting for 'my VAR' inside alias 1.06 Thu Jun 28 22:29 CEST 2007 - Fixed crash when conditionally aliasing whole aggregate 1.05 Sun May 6 16:36 CEST 2007 - Updated to work with recent bleadperl (5.9.5 patch 31154) 1.04 Thu May 3 16:17 CEST 2007 - Avoid directly calling pp_* functions - Fixed copy() of empty list in scalar context - Updated to work with recent bleadperl (5.9.5 patch 31058) - Switched to using Module::Install - Added perl version compatibility test on Win32 and AIX 1.03 Fri Mar 16 15:38 CET 2007 - Updated to work with recent bleadperl (5.9.5 patch 29836) 1.02 Tue Jan 9 16:59 CET 2007 - Updated to work with recent bleadperl (5.9.5 patch 29570) 1.01 Fri Sep 29 23:39 CEST 2006 - Worked around perl bug (wrong context of refgen due to prototype) - Updated to work with recent bleadperl - Warn on aliasing a lexical where the effect is limited in scope (category "closure") 1.0 Mon Jul 12 23:17 CEST 2006 - Further enhanced performance of alias-assign - Fixed compile errors on non-gcc compilers - Fixed aliasing a constant expression - Don't export "copy" by default anymore - Properly reallocate ops (bug exposed by perl 5.9.4 patch 27773) - Enhanced performance of copy in void context - Alias-refgen properly makes stuff read-only that ought to be - Support defined-or-assign (//=) in perl 5.9.x 0.10 Sat Jun 3 17:44 CEST 2006 - Enhanced performance of alias-assign - Made a note about 'local' in the docs 0.09 Mon May 22 17:12 CEST 2006 - Suppress warnings when using 64-bit integers on 32-bit arch - 'local' now doesn't act differently on tied vars than on normal ones - Added "Useless use of alias" warning (category 'void') 0.08 Wed Feb 8 20:19 CET 2006 - Avoid giving the "tied array/hash" error when inappropriate, such as when the array/hash is merely the target of weakrefs 0.07 Mon Feb 6 16:43 CET 2006 - Removed outer lexical support, since it can't be made to work in any consistent way 0.06 Mon Feb 6 00:35 CET 2006 - Fixed memory mismanagement bug (crash) - Fixed parse failure of 'alias' or 'copy' at EOF 0.05 Wed Jan 25 15:48 CET 2006 - Split off Data::Swap again - Perl 5.9.3 support - Fixed alias-returning from within a nested block 0.04 Sun Aug 29 21:01 CEST 2004 - Minor fix because PAUSE complained about missing version in Data::Swap 0.03 Sun Aug 29 00:36 CEST 2004 - Initial version of Data::Alias (incorporates Data::Swap) - Fixed swapping objects with weakrefs 0.02 Thu Jul 3 11:34 CEST 2003 - Added Changes file - Disallow swapping an overloaded object with a non-overloaded one 0.01 Mon Jun 30 20:08 CEST 2003 - Initial version Data-Alias-1.21/Alias.xs0000644000175000017500000015325313212443350014302 0ustar zeframzefram/* Copyright (C) 2003, 2004, 2006, 2007 Matthijs van Duin * * Copyright (C) 2010, 2011, 2013, 2015, 2017 * Andrew Main (Zefram) * * Parts from perl, which is Copyright (C) 1991-2013 Larry Wall and others * * You may distribute under the same terms as perl itself, which is either * the GNU General Public License or the Artistic License. */ #define PERL_CORE #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef USE_5005THREADS #error "5.005 threads not supported by Data::Alias" #endif #ifndef PERL_COMBI_VERSION #define PERL_COMBI_VERSION (PERL_REVISION * 1000000 + PERL_VERSION * 1000 + \ PERL_SUBVERSION) #endif #ifndef cBOOL #define cBOOL(x) ((bool)!!(x)) #endif #if defined(USE_DTRACE) && defined(PERL_CORE) #undef ENTRY_PROBE #undef RETURN_PROBE #if (PERL_COMBI_VERSION < 5013008) #define ENTRY_PROBE(func, file, line) #define RETURN_PROBE(func, file, line) #else #define ENTRY_PROBE(func, file, line, stash) #define RETURN_PROBE(func, file, line, stash) #endif #endif #if defined(PERL_CORE) && defined(MULTIPLICITY) && \ (PERL_COMBI_VERSION < 5013006) #undef PL_sv_placeholder #define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL)) #endif #ifndef G_LIST #define G_LIST G_ARRAY #endif #ifndef RenewOpc #if defined(PL_OP_SLAB_ALLOC) || (PERL_COMBI_VERSION >= 5017002) #define RenewOpc(m,v,n,t,c) \ STMT_START { \ t *tMp_; \ NewOp(m,tMp_,n,t); \ Copy(v,tMp_,n,t); \ FreeOp(v); \ v = (c*) tMp_; \ } STMT_END #else #if (PERL_COMBI_VERSION >= 5009004) #define RenewOpc(m,v,n,t,c) \ (v = (MEM_WRAP_CHECK_(n,t) \ (c*)PerlMemShared_realloc(v, (n)*sizeof(t)))) #else #define RenewOpc(m,v,n,t,c) \ Renewc(v,n,t,c) #endif #endif #endif #ifndef RenewOp #define RenewOp(m,v,n,t) \ RenewOpc(m,v,n,t,t) #endif #ifdef avhv_keys #define DA_FEATURE_AVHV 1 #endif #if (PERL_COMBI_VERSION >= 5009003) #define PL_no_helem PL_no_helem_sv #endif #ifndef SvPVX_const #define SvPVX_const SvPVX #endif #ifndef SvREFCNT_inc_NN #define SvREFCNT_inc_NN SvREFCNT_inc #endif #ifndef SvREFCNT_inc_simple_NN #define SvREFCNT_inc_simple_NN SvREFCNT_inc_NN #endif #ifndef SvREFCNT_inc_simple_void_NN #define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN #endif #ifndef GvGP_set #define GvGP_set(gv, val) (GvGP(gv) = val) #endif #ifndef GvCV_set #define GvCV_set(gv, val) (GvCV(gv) = val) #endif #if (PERL_COMBI_VERSION >= 5009003) #define DA_FEATURE_MULTICALL 1 #endif #if (PERL_COMBI_VERSION >= 5009002) #define DA_FEATURE_RETOP 1 #endif #define INT2SIZE(x) ((MEM_SIZE)(SSize_t)(x)) #define DA_ARRAY_MAXIDX ((IV) (INT2SIZE(-1) / (2 * sizeof(SV *))) ) #ifndef Nullsv #define Nullsv ((SV*)NULL) #endif #ifndef Nullop #define Nullop ((OP*)NULL) #endif #ifndef lex_end #define lex_end() ((void) 0) #endif #ifndef op_lvalue #define op_lvalue(o, t) mod(o, t) #endif #define DA_HAVE_OP_PADRANGE (PERL_COMBI_VERSION >= 5017006) #if DA_HAVE_OP_PADRANGE #define IS_PUSHMARK_OR_PADRANGE(op) \ ((op)->op_type == OP_PUSHMARK || (op)->op_type == OP_PADRANGE) #else #define IS_PUSHMARK_OR_PADRANGE(op) ((op)->op_type == OP_PUSHMARK) #endif #if (PERL_COMBI_VERSION < 5010001) typedef unsigned Optype; #endif #ifndef OpMORESIB_set #define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) #define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) #define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif #ifndef OpSIBLING #define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) #define OpSIBLING(o) (0 + (o)->op_sibling) #endif #if (PERL_COMBI_VERSION < 5009003) typedef OP *(*Perl_check_t)(pTHX_ OP *); #endif #ifndef wrap_op_checker #define wrap_op_checker(c,n,o) THX_wrap_op_checker(aTHX_ c,n,o) static void THX_wrap_op_checker(pTHX_ Optype opcode, Perl_check_t new_checker, Perl_check_t *old_checker_p) { if(*old_checker_p) return; OP_REFCNT_LOCK; if(!*old_checker_p) { *old_checker_p = PL_check[opcode]; PL_check[opcode] = new_checker; } OP_REFCNT_UNLOCK; } #endif #define DA_HAVE_LEX_KNOWNEXT (PERL_COMBI_VERSION < 5025001) #if (PERL_COMBI_VERSION >= 5011000) && !defined(SVt_RV) #define SVt_RV SVt_IV #endif #ifndef IS_PADGV #ifdef USE_ITHREADS #define IS_PADGV(v) ((v) && SvTYPE(v) == SVt_PVGV) #else #define IS_PADGV(v) 0 #endif #endif #ifndef PadnamelistARRAY #define PadnamelistARRAY(pnl) AvARRAY(pnl) #endif #ifndef PadnameOUTER #define PadnameOUTER(pn) (!!SvFAKE(pn)) #endif #if (PERL_COMBI_VERSION >= 5006000) && (PERL_COMBI_VERSION < 5011000) #define case_OP_SETSTATE_ case OP_SETSTATE: #else #define case_OP_SETSTATE_ #endif #if (PERL_COMBI_VERSION >= 5011002) static char const msg_no_symref[] = "Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"; #else #define msg_no_symref PL_no_symref #endif #if (PERL_COMBI_VERSION >= 5009005) #ifdef PERL_MAD #error "Data::Alias doesn't support Misc Attribute Decoration yet" #endif #if DA_HAVE_LEX_KNOWNEXT #define PL_lex_defer (PL_parser->lex_defer) #endif #if (PERL_COMBI_VERSION < 5021004) #define PL_lex_expect (PL_parser->lex_expect) #endif #define PL_linestr (PL_parser->linestr) #define PL_expect (PL_parser->expect) #define PL_bufptr (PL_parser->bufptr) #define PL_oldbufptr (PL_parser->oldbufptr) #define PL_oldoldbufptr (PL_parser->oldoldbufptr) #define PL_bufend (PL_parser->bufend) #define PL_last_uni (PL_parser->last_uni) #define PL_last_lop (PL_parser->last_lop) #define PL_lex_state (PL_parser->lex_state) #define PL_nexttoke (PL_parser->nexttoke) #define PL_nexttype (PL_parser->nexttype) #define PL_tokenbuf (PL_parser->tokenbuf) #define PL_yylval (PL_parser->yylval) #elif (PERL_COMBI_VERSION >= 5009001) #define PL_yylval (*PL_yylvalp) #endif #define OPpALIASAV 1 #define OPpALIASHV 2 #define OPpALIAS (OPpALIASAV | OPpALIASHV) #define OPpUSEFUL OPpLVAL_INTRO #define MOD(op) op_lvalue((op), OP_GREPSTART) #ifndef SVs_PADBUSY #define SVs_PADBUSY 0 #endif #define SVs_PADFLAGS (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP) #ifdef pp_dorassign #define DA_HAVE_OP_DORASSIGN 1 #else #define DA_HAVE_OP_DORASSIGN (PERL_COMBI_VERSION >= 5009000) #endif #define DA_TIED_ERR "Can't %s alias %s tied %s" #define DA_ODD_HASH_ERR "Odd number of elements in hash assignment" #define DA_TARGET_ERR "Unsupported alias target" #define DA_TARGET_ERR_AT "Unsupported alias target at %s line %"UVuf"\n" #define DA_DEREF_ERR "Can't deref string (\"%.32s\")" #define DA_OUTER_ERR "Aliasing of outer lexical variable has limited scope" #define _PUSHaa(a1,a2) PUSHs((SV*)(Size_t)(a1));PUSHs((SV*)(Size_t)(a2)) #define PUSHaa(a1,a2) STMT_START { _PUSHaa(a1,a2); } STMT_END #define XPUSHaa(a1,a2) STMT_START { EXTEND(sp,2); _PUSHaa(a1,a2); } STMT_END #define DA_ALIAS_PAD ((Size_t) -1) #define DA_ALIAS_RV ((Size_t) -2) #define DA_ALIAS_GV ((Size_t) -3) #define DA_ALIAS_AV ((Size_t) -4) #define DA_ALIAS_HV ((Size_t) -5) STATIC OP *(*da_old_ck_rv2cv)(pTHX_ OP *op); STATIC OP *(*da_old_ck_entersub)(pTHX_ OP *op); #if (PERL_COMBI_VERSION >= 5021007) STATIC OP *(*da_old_ck_aelem)(pTHX_ OP *op); STATIC OP *(*da_old_ck_helem)(pTHX_ OP *op); #endif #ifdef USE_ITHREADS #define DA_GLOBAL_KEY "Data::Alias::_global" #define DA_FETCH(create) hv_fetch(PL_modglobal, DA_GLOBAL_KEY, \ sizeof(DA_GLOBAL_KEY) - 1, create) #define DA_ACTIVE ((_dap = DA_FETCH(FALSE)) && (_da = *_dap)) #define DA_INIT STMT_START { _dap = DA_FETCH(TRUE); _da = *_dap; \ sv_upgrade(_da, SVt_PVLV); LvTYPE(_da) = 't'; } STMT_END #define dDA SV *_da, **_dap #define dDAforce SV *_da = *DA_FETCH(FALSE) #define da_inside (*(I32 *) &SvIVX(_da)) #define da_iscope (*(PERL_CONTEXT **) &SvPVX(_da)) #define da_cv (*(CV **) &LvTARGOFF(_da)) #define da_cvc (*(CV **) &LvTARGLEN(_da)) #else #define dDA dNOOP #define dDAforce dNOOP #define DA_ACTIVE 42 #define DA_INIT STATIC CV *da_cv, *da_cvc; STATIC I32 da_inside; STATIC PERL_CONTEXT *da_iscope; #endif STATIC void (*da_old_peepp)(pTHX_ OP *); STATIC OP *da_tag_rv2cv(pTHX) { return NORMAL; } STATIC OP *da_tag_list(pTHX) { return NORMAL; } STATIC OP *da_tag_entersub(pTHX) { return NORMAL; } STATIC void da_peep(pTHX_ OP *o); STATIC void da_peep2(pTHX_ OP *o); STATIC SV *da_fetch(pTHX_ SV *a1, SV *a2) { switch ((Size_t) a1) { case DA_ALIAS_PAD: return PL_curpad[(Size_t) a2]; case DA_ALIAS_RV: if (SvTYPE(a2) == SVt_PVGV) a2 = GvSV(a2); else if (!SvROK(a2) || !(a2 = SvRV(a2)) || (SvTYPE(a2) > SVt_PVLV && SvTYPE(a2) != SVt_PVGV)) Perl_croak(aTHX_ "Not a SCALAR reference"); case DA_ALIAS_GV: return a2; case DA_ALIAS_AV: case DA_ALIAS_HV: break; default: switch (SvTYPE(a1)) { SV **svp; HE *he; case SVt_PVAV: svp = av_fetch((AV *) a1, (Size_t) a2, FALSE); return svp ? *svp : &PL_sv_undef; case SVt_PVHV: he = hv_fetch_ent((HV *) a1, a2, FALSE, 0); return he ? HeVAL(he) : &PL_sv_undef; default: /* suppress warning */ ; } } Perl_croak(aTHX_ DA_TARGET_ERR); return NULL; /* suppress warning on win32 */ } #define PREP_ALIAS_INC(sV) \ STMT_START { \ if (SvPADTMP(sV) && !IS_PADGV(sV)) { \ sV = newSVsv(sV); \ SvREADONLY_on(sV); \ } else { \ switch (SvTYPE(sV)) { \ case SVt_PVLV: \ if (LvTYPE(sV) == 'y') { \ if (LvTARGLEN(sV)) \ vivify_defelem(sV); \ sV = LvTARG(sV); \ if (!sV) \ sV = &PL_sv_undef; \ } \ break; \ case SVt_PVAV: \ if (!AvREAL((AV *) sV) && AvREIFY((AV *) sV)) \ av_reify((AV *) sV); \ break; \ default: \ /* suppress warning */ ; \ } \ SvTEMP_off(sV); \ SvREFCNT_inc_simple_void_NN(sV); \ } \ } STMT_END STATIC void da_restore_gvcv(pTHX_ void *gv_v) { GV *gv = (GV*)gv_v; CV *restcv = (CV *) SSPOPPTR; CV *oldcv = GvCV(gv); GvCV_set(gv, restcv); SvREFCNT_dec(oldcv); SvREFCNT_dec((SV *) gv); } STATIC void da_alias(pTHX_ SV *a1, SV *a2, SV *value) { PREP_ALIAS_INC(value); if ((Size_t) a1 == DA_ALIAS_PAD) { SV *old = PL_curpad[(Size_t) a2]; PL_curpad[(Size_t) a2] = value; SvFLAGS(value) |= (SvFLAGS(old) & SVs_PADFLAGS); if (old != &PL_sv_undef) SvREFCNT_dec(old); return; } switch ((Size_t) a1) { SV **svp; GV *gv; case DA_ALIAS_RV: if (SvTYPE(a2) == SVt_PVGV) { sv_2mortal(value); goto globassign; } value = newRV_noinc(value); goto refassign; case DA_ALIAS_GV: if (!SvROK(value)) { refassign: SvSetMagicSV(a2, value); SvREFCNT_dec(value); return; } value = SvRV(sv_2mortal(value)); globassign: gv = (GV *) a2; #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) Perl_croak(aTHX_ PL_no_modify); #endif switch (SvTYPE(value)) { CV *oldcv; case SVt_PVCV: oldcv = GvCV(gv); if (oldcv != (CV *) value) { if (GvCVGEN(gv)) { GvCV_set(gv, NULL); GvCVGEN(gv) = 0; SvREFCNT_dec((SV *) oldcv); oldcv = NULL; } PL_sub_generation++; } GvMULTI_on(gv); if (GvINTRO(gv)) { SvREFCNT_inc_simple_void_NN((SV *) gv); SvREFCNT_inc_simple_void_NN(value); GvINTRO_off(gv); SSCHECK(1); SSPUSHPTR((SV *) oldcv); SAVEDESTRUCTOR_X(da_restore_gvcv, (void*)gv); GvCV_set(gv, (CV*)value); } else { SvREFCNT_inc_simple_void_NN(value); GvCV_set(gv, (CV*)value); SvREFCNT_dec((SV *) oldcv); } return; case SVt_PVAV: svp = (SV **) &GvAV(gv); break; case SVt_PVHV: svp = (SV **) &GvHV(gv); break; case SVt_PVFM: svp = (SV **) &GvFORM(gv); break; case SVt_PVIO: svp = (SV **) &GvIOp(gv); break; default: svp = &GvSV(gv); } GvMULTI_on(gv); if (GvINTRO(gv)) { GvINTRO_off(gv); SAVEGENERICSV(*svp); *svp = SvREFCNT_inc_simple_NN(value); } else { SV *old = *svp; *svp = SvREFCNT_inc_simple_NN(value); SvREFCNT_dec(old); } return; case DA_ALIAS_AV: case DA_ALIAS_HV: break; default: switch (SvTYPE(a1)) { case SVt_PVAV: if (!av_store((AV *) a1, (Size_t) a2, value)) SvREFCNT_dec(value); return; case SVt_PVHV: if (value == &PL_sv_undef) { (void) hv_delete_ent((HV *) a1, a2, G_DISCARD, 0); } else { if (!hv_store_ent((HV *) a1, a2, value, 0)) SvREFCNT_dec(value); } return; default: /* suppress warning */ ; } } SvREFCNT_dec(value); Perl_croak(aTHX_ DA_TARGET_ERR); } STATIC void da_unlocalize_gvar(pTHX_ void *gp_v) { GP *gp = (GP*) gp_v; SV *value = (SV *) SSPOPPTR; SV **sptr = (SV **) SSPOPPTR; SV *old = *sptr; *sptr = value; SvREFCNT_dec(old); if (gp->gp_refcnt > 1) { --gp->gp_refcnt; } else { SV *gv = newSV(0); sv_upgrade(gv, SVt_PVGV); SvSCREAM_on(gv); GvGP_set(gv, gp); sv_free(gv); } } STATIC void da_localize_gvar(pTHX_ GP *gp, SV **sptr) { SSCHECK(2); SSPUSHPTR(sptr); SSPUSHPTR(*sptr); SAVEDESTRUCTOR_X(da_unlocalize_gvar, (void*)gp); ++gp->gp_refcnt; *sptr = Nullsv; } STATIC SV *da_refgen(pTHX_ SV *sv) { SV *rv; PREP_ALIAS_INC(sv); rv = sv_newmortal(); sv_upgrade(rv, SVt_RV); SvRV(rv) = sv; SvROK_on(rv); SvREADONLY_on(rv); return rv; } STATIC OP *DataAlias_pp_srefgen(pTHX) { dSP; SETs(da_refgen(aTHX_ TOPs)); RETURN; } STATIC OP *DataAlias_pp_refgen(pTHX) { dSP; dMARK; if (GIMME_V != G_LIST) { ++MARK; *MARK = da_refgen(aTHX_ MARK <= SP ? TOPs : &PL_sv_undef); SP = MARK; } else { EXTEND_MORTAL(SP - MARK); while (++MARK <= SP) *MARK = da_refgen(aTHX_ *MARK); } RETURN; } STATIC OP *DataAlias_pp_anonlist(pTHX) { dSP; dMARK; I32 i = SP - MARK; AV *av = newAV(); SV **svp, *sv; av_extend(av, i - 1); AvFILLp(av) = i - 1; svp = AvARRAY(av); while (i--) SvTEMP_off(svp[i] = SvREFCNT_inc_NN(POPs)); if (PL_op->op_flags & OPf_SPECIAL) { sv = da_refgen(aTHX_ (SV *) av); SvREFCNT_dec((SV *) av); } else { sv = sv_2mortal((SV *) av); } XPUSHs(sv); RETURN; } STATIC OP *DataAlias_pp_anonhash(pTHX) { dSP; dMARK; dORIGMARK; HV *hv = (HV *) newHV(); SV *sv; while (MARK < SP) { SV *key = *++MARK; SV *val = &PL_sv_undef; if (MARK < SP) SvTEMP_off(val = SvREFCNT_inc_NN(*++MARK)); else if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); if (val == &PL_sv_undef) (void) hv_delete_ent(hv, key, G_DISCARD, 0); else (void) hv_store_ent(hv, key, val, 0); } SP = ORIGMARK; if (PL_op->op_flags & OPf_SPECIAL) { sv = da_refgen(aTHX_ (SV *) hv); SvREFCNT_dec((SV *) hv); } else { sv = sv_2mortal((SV *) hv); } XPUSHs(sv); RETURN; } STATIC OP *DataAlias_pp_aelemfast(pTHX) { dSP; AV *av = #if (PERL_COMBI_VERSION >= 5015000) PL_op->op_type == OP_AELEMFAST_LEX ? #else (PL_op->op_flags & OPf_SPECIAL) ? #endif (AV *) PAD_SV(PL_op->op_targ) : GvAVn(cGVOP_gv); IV index = PL_op->op_private; if (!av_fetch(av, index, TRUE)) DIE(aTHX_ PL_no_aelem, index); XPUSHaa(av, index); RETURN; } STATIC bool da_badmagic(pTHX_ SV *sv) { MAGIC *mg = SvMAGIC(sv); while (mg) { if (isUPPER(mg->mg_type)) return TRUE; mg = mg->mg_moremagic; } return FALSE; } STATIC OP *DataAlias_pp_aelem(pTHX) { dSP; SV *elem = POPs, **svp; AV *av = (AV *) POPs; IV index = SvIV(elem); if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "array"); if (SvROK(elem) && !SvGAMAGIC(elem) && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elem); if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; if (index > DA_ARRAY_MAXIDX || !(svp = av_fetch(av, index, TRUE))) DIE(aTHX_ PL_no_aelem, index); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, index, svp); PUSHaa(av, index); RETURN; } #if DA_FEATURE_AVHV STATIC I32 da_avhv_index(pTHX_ AV *av, SV *key) { HV *keys = (HV *) SvRV(*AvARRAY(av)); HE *he = hv_fetch_ent(keys, key, FALSE, 0); I32 index; if (!he) Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV_nolen(key)); if ((index = SvIV(HeVAL(he))) <= 0) Perl_croak(aTHX_ "Bad index while coercing array into hash"); if (index > AvMAX(av)) { I32 real = AvREAL(av); AvREAL_on(av); av_extend(av, index); if (!real) AvREAL_off(av); } return index; } #endif STATIC OP *DataAlias_pp_helem(pTHX) { dSP; SV *key = POPs; HV *hv = (HV *) POPs; HE *he; if (SvRMAGICAL(hv) && da_badmagic(aTHX_ (SV *) hv)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash"); if (SvTYPE(hv) == SVt_PVHV) { if (!(he = hv_fetch_ent(hv, key, TRUE, 0))) DIE(aTHX_ PL_no_helem, SvPV_nolen(key)); if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, key, &HeVAL(he)); } #if DA_FEATURE_AVHV else if (SvTYPE(hv) == SVt_PVAV && avhv_keys((AV *) hv)) { I32 i = da_avhv_index(aTHX_ (AV *) hv, key); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem((AV *) hv, i, &AvARRAY(hv)[i]); key = (SV *) (Size_t) i; } #endif else { hv = (HV *) &PL_sv_undef; key = NULL; } PUSHaa(hv, key); RETURN; } STATIC OP *DataAlias_pp_aslice(pTHX) { dSP; dMARK; AV *av = (AV *) POPs; IV max, count; SV **src, **dst; const U32 local = PL_op->op_private & OPpLVAL_INTRO; if (SvTYPE(av) != SVt_PVAV) DIE(aTHX_ "Not an array"); if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "array"); count = SP - MARK; EXTEND(sp, count); src = SP; dst = SP += count; max = AvFILLp(av); count = max + 1; while (MARK < src) { IV i = SvIVx(*src); if (i > DA_ARRAY_MAXIDX || (i < 0 && (i += count) < 0)) DIE(aTHX_ PL_no_aelem, SvIVX(*src)); if (local) save_aelem(av, i, av_fetch(av, i, TRUE)); if (i > max) max = i; *dst-- = (SV *) (Size_t) i; *dst-- = (SV *) av; --src; } if (max > AvMAX(av)) av_extend(av, max); RETURN; } STATIC OP *DataAlias_pp_hslice(pTHX) { dSP; dMARK; HV *hv = (HV *) POPs; SV *key; HE *he; SV **src, **dst; IV i = SP - MARK; if (SvRMAGICAL(hv) && da_badmagic(aTHX_ (SV *) hv)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash"); EXTEND(sp, i); src = SP; dst = SP += i; if (SvTYPE(hv) == SVt_PVHV) { while (MARK < src) { if (!(he = hv_fetch_ent(hv, key = *src--, TRUE, 0))) DIE(aTHX_ PL_no_helem, SvPV_nolen(key)); if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, key, &HeVAL(he)); *dst-- = key; *dst-- = (SV *) hv; } } #if DA_FEATURE_AVHV else if (SvTYPE(hv) == SVt_PVAV && avhv_keys((AV *) hv)) { while (MARK < src) { i = da_avhv_index(aTHX_ (AV *) hv, key = *src--); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem((AV *) hv, i, &AvARRAY(hv)[i]); *dst-- = (SV *) (Size_t) i; *dst-- = (SV *) hv; } } #endif else { DIE(aTHX_ "Not a hash"); } RETURN; } #if DA_HAVE_OP_PADRANGE STATIC OP *DataAlias_pp_padrange_generic(pTHX_ bool is_single) { dSP; IV start = PL_op->op_targ; IV count = PL_op->op_private & OPpPADRANGE_COUNTMASK; IV index; if (PL_op->op_flags & OPf_SPECIAL) { AV *av = GvAVn(PL_defgv); PUSHMARK(SP); if (is_single) { XPUSHs((SV*)av); } else { const I32 maxarg = AvFILL(av) + 1; EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; for (i=0; i < (U32)maxarg; i++) { SV ** const svp = av_fetch(av, i, FALSE); SP[i+1] = svp ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp : &PL_sv_undef; } } else { Copy(AvARRAY(av), SP+1, maxarg, SV*); } SP += maxarg; } } if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) { PUSHMARK(SP); EXTEND(SP, count << 1); } for(index = start; index != start+count; index++) { Size_t da_type; if (is_single) { da_type = DA_ALIAS_PAD; } else { switch(SvTYPE(PAD_SVl(index))) { case SVt_PVAV: da_type = DA_ALIAS_AV; break; case SVt_PVHV: da_type = DA_ALIAS_HV; break; default: da_type = DA_ALIAS_PAD; break; } } if (PL_op->op_private & OPpLVAL_INTRO) { if (da_type == DA_ALIAS_PAD) { SAVEGENERICSV(PAD_SVl(index)); PAD_SVl(index) = &PL_sv_undef; } else { SAVECLEARSV(PAD_SVl(index)); } } if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) PUSHaa(da_type, da_type == DA_ALIAS_PAD ? (Size_t)index : (Size_t)PAD_SVl(index)); } RETURN; } STATIC OP *DataAlias_pp_padrange_list(pTHX) { return DataAlias_pp_padrange_generic(aTHX_ 0); } STATIC OP *DataAlias_pp_padrange_single(pTHX) { return DataAlias_pp_padrange_generic(aTHX_ 1); } #endif STATIC OP *DataAlias_pp_padsv(pTHX) { dSP; IV index = PL_op->op_targ; if (PL_op->op_private & OPpLVAL_INTRO) { SAVEGENERICSV(PAD_SVl(index)); PAD_SVl(index) = &PL_sv_undef; } XPUSHaa(DA_ALIAS_PAD, index); RETURN; } STATIC OP *DataAlias_pp_padav(pTHX) { dSP; dTARGET; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); XPUSHaa(DA_ALIAS_AV, TARG); RETURN; } STATIC OP *DataAlias_pp_padhv(pTHX) { dSP; dTARGET; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); XPUSHaa(DA_ALIAS_HV, TARG); RETURN; } STATIC OP *DataAlias_pp_gvsv(pTHX) { dSP; GV *gv = cGVOP_gv; if (PL_op->op_private & OPpLVAL_INTRO) { da_localize_gvar(aTHX_ GvGP(gv), &GvSV(gv)); GvSV(gv) = newSV(0); } XPUSHaa(DA_ALIAS_RV, gv); RETURN; } STATIC OP *DataAlias_pp_gvsv_r(pTHX) { dSP; GV *gv = cGVOP_gv; if (PL_op->op_private & OPpLVAL_INTRO) { da_localize_gvar(aTHX_ GvGP(gv), &GvSV(gv)); GvSV(gv) = newSV(0); } XPUSHs(GvSV(gv)); RETURN; } STATIC GV *fixglob(pTHX_ GV *gv) { SV **svp = hv_fetch(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE); GV *egv; if (!svp || !(egv = (GV *) *svp) || GvGP(egv) != GvGP(gv)) return gv; GvEGV(gv) = egv; return egv; } STATIC OP *DataAlias_pp_rv2sv(pTHX) { dSP; dPOPss; if (!SvROK(sv) && SvTYPE(sv) != SVt_PVGV) do { const char *tname; U32 type; switch (PL_op->op_type) { case OP_RV2AV: type = SVt_PVAV; tname = "an ARRAY"; break; case OP_RV2HV: type = SVt_PVHV; tname = "a HASH"; break; default: type = SVt_PV; tname = "a SCALAR"; } if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) break; } if (!SvOK(sv)) break; if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ msg_no_symref, SvPV_nolen(sv), tname); sv = (SV *) gv_fetchpv(SvPV_nolen(sv), TRUE, type); } while (0); if (SvTYPE(sv) == SVt_PVGV) sv = (SV *) (GvEGV(sv) ? GvEGV(sv) : fixglob(aTHX_ (GV *) sv)); if (PL_op->op_private & OPpLVAL_INTRO) { if (SvTYPE(sv) != SVt_PVGV || SvFAKE(sv)) DIE(aTHX_ "%s", PL_no_localize_ref); switch (PL_op->op_type) { case OP_RV2AV: da_localize_gvar(aTHX_ GvGP(sv), (SV **) &GvAV(sv)); break; case OP_RV2HV: da_localize_gvar(aTHX_ GvGP(sv), (SV **) &GvHV(sv)); break; default: da_localize_gvar(aTHX_ GvGP(sv), &GvSV(sv)); GvSV(sv) = newSV(0); } } XPUSHaa(DA_ALIAS_RV, sv); RETURN; } STATIC OP *DataAlias_pp_rv2sv_r(pTHX) { U8 savedflags; OP *op = PL_op, *ret; DataAlias_pp_rv2sv(aTHX); PL_stack_sp[-1] = PL_stack_sp[0]; --PL_stack_sp; savedflags = op->op_private; op->op_private = savedflags & ~OPpLVAL_INTRO; ret = PL_ppaddr[op->op_type](aTHX); op->op_private = savedflags; return ret; } STATIC OP *DataAlias_pp_rv2gv(pTHX) { dSP; dPOPss; if (SvROK(sv)) { wasref: sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVGV) DIE(aTHX_ "Not a GLOB reference"); } else if (SvTYPE(sv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } if (!SvOK(sv)) DIE(aTHX_ PL_no_usym, "a symbol"); if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ msg_no_symref, SvPV_nolen(sv), "a symbol"); sv = (SV *) gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVGV); } if (SvTYPE(sv) == SVt_PVGV) sv = (SV *) (GvEGV(sv) ? GvEGV(sv) : fixglob(aTHX_ (GV *) sv)); if (PL_op->op_private & OPpLVAL_INTRO) save_gp((GV *) sv, !(PL_op->op_flags & OPf_SPECIAL)); XPUSHaa(DA_ALIAS_GV, sv); RETURN; } STATIC OP *DataAlias_pp_rv2av(pTHX) { OP *ret = PL_ppaddr[OP_RV2AV](aTHX); dSP; SV *av = POPs; XPUSHaa(DA_ALIAS_AV, av); PUTBACK; return ret; } STATIC OP *DataAlias_pp_rv2hv(pTHX) { OP *ret = PL_ppaddr[OP_RV2HV](aTHX); dSP; SV *hv = POPs; XPUSHaa(DA_ALIAS_HV, hv); PUTBACK; return ret; } STATIC OP *DataAlias_pp_sassign(pTHX) { dSP; SV *a1, *a2, *value; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { value = POPs, a2 = POPs, a1 = TOPs; SETs(value); } else { a2 = POPs, a1 = POPs, value = TOPs; } da_alias(aTHX_ a1, a2, value); RETURN; } STATIC OP *DataAlias_pp_aassign(pTHX) { dSP; SV **left, **llast, **right, **rlast; I32 gimme = GIMME_V; I32 done = FALSE; EXTEND(sp, 1); left = POPMARK + PL_stack_base + 1; llast = SP; right = POPMARK + PL_stack_base + 1; rlast = left - 1; if (PL_op->op_private & OPpALIAS) { U32 hash = (PL_op->op_private & OPpALIASHV); U32 type = hash ? SVt_PVHV : SVt_PVAV; SV *a2 = POPs; SV *a1 = POPs; OPCODE savedop; if (SP != rlast) DIE(aTHX_ "Panic: unexpected number of lvalues"); PUTBACK; if (right != rlast || SvTYPE(*right) != type) { PUSHMARK(right - 1); hash ? DataAlias_pp_anonhash(aTHX) : DataAlias_pp_anonlist(aTHX); SPAGAIN; } da_alias(aTHX_ a1, a2, TOPs); savedop = PL_op->op_type; PL_op->op_type = hash ? OP_RV2HV : OP_RV2AV; PL_ppaddr[PL_op->op_type](aTHX); PL_op->op_type = savedop; return NORMAL; } SP = right - 1; while (SP < rlast) if (!SvTEMP(*++SP)) sv_2mortal(SvREFCNT_inc_NN(*SP)); SP = right - 1; while (left <= llast) { SV *a1 = *left++, *a2; if (a1 == &PL_sv_undef) { right++; continue; } a2 = *left++; switch ((Size_t) a1) { case DA_ALIAS_AV: { SV **svp; if (SvRMAGICAL(a2) && da_badmagic(aTHX_ a2)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "array"); av_clear((AV *) a2); if (done || right > rlast) break; av_extend((AV *) a2, rlast - right); AvFILLp((AV *) a2) = rlast - right; svp = AvARRAY((AV *) a2); while (right <= rlast) SvTEMP_off(*svp++ = SvREFCNT_inc_NN(*right++)); break; } case DA_ALIAS_HV: { SV *tmp, *val, **svp = rlast; U32 dups = 0, nils = 0; HE *he; #if DA_FEATURE_AVHV if (SvTYPE(a2) == SVt_PVAV) goto phash; #endif if (SvRMAGICAL(a2) && da_badmagic(aTHX_ a2)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash"); hv_clear((HV *) a2); if (done || right > rlast) break; done = TRUE; hv_ksplit((HV *) a2, (rlast - right + 2) >> 1); if (1 & ~(rlast - right)) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), DA_ODD_HASH_ERR); *++svp = &PL_sv_undef; } while (svp > right) { val = *svp--; tmp = *svp--; he = hv_fetch_ent((HV *) a2, tmp, TRUE, 0); if (!he) /* is this possible? */ DIE(aTHX_ PL_no_helem, SvPV_nolen(tmp)); tmp = HeVAL(he); if (SvREFCNT(tmp) > 1) { /* existing element */ svp[1] = svp[2] = NULL; dups += 2; continue; } if (val == &PL_sv_undef) nils++; SvREFCNT_dec(tmp); SvTEMP_off(HeVAL(he) = SvREFCNT_inc_simple_NN(val)); } while (nils && (he = hv_iternext((HV *) a2))) { if (HeVAL(he) == &PL_sv_undef) { HeVAL(he) = &PL_sv_placeholder; HvPLACEHOLDERS(a2)++; nils--; } } if (gimme != G_LIST || !dups) { right = rlast - dups + 1; break; } while (svp++ < rlast) { if (*svp) *right++ = *svp; } break; } #if DA_FEATURE_AVHV phash: { SV *key, *val, **svp = rlast, **he; U32 dups = 0; I32 i; if (SvRMAGICAL(a2) && da_badmagic(aTHX_ a2)) DIE(aTHX_ DA_TIED_ERR, "put", "into", "hash"); avhv_keys((AV *) a2); av_fill((AV *) a2, 0); if (done || right > rlast) break; done = TRUE; if (1 & ~(rlast - right)) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), DA_ODD_HASH_ERR); *++svp = &PL_sv_undef; } ENTER; while (svp > right) { val = *svp--; key = *svp--; i = da_avhv_index(aTHX_ (AV *) a2, key); he = &AvARRAY(a2)[i]; if (*he != &PL_sv_undef) { svp[1] = svp[2] = NULL; dups += 2; continue; } SvREFCNT_dec(*he); if (val == &PL_sv_undef) { SAVESPTR(*he); *he = NULL; } else { if (i > AvFILLp(a2)) AvFILLp(a2) = i; SvTEMP_off(*he = SvREFCNT_inc_simple_NN(val)); } } LEAVE; if (gimme != G_LIST || !dups) { right = rlast - dups + 1; break; } while (svp++ < rlast) { if (*svp) *right++ = *svp; } break; } #endif default: if (right > rlast) da_alias(aTHX_ a1, a2, &PL_sv_undef); else if (done) da_alias(aTHX_ a1, a2, *right = &PL_sv_undef); else da_alias(aTHX_ a1, a2, *right); right++; break; } } if (gimme == G_LIST) { SP = right - 1; EXTEND(SP, 0); while (rlast < SP) *++rlast = &PL_sv_undef; RETURN; } else if (gimme == G_SCALAR) { dTARGET; XPUSHi(rlast - SP); } RETURN; } STATIC OP *DataAlias_pp_andassign(pTHX) { dSP; SV *a2 = POPs; SV *sv = da_fetch(aTHX_ TOPs, a2); if (SvTRUE(sv)) { /* no PUTBACK */ return cLOGOP->op_other; } SETs(sv); RETURN; } STATIC OP *DataAlias_pp_orassign(pTHX) { dSP; SV *a2 = POPs; SV *sv = da_fetch(aTHX_ TOPs, a2); if (!SvTRUE(sv)) { /* no PUTBACK */ return cLOGOP->op_other; } SETs(sv); RETURN; } #if DA_HAVE_OP_DORASSIGN STATIC OP *DataAlias_pp_dorassign(pTHX) { dSP; SV *a2 = POPs; SV *sv = da_fetch(aTHX_ TOPs, a2); if (!SvOK(sv)) { /* no PUTBACK */ return cLOGOP->op_other; } SETs(sv); RETURN; } #endif STATIC OP *DataAlias_pp_push(pTHX) { dSP; dMARK; dORIGMARK; dTARGET; AV *av = (AV *) *++MARK; I32 i; if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av)) DIE(aTHX_ DA_TIED_ERR, "push", "onto", "array"); i = AvFILL(av); av_extend(av, i + (SP - MARK)); while (MARK < SP) av_store(av, ++i, SvREFCNT_inc_NN(*++MARK)); SP = ORIGMARK; PUSHi(i + 1); RETURN; } STATIC OP *DataAlias_pp_unshift(pTHX) { dSP; dMARK; dORIGMARK; dTARGET; AV *av = (AV *) *++MARK; I32 i = 0; if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av)) DIE(aTHX_ DA_TIED_ERR, "unshift", "onto", "array"); av_unshift(av, SP - MARK); while (MARK < SP) av_store(av, i++, SvREFCNT_inc_NN(*++MARK)); SP = ORIGMARK; PUSHi(AvFILL(av) + 1); RETURN; } STATIC OP *DataAlias_pp_splice(pTHX) { dSP; dMARK; dORIGMARK; I32 ins = SP - MARK - 3; AV *av = (AV *) MARK[1]; I32 off, del, count, i; SV **svp, *tmp; if (ins < 0) /* ?! */ DIE(aTHX_ "Too few arguments for DataAlias_pp_splice"); if (SvRMAGICAL(av) && da_badmagic(aTHX_ (SV *) av)) DIE(aTHX_ DA_TIED_ERR, "splice", "onto", "array"); count = AvFILLp(av) + 1; off = SvIV(MARK[2]); if (off < 0 && (off += count) < 0) DIE(aTHX_ PL_no_aelem, off - count); del = SvIV(ORIGMARK[3]); if (del < 0 && (del += count - off) < 0) del = 0; if (off > count) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array"); off = count; } if ((count -= off + del) < 0) /* count of trailing elems */ del += count, count = 0; i = off + ins + count - 1; if (i > AvMAX(av)) av_extend(av, i); if (!AvREAL(av) && AvREIFY(av)) av_reify(av); AvFILLp(av) = i; MARK = ORIGMARK + 4; svp = AvARRAY(av) + off; for (i = 0; i < ins; i++) SvTEMP_off(SvREFCNT_inc_NN(MARK[i])); if (ins > del) { Move(svp+del, svp+ins, INT2SIZE(count), SV *); for (i = 0; i < del; i++) tmp = MARK[i], MARK[i-3] = svp[i], svp[i] = tmp; Copy(MARK+del, svp+del, INT2SIZE(ins-del), SV *); } else { for (i = 0; i < ins; i++) tmp = MARK[i], MARK[i-3] = svp[i], svp[i] = tmp; if (ins != del) Copy(svp+ins, MARK-3+ins, INT2SIZE(del-ins), SV *); Move(svp+del, svp+ins, INT2SIZE(count), SV *); } MARK -= 3; for (i = 0; i < del; i++) sv_2mortal(MARK[i]); SP = MARK + del - 1; RETURN; } STATIC OP *DataAlias_pp_leave(pTHX) { dSP; SV **newsp; #ifdef POPBLOCK PMOP *newpm; #endif I32 gimme; PERL_CONTEXT *cx; SV *sv; if (PL_op->op_flags & OPf_SPECIAL) cxstack[cxstack_ix].blk_oldpm = PL_curpm; #ifdef POPBLOCK POPBLOCK(cx, newpm); gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); #else cx = CX_CUR(); assert(CxTYPE(cx) == CXt_BLOCK); gimme = cx->blk_gimme; newsp = PL_stack_base + cx->blk_oldsp; #endif if (gimme == G_SCALAR) { if (newsp == SP) { *++newsp = &PL_sv_undef; } else { sv = SvREFCNT_inc_NN(TOPs); FREETMPS; *++newsp = sv_2mortal(sv); } } else if (gimme == G_LIST) { while (newsp < SP) if (!SvTEMP(sv = *++newsp)) sv_2mortal(SvREFCNT_inc_simple_NN(sv)); } PL_stack_sp = newsp; #ifdef POPBLOCK PL_curpm = newpm; LEAVE; #else CX_LEAVE_SCOPE(cx); cx_popblock(cx); CX_POP(cx); #endif return NORMAL; } STATIC OP *DataAlias_pp_return(pTHX) { dSP; dMARK; I32 cxix; PERL_CONTEXT *cx; bool clearerr = FALSE; I32 gimme; SV **newsp; #ifdef POPBLOCK PMOP *newpm; #endif I32 optype = 0, type = 0; SV *sv = (MARK < SP) ? TOPs : &PL_sv_undef; OP *retop; cxix = cxstack_ix; while (cxix >= 0) { cx = &cxstack[cxix]; type = CxTYPE(cx); if (type == CXt_EVAL || type == CXt_SUB || type == CXt_FORMAT) break; cxix--; } #if DA_FEATURE_MULTICALL if (cxix < 0) { if (CxMULTICALL(cxstack)) { /* sort block */ dounwind(0); *(PL_stack_sp = PL_stack_base + 1) = sv; return 0; } DIE(aTHX_ "Can't return outside a subroutine"); } #else if (PL_curstackinfo->si_type == PERLSI_SORT && cxix <= PL_sortcxix) { if (cxstack_ix > PL_sortcxix) dounwind(PL_sortcxix); *(PL_stack_sp = PL_stack_base + 1) = sv; return 0; } if (cxix < 0) DIE(aTHX_ "Can't return outside a subroutine"); #endif if (cxix < cxstack_ix) dounwind(cxix); #if DA_FEATURE_MULTICALL if (CxMULTICALL(&cxstack[cxix])) { gimme = cxstack[cxix].blk_gimme; if (gimme == G_VOID) PL_stack_sp = PL_stack_base; else if (gimme == G_SCALAR) *(PL_stack_sp = PL_stack_base + 1) = sv; return 0; } #endif #ifdef POPBLOCK POPBLOCK(cx, newpm); #else cx = CX_CUR(); gimme = cx->blk_gimme; newsp = PL_stack_base + cx->blk_oldsp; #endif switch (type) { case CXt_SUB: #if DA_FEATURE_RETOP retop = cx->blk_sub.retop; #endif #ifdef POPBLOCK cxstack_ix++; /* temporarily protect top context */ #endif break; case CXt_EVAL: clearerr = !(PL_in_eval & EVAL_KEEPERR); #ifdef POPBLOCK POPEVAL(cx); #else cx_popeval(cx); #endif #if DA_FEATURE_RETOP retop = cx->blk_eval.retop; #endif if (CxTRYBLOCK(cx)) break; lex_end(); if (optype == OP_REQUIRE && !SvTRUE(sv) && (gimme == G_SCALAR || MARK == SP)) { sv = cx->blk_eval.old_namesv; (void) hv_delete(GvHVn(PL_incgv), SvPVX_const(sv), SvCUR(sv), G_DISCARD); DIE(aTHX_ "%"SVf" did not return a true value", sv); } break; case CXt_FORMAT: #ifdef POPBLOCK POPFORMAT(cx); #else cx_popformat(cx); #endif #if DA_FEATURE_RETOP retop = cx->blk_sub.retop; #endif break; default: DIE(aTHX_ "panic: return"); retop = NULL; /* suppress "uninitialized" warning */ } TAINT_NOT; if (gimme == G_SCALAR) { if (MARK == SP) { *++newsp = &PL_sv_undef; } else { sv = SvREFCNT_inc_NN(TOPs); FREETMPS; *++newsp = sv_2mortal(sv); } } else if (gimme == G_LIST) { while (MARK < SP) { *++newsp = sv = *++MARK; if (!SvTEMP(sv) && !(SvREADONLY(sv) && SvIMMORTAL(sv))) sv_2mortal(SvREFCNT_inc_simple_NN(sv)); TAINT_NOT; } } PL_stack_sp = newsp; #ifdef POPBLOCK LEAVE; if (type == CXt_SUB) { cxstack_ix--; POPSUB(cx, sv); LEAVESUB(sv); } PL_curpm = newpm; #else if (type == CXt_SUB) { cx_popsub(cx); } CX_LEAVE_SCOPE(cx); cx_popblock(cx); CX_POP(cx); #endif if (clearerr) sv_setpvn(ERRSV, "", 0); #if (!DA_FEATURE_RETOP) retop = pop_return(); #endif return retop; } STATIC OP *DataAlias_pp_leavesub(pTHX) { if (++PL_markstack_ptr == PL_markstack_max) markstack_grow(); *PL_markstack_ptr = cxstack[cxstack_ix].blk_oldsp; return DataAlias_pp_return(aTHX); } STATIC OP *DataAlias_pp_entereval(pTHX) { dDAforce; PERL_CONTEXT *iscope = da_iscope; I32 inside = da_inside; I32 cxi = (cxstack_ix < cxstack_max) ? cxstack_ix + 1 : cxinc(); OP *ret; da_iscope = &cxstack[cxi]; da_inside = 1; ret = PL_ppaddr[OP_ENTEREVAL](aTHX); da_iscope = iscope; da_inside = inside; return ret; } STATIC OP *DataAlias_pp_copy(pTHX) { dSP; dMARK; SV *sv; switch (GIMME_V) { case G_VOID: SP = MARK; break; case G_SCALAR: if (MARK == SP) { sv = sv_newmortal(); EXTEND(SP, 1); } else { sv = TOPs; if (!SvTEMP(sv) || SvREFCNT(sv) != 1) sv = sv_mortalcopy(sv); } *(SP = MARK + 1) = sv; break; default: while (MARK < SP) { if (!SvTEMP(sv = *++MARK) || SvREFCNT(sv) != 1) *MARK = sv_mortalcopy(sv); } } RETURN; } STATIC void da_lvalue(pTHX_ OP *op, int list) { switch (op->op_type) { case OP_PADSV: op->op_ppaddr = DataAlias_pp_padsv; if (PadnameOUTER( PadnamelistARRAY(PL_comppad_name)[op->op_targ]) && ckWARN(WARN_CLOSURE)) Perl_warner(aTHX_ packWARN(WARN_CLOSURE), DA_OUTER_ERR); break; #if DA_HAVE_OP_PADRANGE case OP_PADRANGE: { int start = op->op_targ; int count = op->op_private & OPpPADRANGE_COUNTMASK; int i; if (!list) goto bad; for(i = start; i != start+count; i++) { if (PadnameOUTER( PadnamelistARRAY(PL_comppad_name)[i]) && ckWARN(WARN_CLOSURE)) Perl_warner(aTHX_ packWARN(WARN_CLOSURE), DA_OUTER_ERR); } if (op->op_ppaddr != DataAlias_pp_padrange_single) op->op_ppaddr = DataAlias_pp_padrange_list; } break; #endif case OP_AELEM: op->op_ppaddr = DataAlias_pp_aelem; break; #if (PERL_COMBI_VERSION >= 5015000) case OP_AELEMFAST_LEX: #endif case OP_AELEMFAST: op->op_ppaddr = DataAlias_pp_aelemfast; break; case OP_HELEM: op->op_ppaddr = DataAlias_pp_helem; break; case OP_ASLICE: op->op_ppaddr = DataAlias_pp_aslice; break; case OP_HSLICE: op->op_ppaddr = DataAlias_pp_hslice; break; case OP_GVSV: op->op_ppaddr = DataAlias_pp_gvsv; break; case OP_RV2SV: op->op_ppaddr = DataAlias_pp_rv2sv; break; case OP_RV2GV: op->op_ppaddr = DataAlias_pp_rv2gv; break; case OP_LIST: if (!list) goto bad; case OP_NULL: op = (op->op_flags & OPf_KIDS) ? cUNOPx(op)->op_first : NULL; while (op) { da_lvalue(aTHX_ op, list); op = OpSIBLING(op); } break; case OP_COND_EXPR: op = cUNOPx(op)->op_first; while ((op = OpSIBLING(op))) da_lvalue(aTHX_ op, list); break; case OP_SCOPE: case OP_LEAVE: case OP_LINESEQ: op = (op->op_flags & OPf_KIDS) ? cUNOPx(op)->op_first : NULL; while (OpHAS_SIBLING(op)) op = OpSIBLING(op); da_lvalue(aTHX_ op, list); break; case OP_PUSHMARK: if (!list) goto bad; break; case OP_PADAV: if (!list) goto bad; if (op->op_ppaddr != DataAlias_pp_padsv) op->op_ppaddr = DataAlias_pp_padav; break; case OP_PADHV: if (!list) goto bad; if (op->op_ppaddr != DataAlias_pp_padsv) op->op_ppaddr = DataAlias_pp_padhv; break; case OP_RV2AV: if (!list) goto bad; if (op->op_ppaddr != DataAlias_pp_rv2sv) op->op_ppaddr = DataAlias_pp_rv2av; break; case OP_RV2HV: if (!list) goto bad; if (op->op_ppaddr != DataAlias_pp_rv2sv) op->op_ppaddr = DataAlias_pp_rv2hv; break; case OP_UNDEF: if (!list || (op->op_flags & OPf_KIDS)) goto bad; break; default: bad: qerror(Perl_mess(aTHX_ DA_TARGET_ERR_AT, OutCopFILE(PL_curcop), (UV) CopLINE(PL_curcop))); } } STATIC void da_aassign(OP *op, OP *right) { OP *left, *la, *ra; int hash = FALSE, pad; /* make sure it fits the model exactly */ if (!right || !(left = OpSIBLING(right)) || OpHAS_SIBLING(left)) return; if (left->op_type || !(left->op_flags & OPf_KIDS)) return; if (!(left = cUNOPx(left)->op_first) || !IS_PUSHMARK_OR_PADRANGE(left)) return; if (!(la = OpSIBLING(left)) || OpHAS_SIBLING(la)) return; if (la->op_flags & OPf_PARENS) return; switch (la->op_type) { case OP_PADHV: hash = TRUE; case OP_PADAV: pad = TRUE; break; case OP_RV2HV: hash = TRUE; case OP_RV2AV: pad = FALSE; break; default: return; } if (right->op_type || !(right->op_flags & OPf_KIDS)) return; if (!(right = cUNOPx(right)->op_first) || !IS_PUSHMARK_OR_PADRANGE(right)) return; op->op_private = hash ? OPpALIASHV : OPpALIASAV; la->op_ppaddr = pad ? DataAlias_pp_padsv : DataAlias_pp_rv2sv; if (pad) { la->op_type = OP_PADSV; #if DA_HAVE_OP_PADRANGE if (left->op_type == OP_PADRANGE) left->op_ppaddr = DataAlias_pp_padrange_single; else if (right->op_type == OP_PADRANGE && (right->op_flags & OPf_SPECIAL)) right->op_ppaddr = DataAlias_pp_padrange_single; #endif } if (!(ra = OpSIBLING(right)) || OpHAS_SIBLING(ra)) return; if (ra->op_flags & OPf_PARENS) return; if (hash) { if (ra->op_type != OP_PADHV && ra->op_type != OP_RV2HV) return; } else { if (ra->op_type != OP_PADAV && ra->op_type != OP_RV2AV) return; } ra->op_flags &= -2; ra->op_flags |= OPf_REF; } STATIC int da_transform(pTHX_ OP *op, int sib) { int hits = 0; while (op) { OP *kid = Nullop, *tmp; int ksib = TRUE; OPCODE optype; if (op->op_flags & OPf_KIDS) kid = cUNOPx(op)->op_first; ++hits; switch ((optype = op->op_type)) { case OP_NULL: optype = (OPCODE) op->op_targ; default: --hits; switch (optype) { case_OP_SETSTATE_ case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = (COP *) op; break; case OP_LIST: if (op->op_ppaddr == da_tag_list) { da_peep2(aTHX_ op); return hits; } break; } break; case OP_LEAVE: if (op->op_ppaddr != da_tag_entersub) op->op_ppaddr = DataAlias_pp_leave; else hits--; break; case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVETRY: op->op_ppaddr = DataAlias_pp_leavesub; break; case OP_RETURN: op->op_ppaddr = DataAlias_pp_return; break; case OP_ENTEREVAL: op->op_ppaddr = DataAlias_pp_entereval; break; case OP_CONST: --hits; { SV *sv = cSVOPx_sv(op); SvPADTMP_off(sv); SvREADONLY_on(sv); } break; case OP_GVSV: if (op->op_private & OPpLVAL_INTRO) op->op_ppaddr = DataAlias_pp_gvsv_r; else hits--; break; case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: if (op->op_private & OPpLVAL_INTRO) op->op_ppaddr = DataAlias_pp_rv2sv_r; else hits--; break; case OP_SREFGEN: op->op_ppaddr = DataAlias_pp_srefgen; break; case OP_REFGEN: op->op_ppaddr = DataAlias_pp_refgen; break; case OP_AASSIGN: op->op_ppaddr = DataAlias_pp_aassign; op->op_private = 0; da_aassign(op, kid); MOD(kid); ksib = FALSE; #if DA_HAVE_OP_PADRANGE for (tmp = kid; tmp->op_type == OP_NULL && (tmp->op_flags & OPf_KIDS); ) tmp = cUNOPx(tmp)->op_first; if (tmp->op_type == OP_PADRANGE && (tmp->op_flags & OPf_SPECIAL)) da_lvalue(aTHX_ tmp, TRUE); else #endif da_lvalue(aTHX_ OpSIBLING(kid), TRUE); break; case OP_SASSIGN: op->op_ppaddr = DataAlias_pp_sassign; MOD(kid); ksib = FALSE; if (!(op->op_private & OPpASSIGN_BACKWARDS)) da_lvalue(aTHX_ OpSIBLING(kid), FALSE); break; case OP_ANDASSIGN: op->op_ppaddr = DataAlias_pp_andassign; if (0) case OP_ORASSIGN: op->op_ppaddr = DataAlias_pp_orassign; #if DA_HAVE_OP_DORASSIGN if (0) case OP_DORASSIGN: op->op_ppaddr = DataAlias_pp_dorassign; #endif da_lvalue(aTHX_ kid, FALSE); kid = OpSIBLING(kid); break; case OP_UNSHIFT: if (!(tmp = OpSIBLING(kid))) break; /* array */ if (!(tmp = OpSIBLING(tmp))) break; /* first elem */ op->op_ppaddr = DataAlias_pp_unshift; goto mod; case OP_PUSH: if (!(tmp = OpSIBLING(kid))) break; /* array */ if (!(tmp = OpSIBLING(tmp))) break; /* first elem */ op->op_ppaddr = DataAlias_pp_push; goto mod; case OP_SPLICE: if (!(tmp = OpSIBLING(kid))) break; /* array */ if (!(tmp = OpSIBLING(tmp))) break; /* offset */ if (!(tmp = OpSIBLING(tmp))) break; /* length */ if (!(tmp = OpSIBLING(tmp))) break; /* first elem */ op->op_ppaddr = DataAlias_pp_splice; goto mod; case OP_ANONLIST: if (!(tmp = OpSIBLING(kid))) break; /* first elem */ op->op_ppaddr = DataAlias_pp_anonlist; goto mod; case OP_ANONHASH: if (!(tmp = OpSIBLING(kid))) break; /* first elem */ op->op_ppaddr = DataAlias_pp_anonhash; mod: do MOD(tmp); while ((tmp = OpSIBLING(tmp))); } if (sib && OpHAS_SIBLING(op)) { if (kid) hits += da_transform(aTHX_ kid, ksib); op = OpSIBLING(op); } else { op = kid; sib = ksib; } } return hits; } STATIC void da_peep2(pTHX_ OP *o) { OP *k, *lsop, *pmop, *argop, *cvop, *esop; int useful; while (o->op_ppaddr != da_tag_list) { while (OpHAS_SIBLING(o)) { if ((o->op_flags & OPf_KIDS) && (k = cUNOPo->op_first)){ da_peep2(aTHX_ k); } else switch (o->op_type ? o->op_type : o->op_targ) { case_OP_SETSTATE_ case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = (COP *) o; } o = OpSIBLING(o); } if (!(o->op_flags & OPf_KIDS) || !(o = cUNOPo->op_first)) return; } lsop = o; useful = lsop->op_private & OPpUSEFUL; op_null(lsop); lsop->op_ppaddr = PL_ppaddr[OP_NULL]; pmop = cLISTOPx(lsop)->op_first; argop = cLISTOPx(lsop)->op_last; if (!(cvop = cUNOPx(pmop)->op_first) || cvop->op_ppaddr != da_tag_rv2cv) { Perl_warn(aTHX_ "da peep weirdness 1"); return; } OpMORESIB_set(argop, cvop); OpLASTSIB_set(cvop, lsop); cLISTOPx(lsop)->op_last = cvop; if (!(esop = cvop->op_next) || esop->op_ppaddr != da_tag_entersub) { Perl_warn(aTHX_ "da peep weirdness 2"); return; } esop->op_type = OP_ENTERSUB; if (cvop->op_flags & OPf_SPECIAL) { esop->op_ppaddr = DataAlias_pp_copy; da_peep2(aTHX_ pmop); } else if (!da_transform(aTHX_ pmop, TRUE) && !useful && ckWARN(WARN_VOID)) { Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of alias"); } } STATIC void da_peep(pTHX_ OP *o) { dDAforce; da_old_peepp(aTHX_ o); ENTER; SAVEVPTR(PL_curcop); if (da_inside && da_iscope == &cxstack[cxstack_ix]) { OP *tmp; while ((tmp = o->op_next)) o = tmp; if (da_transform(aTHX_ o, FALSE)) da_inside = 2; } else { da_peep2(aTHX_ o); } LEAVE; } #define LEX_NORMAL 10 #define LEX_INTERPNORMAL 9 #if DA_HAVE_LEX_KNOWNEXT #define LEX_KNOWNEXT 0 #endif STATIC OP *da_ck_rv2cv(pTHX_ OP *o) { dDA; SV **sp, *gvsv; OP *kid; char *s, *start_s; CV *cv; o = da_old_ck_rv2cv(aTHX_ o); #if (PERL_COMBI_VERSION >= 5009005) if (!PL_parser) return o; #endif if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL) return o; /* not lexing? */ kid = cUNOPo->op_first; if (kid->op_type != OP_GV || !DA_ACTIVE || ( (gvsv = (SV*)kGVOP_gv, cv = #if (PERL_COMBI_VERSION >= 5021004) SvROK(gvsv) ? (CV*)SvRV(gvsv) : #endif GvCV((GV*)gvsv), 1) && cv != da_cv && cv != da_cvc )) return o; if (o->op_private & OPpENTERSUB_AMPER) return o; SvPOK_off(cv); o->op_ppaddr = da_tag_rv2cv; if (cv == da_cv) o->op_flags &= ~OPf_SPECIAL; else o->op_flags |= OPf_SPECIAL; start_s = s = PL_oldbufptr; while (s < PL_bufend && isSPACE(*s)) s++; if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf))) { s += strlen(PL_tokenbuf); if (PL_bufptr > s) s = PL_bufptr; #if (PERL_COMBI_VERSION >= 5011002) { char *old_buf = SvPVX(PL_linestr); char *old_bufptr = PL_bufptr; PL_bufptr = s; lex_read_space(LEX_KEEP_PREVIOUS); if (SvPVX(PL_linestr) != old_buf) Perl_croak(aTHX_ "Data::Alias can't handle " "lexer buffer reallocation"); s = PL_bufptr; PL_bufptr = old_bufptr; } #else while (s < PL_bufend && isSPACE(*s)) s++; #endif } else { s = ""; } if (*s == '{') { /* here comes deep magic */ I32 shift; int tok; YYSTYPE yylval = PL_yylval; PL_bufptr = s; PL_expect = XSTATE; tok = yylex(); PL_nexttype[PL_nexttoke++] = tok; if (tok == '{') { PL_nexttype[PL_nexttoke++] = DO; sv_setpv((SV *) cv, "$"); if ((PERL_COMBI_VERSION >= 5021004) || (PERL_COMBI_VERSION >= 5011002 && *PL_bufptr == '(')) { /* * On 5.21.4+, PL_expect can't be * directly set as we'd like, and ends * up wrong for parsing the interior of * the block. Rectify it by injecting * a semicolon, lexing of which sets * PL_expect appropriately. On 5.11.2+, * a paren here triggers special lexer * behaviour for a parenthesised argument * list, which screws up the normal * parsing that we want to continue. * Suppress it by injecting a semicolon. * Either way, apart from this tweaking of * the lexer the semicolon is a no-op, * coming as it does just after the * opening brace of a block. */ Move(PL_bufptr, PL_bufptr+1, PL_bufend+1-PL_bufptr, char); *PL_bufptr = ';'; PL_bufend++; SvCUR(PL_linestr)++; } } #if DA_HAVE_LEX_KNOWNEXT if(PL_lex_state != LEX_KNOWNEXT) { PL_lex_defer = PL_lex_state; #if (PERL_COMBI_VERSION < 5021004) PL_lex_expect = PL_expect; #endif PL_lex_state = LEX_KNOWNEXT; } #endif PL_yylval = yylval; if ((shift = s - PL_bufptr)) { /* here comes deeper magic */ s = SvPVX(PL_linestr); PL_bufptr += shift; if ((PL_oldbufptr += shift) < s) PL_oldbufptr = s; if ((PL_oldoldbufptr += shift) < s) PL_oldbufptr = s; if (PL_last_uni && (PL_last_uni += shift) < s) PL_last_uni = s; if (PL_last_lop && (PL_last_lop += shift) < s) PL_last_lop = s; if (shift > 0) { STRLEN len = SvCUR(PL_linestr) + 1; if (len + shift > SvLEN(PL_linestr)) len = SvLEN(PL_linestr) - shift; Move(s, s + shift, len, char); SvCUR(PL_linestr) = len + shift - 1; } else { STRLEN len = SvCUR(PL_linestr) + shift + 1; Move(s - shift, s, len, char); SvCUR(PL_linestr) += shift; } *(PL_bufend = s + SvCUR(PL_linestr)) = '\0'; if (start_s < PL_bufptr) memset(start_s, ' ', PL_bufptr-start_s); } } if (da_iscope != &cxstack[cxstack_ix]) { SAVEVPTR(da_iscope); SAVEI32(da_inside); da_iscope = &cxstack[cxstack_ix]; } SPAGAIN; XPUSHs(da_inside ? &PL_sv_yes : &PL_sv_no); da_inside = (cv == da_cv); PUTBACK; return o; } STATIC OP *da_ck_entersub(pTHX_ OP *esop) { dDA; OP *lsop, *cvop, *pmop, *argop; int inside; if (!(esop->op_flags & OPf_KIDS)) return da_old_ck_entersub(aTHX_ esop); lsop = cUNOPx(esop)->op_first; if (!(lsop->op_type == OP_LIST || (lsop->op_type == OP_NULL && lsop->op_targ == OP_LIST)) || OpHAS_SIBLING(lsop) || !(lsop->op_flags & OPf_KIDS)) return da_old_ck_entersub(aTHX_ esop); cvop = cLISTOPx(lsop)->op_last; if (!DA_ACTIVE || cvop->op_ppaddr != da_tag_rv2cv) return da_old_ck_entersub(aTHX_ esop); inside = da_inside; da_inside = SvIVX(*PL_stack_sp--); SvPOK_off(inside ? da_cv : da_cvc); op_clear(esop); RenewOpc(0, esop, 1, LISTOP, OP); OpLASTSIB_set(lsop, esop); esop->op_type = inside ? OP_SCOPE : OP_LEAVE; esop->op_ppaddr = da_tag_entersub; cLISTOPx(esop)->op_last = lsop; lsop->op_type = OP_LIST; lsop->op_targ = 0; lsop->op_ppaddr = da_tag_list; if (inside > 1) lsop->op_private |= OPpUSEFUL; else lsop->op_private &= ~OPpUSEFUL; pmop = cLISTOPx(lsop)->op_first; if (inside) op_null(pmop); RenewOpc(0, pmop, 1, UNOP, OP); cLISTOPx(lsop)->op_first = pmop; #if (PERL_COMBI_VERSION >= 5021006) pmop->op_type = OP_CUSTOM; #endif pmop->op_next = pmop; cUNOPx(pmop)->op_first = cvop; OpLASTSIB_set(cvop, pmop); argop = pmop; while (OpSIBLING(argop) != cvop) argop = OpSIBLING(argop); cLISTOPx(lsop)->op_last = argop; OpLASTSIB_set(argop, lsop); if (argop->op_type == OP_NULL && inside) argop->op_flags &= ~OPf_SPECIAL; cvop->op_next = esop; return esop; } #if (PERL_COMBI_VERSION >= 5021007) STATIC OP *da_ck_aelem(pTHX_ OP *o) { return da_old_ck_aelem(aTHX_ o); } STATIC OP *da_ck_helem(pTHX_ OP *o) { return da_old_ck_helem(aTHX_ o); } #endif MODULE = Data::Alias PACKAGE = Data::Alias PROTOTYPES: DISABLE BOOT: { dDA; DA_INIT; da_cv = get_cv("Data::Alias::alias", TRUE); da_cvc = get_cv("Data::Alias::copy", TRUE); wrap_op_checker(OP_RV2CV, da_ck_rv2cv, &da_old_ck_rv2cv); wrap_op_checker(OP_ENTERSUB, da_ck_entersub, &da_old_ck_entersub); #if (PERL_COMBI_VERSION >= 5021007) { /* * The multideref peep-time optimisation, introduced in * Perl 5.21.7, is liable to incorporate into a multideref * op aelem/helem ops that we need to modify. Because our * modification of those ops gets applied late at peep * time, after the main peeper, the specialness of the * ops doesn't get a chance to inhibit incorporation * into a multideref. As an ugly hack, we disable the * multideref optimisation entirely for these op types * by hooking their checking (and not actually doing * anything in the checker). * * The multideref peep-time code has no logical * reason to look at whether the op checking is in a * non-default state. It deals with already-checked ops, * so a check hook cannot make any difference to the * future behaviour of those ops. Rather, it should, * but currently (5.23.4) doesn't, check that op_ppaddr * of the op to be incorporated has the standard value. * If the superfluous PL_check[] check goes away, this * hack will break. * * The proper fix for this problem would be to move our op * munging from peep time to op check time. When ops are * placed into an alias() wrapper they should be walked, * and the contained assignments and lvalues modified. * The modified lvalue aelem/helem ops would thereby be * made visibly non-standard in plenty of time for the * multideref peep-time code to avoid replacing them. * If the multideref code is changed to look at op_ppaddr * then that change alone will be sufficient; failing * that the op_type can be changed to OP_CUSTOM. */ wrap_op_checker(OP_AELEM, da_ck_aelem, &da_old_ck_aelem); wrap_op_checker(OP_HELEM, da_ck_helem, &da_old_ck_helem); } #endif CvLVALUE_on(get_cv("Data::Alias::deref", TRUE)); da_old_peepp = PL_peepp; PL_peepp = da_peep; } void deref(...) PREINIT: I32 i, n = 0; SV *sv; PPCODE: for (i = 0; i < items; i++) { if (!SvROK(ST(i))) { STRLEN z; if (SvOK(ST(i))) Perl_croak(aTHX_ DA_DEREF_ERR, SvPV(ST(i), z)); if (ckWARN(WARN_UNINITIALIZED)) Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), "Use of uninitialized value in deref"); continue; } sv = SvRV(ST(i)); switch (SvTYPE(sv)) { I32 x; case SVt_PVAV: if (!(x = av_len((AV *) sv) + 1)) continue; SP += x; break; case SVt_PVHV: if (!(x = HvKEYS(sv))) continue; SP += x * 2; break; case SVt_PVCV: Perl_croak(aTHX_ "Can't deref subroutine reference"); case SVt_PVFM: Perl_croak(aTHX_ "Can't deref format reference"); case SVt_PVIO: Perl_croak(aTHX_ "Can't deref filehandle reference"); default: SP++; } ST(n++) = ST(i); } EXTEND(SP, 0); for (i = 0; n--; ) { SV *sv = SvRV(ST(n)); I32 x = SvTYPE(sv); if (x == SVt_PVAV) { i -= x = AvFILL((AV *) sv) + 1; Copy(AvARRAY((AV *) sv), SP + i + 1, INT2SIZE(x), SV *); } else if (x == SVt_PVHV) { HE *entry; HV *hv = (HV *) sv; i -= x = hv_iterinit(hv) * 2; PUTBACK; while ((entry = hv_iternext(hv))) { sv = hv_iterkeysv(entry); SvREADONLY_on(sv); SPAGAIN; SP[++i] = sv; sv = hv_iterval(hv, entry); SPAGAIN; SP[++i] = sv; } i -= x; } else { SP[i--] = sv; } } Data-Alias-1.21/t/0000755000175000017500000000000013212443455013135 5ustar zeframzeframData-Alias-1.21/t/17_alias_lex_inner.t0000644000175000017500000000222311661277703016773 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 34; use Data::Alias; my ($x, $y, $z); my $T = 42; is \alias($x = $y), \$y; is \$x, \$y; is \alias($x = $z), \$z; is \$x, \$z; isnt \$y, \$z; is \alias($x ||= $T), \$T; is \$x, \$T; isnt \alias($x ||= $y), \$y; is \$x, \$T; is \alias($x &&= $z), \$z; is \$x, \$z; isnt \alias($x &&= $T), \$T; is \$x, \$z; my (@x, @y, @z); is \alias(@x = @y), \@y; is \@x, \@y; is \alias(@x = @z), \@z; is \@x, \@z; isnt \@y, \@z; @x = (); @z = (42); isnt \alias(@x = (@z)), \@z; isnt \@x, \@z; is \$x[0], \$z[0]; my (%x, %y, %z); is \alias(%x = %y), \%y; is \%x, \%y; is \alias(%x = %z), \%z; is \%x, \%z; isnt \%y, \%z; %x = (); %z = (x => 42); isnt \alias(%x = (%z)), \%z; isnt \%x, \%z; is \$x{x}, \$z{x}; my $outer = "outer"; sub foo { no warnings 'closure'; alias $outer = "inner"; sub { $outer } } is foo->(), "inner"; is $outer, "outer"; eval 'sub { alias $outer = "inner"; }'; like $@, qr/^Aliasing of outer lexical variable has limited scope/; sub bar { alias my $x &&= 42; alias my $y ||= 42; [$x, $y] } is bar->[0], undef; is bar->[1], 42; # vim: ft=perl Data-Alias-1.21/t/01_deref.t0000644000175000017500000000217511661277703014723 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 12; use Data::Alias 'deref'; sub refs { [map "".\$_, @_] } our $x = \1; our $y = [2, 3, 4]; our $z = {5 => 6, 7 => 8}; is_deeply [deref $x, $y, $z], [$$x, @$y, %$z]; is_deeply refs((deref $x, $y, $z)[0,1,2,3,5,7]), refs($$x, @$y, (%$z)[1,3]); our @r = \(($x, $y, $z) = (1, 2, 3)); $_++ for deref @r; is_deeply [$x, $y, $z], [2, 3, 4]; (deref @r) = (42, 43, 44); is_deeply [$x, $y, $z], [42, 43, 44]; eval { deref undef }; like $@, qr/^Use of uninitialized value in deref /; is_deeply [do { no warnings 'uninitialized'; deref undef }], []; eval { no warnings; deref "" }; like $@, qr/^Can't deref string /; our @n; our %n; is_deeply refs(deref \$x, \@n, \$y, \$z), refs($x, $y, $z); is_deeply refs(deref \$x, \%n, \$y, \$z), refs($x, $y, $z); format foo = . eval { no warnings; deref \&refs }; like $@, qr/^Can't deref subroutine reference /; eval { no warnings; deref *foo{FORMAT} }; like $@, qr/^Can't deref format reference /; eval { no warnings; deref *STDOUT{IO} }; like $@, qr/^Can't deref filehandle reference /; # vim: ft=perl Data-Alias-1.21/t/pod_syn.t0000644000175000017500000000023611661277703015005 0ustar zeframzeframuse warnings; use strict; use Test::More; plan skip_all => "Test::Pod not available" unless eval "use Test::Pod 1.00; 1"; Test::Pod::all_pod_files_ok(); 1; Data-Alias-1.21/t/13_alias_pkg_array.t0000644000175000017500000000132211661277703016762 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 24; use Data::Alias; our (@x, @y, @z); is \alias(@x = @y), \@y; is \@x, \@y; is \alias(@x = @z), \@z; is \@x, \@z; isnt \@y, \@z; alias { is \(local @x = @y), \@y; is \@x, \@y }; is \@x, \@z; @x = (); @y = (42); isnt \alias(@x = (@y)), \@y; isnt \@x, \@y; is \$x[0], \$y[0]; my $gx = *x; is alias(*$gx = \@y), \@y; is \@x, \@y; is \alias(@$gx = @z), \@z; is \@x, \@z; alias { is +(local *$gx = \@y), \@y; is \@x, \@y }; is \@x, \@z; alias { is \(local @$gx = @y), \@y; is \@x, \@y }; is \@x, \@z; my $gy = *y; @x = (); @y = (42); isnt \alias(@$gx = (@$gy)), \@y; isnt \@x, \@y; is \$x[0], \$y[0]; # vim: ft=perl Data-Alias-1.21/t/05_alias_parse2.t0000644000175000017500000000157013133536553016202 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 17; use Data::Alias qw/alias copy/; our $x; our $y; alias { BEGIN { $x = $y } }; BEGIN { is \$x, \$y; alias $y = copy 42 } alias { BEGIN { do "./t/lib/assign.pm" or die $! } }; isnt \$x, \$y; is $x, 42; our $z = 1; alias($x = $y) = $z; is \$x, \$y; isnt \$x, \$z; is $x, $z; alias { sub foo { $x = $y } }; is \foo, \$y; is \$x, \$y; alias(sub { $x = $z })->(); is \$x, \$z; $x++; alias { {;} $x } = $y; is \$x, \$z; is $x, $y; eval "{;}\n\nalias { Data::Alias::deref = 42 };\n\n{;}\n"; like $@, qr/^Unsupported alias target .* line 3\b/; eval "{;}\n\n\$x = alias \$y;\n\n{;}\n"; like $@, qr/^Useless use of alias .* line 3\b/; is \alias(sub { $x })->(), \$x; no warnings 'void'; alias copy alias copy $x = 99; is \$x, \$z; is $x, 99; # vim: ft=perl is \undef, scalar \alias Data-Alias-1.21/t/28_alias_const.t0000644000175000017500000000053211661277703016141 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 5; use Data::Alias; alias my $foo = "foo"; alias my $bar = $foo; is \$foo, \$bar; eval { $foo = 42 }; is $foo, "foo"; my @x; for (0, 1) { alias $x[$_] = $_ + 1; } is $x[0], 1; is $x[1], 2; eval { $x[1] = 42 }; is $x[1], 2; # vim: ft=perl Data-Alias-1.21/t/devel_callparser.t0000644000175000017500000000047211661277703016643 0ustar zeframzeframuse warnings; no warnings "void"; use strict; BEGIN { eval { require Devel::CallParser }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "Devel::CallParser unavailable"); } } use Test::More tests => 2; use Devel::CallParser (); use Data::Alias; is alias(42), 42; is alias{42}, 42; 1; Data-Alias-1.21/t/09_alias_push.t0000644000175000017500000000100611661277703015766 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); no warnings 'syntax'; use lib 'lib'; use Test::More tests => 10; use Data::Alias; sub refs { [map "".\$_, @_] } @_ = (); is alias(push @_), 0; is alias(push @_, our $x), 1; is_deeply &refs, refs($x); is alias(push @_, our ($y, $z)), 3; is_deeply &refs, refs($x, $y, $z); is alias(push @_), 3; is alias(push @_, $x), 4; is_deeply &refs, refs($x, $y, $z, $x); is alias(push @_, $y, $z), 6; is_deeply &refs, refs($x, $y, $z, $x, $y, $z); # vim: ft=perl Data-Alias-1.21/t/14_alias_pkg_hash.t0000644000175000017500000000133411661277703016573 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 24; use Data::Alias; our (%x, %y, %z); is \alias(%x = %y), \%y; is \%x, \%y; is \alias(%x = %z), \%z; is \%x, \%z; isnt \%y, \%z; alias { is \(local %x = %y), \%y; is \%x, \%y }; is \%x, \%z; %x = (); %y = (x => 42); isnt \alias(%x = (%y)), \%y; isnt \%x, \%y; is \$x{x}, \$y{x}; my $gx = *x; is alias(*$gx = \%y), \%y; is \%x, \%y; is \alias(%$gx = %z), \%z; is \%x, \%z; alias { is +(local *$gx = \%y), \%y; is \%x, \%y }; is \%x, \%z; alias { is \(local %$gx = %y), \%y; is \%x, \%y }; is \%x, \%z; my $gy = *y; %x = (); %y = (x => 42); isnt \alias(%$gx = (%$gy)), \%y; isnt \%x, \%y; is \$x{x}, \$y{x}; # vim: ft=perl Data-Alias-1.21/t/08_alias_anon_hash.t0000644000175000017500000000210611661277703016746 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 20; use Data::Alias; sub refs { [map "".\$_, @_] } our $x = alias {}; is %$x, 0; is_deeply alias({$_, 0}), {$_, 0} for 1 .. 3; $x = alias {x => 42}; eval { $x->{x}++ }; like $@, qr/^Modification .* attempted /; $x = alias {x => $x}; is_deeply [sort keys %$x], ["x"]; is_deeply refs($$x{x}), refs($x); $x = alias {x => $x, y => our $y}; is_deeply [sort keys %$x], ["x", "y"]; is_deeply refs(@$x{"x", "y"}), refs($x, $y); $x = alias {x => $x, y => $y, z => our $z}; is_deeply [sort keys %$x], ["x", "y", "z"]; is_deeply refs(@$x{"x", "y", "z"}), refs($x, $y, $z); $x = alias {x => 1, x => 2, x => 3}; is $x->{x}, 3; $x = alias {x => undef, y => $y, z => undef}; is keys %$x, 1; is \$x->{y}, \$y; ok !exists $x->{x}; ok !exists $x->{z}; no warnings 'misc'; $x = alias {x => $x, y => $y, y => }; is keys %$x, 1; is \$x->{x}, \$x; use warnings qw(FATAL misc); $x = eval { alias {x => $x, y => } }; is $x, undef; like $@, qr/^Odd number of elements in anonymous hash /; # vim: ft=perl Data-Alias-1.21/t/16_alias_refs.t0000644000175000017500000000170611661277703015753 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 20; use Data::Alias; our ($y, $z); our $r1; is \alias($$r1 = $y), \$y; is $r1, \$y; is \alias($$r1 = $z), \$z; is $r1, \$z; eval { alias local $$r1 = $y }; like $@, qr/^Can't localize through a reference /; our (@y, @z); our $r2; is \alias(@$r2 = @y), \@y; is $r2, \@y; is \alias(@$r2 = @z), \@z; is $r2, \@z; eval { alias local @$r2 = @y }; like $@, qr/^Can't localize through a reference /; our (%y, %z); our $r3; is \alias(%$r3 = %y), \%y; is $r3, \%y; is \alias(%$r3 = %z), \%z; is $r3, \%z; eval { alias local %$r3 = %y }; like $@, qr/^Can't localize through a reference /; alias $r1 = \$y; is $r1, \$y; eval { $r1 = undef }; like $@, qr/^Modification of a read-only value attempted /; alias $r2 = [$y, $z]; is \$r2->[0], \$y; is \$r2->[1], \$z; eval {}; eval { $r2 = undef }; like $@, qr/^Modification of a read-only value attempted /; # vim: ft=perl Data-Alias-1.21/t/12_alias_pkg_scalar.t0000644000175000017500000000156711661277703017123 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 34; use Data::Alias; our ($x, $y, $z); our $T = 42; is \alias($x = $y), \$y; is \$x, \$y; is \alias($x = $z), \$z; is \$x, \$z; isnt \$y, \$z; is \alias($x ||= $T), \$T; is \$x, \$T; isnt \alias($x ||= $y), \$y; is \$x, \$T; is \alias($x &&= $z), \$z; is \$x, \$z; isnt \alias($x &&= $T), \$T; is \$x, \$z; alias { is \(local $x = $y), \$y; is \$x, \$y }; is \$x, \$z; my $gx = *x; is alias(*$gx = \$y), \$y; is \$x, \$y; is \alias($$gx = $z), \$z; is \$x, \$z; is \alias($$gx ||= $T), \$T; is \$x, \$T; isnt \alias($$gx ||= $y), \$y; is \$x, \$T; is \alias($$gx &&= $z), \$z; is \$x, \$z; isnt \alias($$gx &&= $T), \$T; is \$x, \$z; alias { is +(local *$gx = \$y), \$y; is \$x, \$y }; is \$x, \$z; alias { is \(local $$gx = $y), \$y; is \$x, \$y }; is \$x, \$z; # vim: ft=perl Data-Alias-1.21/t/25_alias_weakref.t0000644000175000017500000000101711661277703016433 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 4; use Data::Alias; SKIP: { skip "Scalar::Util not installed", 4 unless eval "use Scalar::Util qw/ weaken /; 42"; my $x = {}; my $y = {}; my $keepalive = $x; weaken($x); alias $x->{foo} = $y->{foo}; $x->{foo} = 42; undef $keepalive; is $x, undef; is $y->{foo}, 42; $x = []; $keepalive = $x; weaken($x); alias push @$x, $y; $y = 42; is "@$keepalive", 42; undef $keepalive; is $x, undef; } # vim: ft=perl Data-Alias-1.21/t/threads.t0000644000175000017500000000071712217331125014753 0ustar zeframzeframuse warnings; use strict; BEGIN { eval { require threads; }; if($@ =~ /\AThis Perl not built to support threads/) { require Test::More; Test::More::plan(skip_all => "non-threading perl build"); } if($@ ne "") { require Test::More; Test::More::plan(skip_all => "threads unavailable"); } } use threads; use Test::More tests => 1; use Data::Alias; sub worker { eval "1 + 1"; return 1; } my $thr = threads->create(\&worker); $thr->join(); ok 1; 1; Data-Alias-1.21/t/04_swap.t0000644000175000017500000000045211661277703014607 0ustar zeframzeframuse strict; use warnings qw(FATAL all); no warnings 'void'; use lib 'lib'; use Test::More tests => 4; use Data::Alias; our $x = "x"; my $xref = "@{[\$x]}"; our $y = "y"; my $yref = "@{[\$y]}"; alias { ($x, $y) = ($y, $x) }; is $x, "y"; is $y, "x"; is "@{[\$x]}", $yref; is "@{[\$y]}", $xref; 1; Data-Alias-1.21/t/pod_cvg.t0000644000175000017500000000027311661277703014754 0ustar zeframzeframuse warnings; use strict; use Test::More; plan skip_all => "Test::Pod::Coverage not available" unless eval "use Test::Pod::Coverage; 1"; Test::Pod::Coverage::all_pod_coverage_ok(); 1; Data-Alias-1.21/t/11_alias_splice.t0000644000175000017500000000376011661277703016270 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); no warnings 'syntax'; use lib 'lib'; use Test::More tests => 35; use Data::Alias; sub refs { [map "".\$_, @_] } our ($a, $b, $c, $d, $e, $f, $g); @_ = (); is_deeply refs(alias splice @_, 0, 0, $a, $b), []; is_deeply &refs, refs($a, $b); is_deeply refs(alias splice @_, 1, 0, $c, $d, $e), []; is_deeply &refs, refs($a, $c, $d, $e, $b); is_deeply refs(alias splice @_, 2, 1, $f, $g), refs($d); is_deeply &refs, refs($a, $c, $f, $g, $e, $b); is_deeply refs(alias splice @_, 1, 2, $d, $c), refs($c, $f); is_deeply &refs, refs($a, $d, $c, $g, $e, $b); is_deeply refs(alias splice @_, 1, 2, $f), refs($d, $c); is_deeply &refs, refs($a, $f, $g, $e, $b); is_deeply refs(alias splice @_, -5, 1, $c), refs($a); is_deeply &refs, refs($c, $f, $g, $e, $b); is_deeply refs(alias splice @_, -4, 1, $d), refs($f); is_deeply &refs, refs($c, $d, $g, $e, $b); is_deeply refs(alias splice @_, -1, 1, $a, $f), refs($b); is_deeply &refs, refs($c, $d, $g, $e, $a, $f); is_deeply refs(alias splice @_, 1, -3, $b), refs($d, $g); is_deeply &refs, refs($c, $b, $e, $a, $f); is_deeply refs(alias splice @_, -3, -1, $d, $g), refs($e, $a); is_deeply &refs, refs($c, $b, $d, $g, $f); is_deeply refs(alias splice @_, -2, -4, $e), []; is_deeply &refs, refs($c, $b, $d, $e, $g, $f); is_deeply refs(alias splice @_, -2, 4, $a), refs($g, $f); is_deeply &refs, refs($c, $b, $d, $e, $a); is_deeply refs(alias splice @_, 5, 0, $f), []; is_deeply &refs, refs($c, $b, $d, $e, $a, $f); eval { alias splice @_, 7, 0, $g }; like $@, qr/^splice\(\) offset past end of array /; { no warnings 'misc'; is_deeply refs(alias splice @_, 7, 0, $g), []; is_deeply &refs, refs($c, $b, $d, $e, $a, $f, $g); } is_deeply refs(alias splice @_, 2, 1), refs($d); is_deeply refs(alias splice @_, -3, 2), refs($a, $f); is_deeply refs(alias splice @_, 1, -2), refs($b); is_deeply refs(alias splice @_, -3, -2), refs($c); is_deeply refs(alias splice @_, -1), refs($g); is_deeply refs(alias splice @_), refs($e); # vim: ft=perl Data-Alias-1.21/t/10_alias_unshift.t0000644000175000017500000000103011661277703016454 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); no warnings 'syntax'; use lib 'lib'; use Test::More tests => 10; use Data::Alias; sub refs { [map "".\$_, @_] } @_ = (); is alias(unshift @_), 0; is alias(unshift @_, our $x), 1; is_deeply &refs, refs($x); is alias(unshift @_, our ($y, $z)), 3; is_deeply &refs, refs($y, $z, $x); is alias(unshift @_), 3; is alias(unshift @_, $x), 4; is_deeply &refs, refs($x, $y, $z, $x); is alias(unshift @_, $y, $z), 6; is_deeply &refs, refs($y, $z, $x, $y, $z, $x); # vim: ft=perl Data-Alias-1.21/t/20_alias_helem.t0000644000175000017500000000263311661277703016101 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 38; use Data::Alias; our %x; our $T = 42; is \alias($x{0} = $x{1}), \$x{1}; is \$x{0}, \$x{1}; is \alias($x{0} = $x{2}), \$x{2}; is \$x{0}, \$x{2}; isnt \$x{1}, \$x{2}; is \alias($x{0} ||= $T), \$T; is \$x{0}, \$T; isnt \alias($x{0} ||= $x{1}), \$x{1}; is \$x{0}, \$T; is \alias($x{0} &&= $x{2}), \$x{2}; is \$x{0}, \$x{2}; isnt \alias($x{0} &&= $T), \$T; is \$x{0}, \$x{2}; alias { is \(local $x{0} = $x{1}), \$x{1}; is \$x{0}, \$x{1} }; is \$x{0}, \$x{2}; is \alias($x{0} = undef), \undef; ok !exists $x{0}; sub{alias my ($y) = @_}->($x{0}); ok exists $x{0}; SKIP: { no warnings 'deprecated'; skip "pseudo-hashes not supported anymore", 19 unless eval { [{1,1},1]->{1} }; our $y = [{0 => 1, 1 => 2, 2 => 3}]; is \alias($y->{0} = $y->{1}), \$y->{1}; is \$y->{0}, \$y->{1}; is \alias($y->{0} = $y->{2}), \$y->{2}; is \$y->{0}, \$y->{2}; isnt \$y->{1}, \$y->{2}; is \alias($y->{0} ||= $T), \$T; is \$y->{0}, \$T; isnt \alias($y->{0} ||= $y->{1}), \$y->{1}; is \$y->{0}, \$T; is \alias($y->{0} &&= $y->{2}), \$y->{2}; is \$y->{0}, \$y->{2}; isnt \alias($y->{0} &&= $T), \$T; is \$y->{0}, \$y->{2}; alias { is \(local $y->{0} = $y->{1}), \$y->{1}; is \$y->{0}, \$y->{1} }; is \$y->{0}, \$y->{2}; is \alias($y->{0} = undef), \undef; ok !exists $y->{0}; sub{alias my ($x) = @_}->($y->{0}); ok exists $y->{0}; } # vim: ft=perl Data-Alias-1.21/t/06_alias_scope.t0000644000175000017500000000444411661277703016126 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 48; use Data::Alias; sub refs { [map "".\$_, @_] } sub ckvoid { ok !defined wantarray } sub context : lvalue { my $x = defined(wantarray) ? 1 + wantarray : 0; $x } our ($x, $y); no warnings 'void'; # context is alias(context), 1; is +(alias context)[0], 2; # do-blocks is alias { context }, 1; is +(alias { context })[0], 2; is \alias { undef }, \undef; is \alias { ckvoid; $x, $y }, \$y; is \alias { do { ckvoid; $x, $y } }, \$y; is_deeply refs(alias { do { ckvoid; $x, $y, undef } }), refs($x, $y, undef); is alias { local $_ = 42 }, 42; # verify curpm 0 =~ /(0)/; is $1, 0; alias { 42 =~ /(42)/; is $1, 42 }; is $1, 0; alias { our $z; local $z = 1 =~ /(1)/ until $1; ok !$z; is $1, 1 }; is $1, 0; # leavesub.. actually calls alias_pp_return for all the hard work alias sub { ckvoid }->(); alias(sub { ckvoid })->(); is alias(sub { context }->()), 1; is alias(sub { context })->(), 1; is \alias(sub { $x, $y }->()), \$y; is \alias(sub { $x, $y })->(), \$y; is +(alias sub { context }->())[0], 2; is +(alias(sub { context })->())[0], 2; is_deeply refs(alias sub { $x, $y }->()), refs($x, $y); is_deeply refs(alias(sub { $x, $y })->()), refs($x, $y); # leavesublv and leavetry call enter too... mostly tested, so keep it brief alias(sub : lvalue { ckvoid; $x })->(); is \alias(sub : lvalue { $x, $y })->(), \$y; is_deeply refs(alias(sub : lvalue { $x, $y })->()), refs($x, $y); alias(eval { ckvoid }); is \alias(eval { $x, $y }), \$y; is_deeply refs(alias eval { $x, $y }), refs($x, $y); # entereval / leaveeval alias(eval 'ckvoid'); is alias(eval 'context'), 1; is \alias(eval '$x, $y'), \$y; is +(alias eval 'context')[0], 2; is_deeply refs(alias eval '$x, $y'), refs($x, $y); # return itself.. mostly tested already, so keep it brief is \sub { alias return $x, $y }->(), \$y; is_deeply refs(sub { alias return $x, $y }->()), refs($x, $y); is \sub : lvalue { alias return $x, $y }->(), \$y; is_deeply refs(sub : lvalue { alias return $x, $y }->()), refs($x, $y); is \eval { alias return $x, $y }, \$y; is_deeply refs(eval { alias return $x, $y }), refs($x, $y); is \eval 'alias return $x, $y', \$y; is_deeply refs(eval 'alias return $x, $y'), refs($x, $y); is \sub { for (1) { alias return $x, $y } }->(), \$y; # vim: ft=perl Data-Alias-1.21/t/21_alias_list_basic.t0000644000175000017500000000215211661277703017120 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 24; use Data::Alias; sub refs { [map "".\$_, @_] } our ($x, $y, $z); is alias(($x) = ()), 0; is \$x, \undef; is_deeply refs(alias +($x) = ()), refs(undef); is \$x, \undef; is alias(($x) = $y), 1; is \$x, \$y; is_deeply refs(alias +($x) = $z), refs($z); is \$x, \$z; is alias(($x) = ($y, $z)), 2; is \$x, \$y; is_deeply refs(alias +($x) = ($z, $y)), refs($z); is \$x, \$z; is alias(($z, $y) = ($y, $z)), 2; is \$x, \$y; our $r = refs($y, $z); is_deeply refs(alias +($z, $y) = ($y, $z)), $r; is \$x, \$z; $r = refs($y, $x, $z); is_deeply refs(alias +($z, undef, $y) = ($y, $x, $z)), $r; is \$x, \$y; $r = *x; is_deeply refs(alias +(undef, $$r, undef) = ($r, $z, $y)), refs($r, $z, $y); is \$x, \$z; alias { $x = my $foo }; our (@x, %x); undef $r; alias +($x[0], $x{0}, $$r) = ($x, $y, $z); is \$x[0], \$x; is \$x{0}, \$y; is $r, \$z; SKIP: { no warnings 'deprecated'; skip "pseudo-hashes not supported anymore", 1 unless eval { [{1,1},1]->{1} }; $r = [{0=>1}]; alias +($r->{0}) = ($x); is \$r->[1], \$x; } # vim: ft=perl Data-Alias-1.21/t/04_alias_parse.t0000644000175000017500000000201411661277703016114 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); no warnings 'void'; use lib 'lib'; use Test::More tests => 23; use Data::Alias; eval { &alias }; like $@, qr/^Undefined subroutine /; eval { &alias(1) }; like $@, qr/^Undefined subroutine /; is alias(42), 42; is alias (42), 42; is alias{42}, 42; is alias#{{{{{{{ {#}}}}} 42 }, 42; is_deeply alias{},{}; is alias{1},1; is_deeply alias{x=>1},{x=>1}; is alias{{1}},1; is_deeply alias{{x=>1}},{x=>1}; is alias{{;x=>1}},1; is alias{;x=>1},1; our $x = "x"; is alias{{$x,1}},1; is_deeply alias{+{$x,1}},{x=>1}; is alias{$x,1},1; is_deeply alias+{$x,1},{x=>1}; is_deeply alias({$x,1}),{x=>1}; $x = alias 1, !alias { 2 }, 3; is $x, 3; $x = alias { !alias 1, 2 }, 3; is $x, !2; BEGIN { # install a source filter, just for fun if(eval { require Filter::Util::Call; 1 }) { Filter::Util::Call::filter_add(sub { my $s = Filter::Util::Call::filter_read(); return $s; }); } } is alias (42), 42; is alias{42}, 42; is alias#{{{{{{{ {#}}}}} 42 }, 42; # vim: ft=perl Data-Alias-1.21/t/24_alias_cond.t0000644000175000017500000000040311661277703015727 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 6; use Data::Alias; for (0, 1) { my ($x, $y, $z); is \alias($_ ? $y : $z = $x), \$x; is $_ ? \$y : \$z, \$x; isnt $_ ? \$z : \$y, \$x; } # vim: ft=perl Data-Alias-1.21/t/26_alias_local.t0000644000175000017500000000217511661277703016110 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 24; use Data::Alias; tie our $x, 'MyTie'; $x = 42; is $MyTie::var, 42; { alias local $x = 666; is $MyTie::var, 42; is $x, 666; } is $MyTie::var, 42; is ref(tied($x)), 'MyTie'; { alias local $x; is $MyTie::var, 42; undef *x; } is $MyTie::var, undef; is tied($x), undef; tie our @y, 'MyTie'; $y[0] = 42; is $MyTie::var, 42; { alias local @y = 666; is $MyTie::var, 42; is $y[0], 666; } is $MyTie::var, 42; is ref(tied(@y)), 'MyTie'; { alias local @y; is $MyTie::var, 42; undef *y; } is $MyTie::var, undef; is tied(@y), undef; tie our %z, 'MyTie'; $z{foo} = 42; is $MyTie::var, 42; { alias local %z = (foo => 666); is $MyTie::var, 42; is $z{foo}, 666; } is $MyTie::var, 42; is ref(tied(%z)), 'MyTie'; { alias local %z; is $MyTie::var, 42; undef *z; } is $MyTie::var, undef; is tied(%z), undef; package MyTie; our $var; sub TIESCALAR { bless {}, shift } sub TIEHASH { bless {}, shift } sub TIEARRAY { bless {}, shift } sub FETCH { $var } sub STORE { $var = pop } sub DESTROY { $var = undef } # vim: ft=perl Data-Alias-1.21/t/03_copy.t0000644000175000017500000000122611661277703014606 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 14; use Data::Alias 'copy'; sub refs { [map "".\$_, @_] } is copy($_), $_ for 1 .. 3; our $x = 42; our $y = 43; our $z = 44; is copy($x), $x; is copy { $x }, $x; isnt \copy($x), \$x; isnt \copy { $x }, \$x; is_deeply [copy $x, $y, $z], [$x, $y, $z]; our @r = refs(copy $x, $y, $z); isnt $r[0], \$x; isnt $r[1], \$y; isnt $r[2], \$z; sub mortal { 42 } sub nonmortal () { 42 } $x = "".\mortal; $y = "".\copy mortal; is $x, $y; $x = "".\nonmortal; $y = "".\copy nonmortal; isnt $x, $y; $x = "".\scalar copy(); $y = "".\undef; isnt $x, $y; # vim: ft=perl Data-Alias-1.21/t/07_alias_anon_array.t0000644000175000017500000000125112217326613017131 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 12; use Data::Alias; sub refs { [map "".\$_, @_] } our $x = alias []; is @$x, 0; is_deeply alias([$_]), [$_] for 1 .. 3; $x = alias [42]; eval { $x->[0]++ }; like $@, qr/^Modification .* attempted /; $x = alias [$x]; is_deeply refs(@$x), refs($x); $x = alias [$x, our $y]; is_deeply refs(@$x), refs($x, $y); $x = alias [$x, $y, our $z]; is_deeply refs(@$x), refs($x, $y, $z); $x = alias [undef, $y, undef]; is @$x, 3; is \$x->[1], \$y; ok "$]" < 5.019004 ? !exists($x->[0]) : \$x->[0] eq \undef; ok "$]" < 5.019004 ? !exists($x->[2]) : \$x->[2] eq \undef; # vim: ft=perl Data-Alias-1.21/t/29_alias_dorassign.t0000644000175000017500000000105511661277703017006 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More; BEGIN { if (eval 'my $x //= 42') { plan tests => 12; } else { plan skip_all => "//= not supported in this perl version"; } } use Data::Alias; my $U; my $E = ""; my $Z = 0; my $x; my $rx = \$x; is \alias($x //= $U), \$U; is \$x, \$U; is \alias($x //= $E), \$E; is \$x, \$E; is \alias($x //= $Z), \$E; is \$x, \$E; is \alias($x = $$rx), $rx; is \$x, $rx; is \alias($x //= $Z), \$Z; is \$x, \$Z; is \alias($x //= $E), \$Z; is \$x, \$Z; # vim: ft=perl Data-Alias-1.21/t/lib/0000755000175000017500000000000013212443455013703 5ustar zeframzeframData-Alias-1.21/t/lib/assign.pm0000644000175000017500000000002011661277703015524 0ustar zeframzefram$::x = $::y; 42 Data-Alias-1.21/t/lib/Test/0000755000175000017500000000000013212443455014622 5ustar zeframzeframData-Alias-1.21/t/lib/Test/Builder.pm0000644000175000017500000007377311661277703016576 0ustar zeframzeframpackage Test::Builder; use 5.004; # $^C was only introduced in 5.005-ish. We do this to prevent # use of uninitialized value warnings in older perls. $^C ||= 0; use strict; use vars qw($VERSION $CLASS); $VERSION = '0.17'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; if( $] >= 5.008 && $Config{useithreads} ) { require threads; require threads::shared; threads::shared->import; } else { *share = sub { 0 }; *lock = sub { 0 }; } } use vars qw($Level); my($Test_Died) = 0; my($Have_Plan) = 0; my $Original_Pid = $$; my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my @Test_Details = (); share(@Test_Details); =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use Test::Builder; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(ok); my $Test = Test::Builder->new; $Test->output('my_logfile'); sub import { my($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'ok'); } sub ok { my($test, $name) = @_; $Test->ok($test, $name); } =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program, there is B Test::Builder object. No matter how many times you call new(), you're getting the same object. (This is called a singleton). =cut my $Test; sub new { my($class) = shift; $Test ||= bless ['Move along, nothing to see here'], $class; return $Test; } =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This is important for getting TODO tests right. =cut my $Exported_To; sub exported_to { my($self, $pack) = @_; if( defined $pack ) { $Exported_To = $pack; } return $Exported_To; } =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call plan(), don't call any of the other methods below. =cut sub plan { my($self, $cmd, $arg) = @_; return unless $cmd; if( $Have_Plan ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } if( $cmd eq 'no_plan' ) { $self->no_plan; } elsif( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif( $cmd eq 'tests' ) { if( $arg ) { return $self->expected_tests($arg); } elsif( !defined $arg ) { die "Got an undefined number of tests. Looks like you tried to ". "say how many tests you plan to run but made a mistake.\n"; } elsif( !$arg ) { die "You said to run 0 tests! You've got to run something.\n"; } } else { require Carp; my @args = grep { defined } ($cmd, $arg); Carp::croak("plan() doesn't understand @args"); } return 1; } =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the # of tests we expect this test to run and prints out the appropriate headers. =cut my $Expected_Tests = 0; sub expected_tests { my($self, $max) = @_; if( defined $max ) { $Expected_Tests = $max; $Have_Plan = 1; $self->_print("1..$max\n") unless $self->no_header; } return $Expected_Tests; } =item B $Test->no_plan; Declares that this test will run an indeterminate # of tests. =cut my($No_Plan) = 0; sub no_plan { $No_Plan = 1; $Have_Plan = 1; } =item B $plan = $Test->has_plan Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { return($Expected_Tests) if $Expected_Tests; return('no_plan') if $No_Plan; return(undef); }; =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given $reason. Exits immediately with 0. =cut my $Skip_All = 0; sub skip_all { my($self, $reason) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; $out .= "\n"; $Skip_All = 1; $self->_print($out) unless $self->no_header; exit(0); } =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. $name is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if $test is true, fail if $test is false. Just like Test::Simple's ok(). =cut sub ok { my($self, $test, $name) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } lock $Curr_Test; $Curr_Test++; $self->diag(<caller; my $todo = $self->todo($pack); my $out; my $result = {}; share($result); unless( $test ) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $Curr_Test" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $out .= " # TODO $what_todo"; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; $out .= "\n"; $self->_print($out); unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->diag(" $msg test ($file at line $line)\n"); } return $test ? 1 : 0; } =item B $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $Test->is_num($got, $expected, $name); Like Test::More's is(). Checks if $got == $expected. This is the numeric version. =cut sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, 'eq', $expect) unless $test; return $test; } return $self->cmp_ok($got, 'eq', $expect, $name); } sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, '==', $expect) unless $test; return $test; } return $self->cmp_ok($got, '==', $expect, $name); } sub _is_diag { my($self, $got, $type, $expect) = @_; foreach my $val (\$got, \$expect) { if( defined $$val ) { if( $type eq 'eq' ) { # quote and force string context $$val = "'$$val'" } else { # force numeric context $$val = $$val+0; } } else { $$val = 'undef'; } } return $self->diag(sprintf < $Test->isnt_eq($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the string version. =item B $Test->is_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. =cut sub isnt_eq { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('ne', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, 'ne', $dont_expect, $name); } sub isnt_num { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('!=', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, '!=', $dont_expect, $name); } =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); Like Test::More's like(). Checks if $this matches the given $regex. You'll want to avoid qr// if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B the given $regex. =cut sub like { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '=~', $name); } sub unlike { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '!~', $name); } =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); Convenience method for building testing functions that take regular expressions as arguments, but need to work before perl 5.005. Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or undef if it's argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $this, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($this =~ m/$usable_regex/, $name); } =cut sub maybe_regex { my ($self, $regex) = @_; my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; }; return($usable_regex) }; sub _regex_ok { my($self, $this, $regex, $cmp, $name) = @_; local $Level = $Level + 1; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless (defined $usable_regex) { $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { local $^W = 0; my $test = $this =~ /$usable_regex/ ? 1 : 0; $test = !$test if $cmp eq '!~'; $ok = $self->ok( $test, $name ); } unless( $ok ) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; $self->diag(sprintf < $Test->cmp_ok($this, $type, $that, $name); Works just like Test::More's cmp_ok(). $Test->cmp_ok($big_num, '!=', $other_big_num); =cut sub cmp_ok { my($self, $got, $type, $expect, $name) = @_; my $test; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $test = eval "\$got $type \$expect"; } local $Level = $Level + 1; my $ok = $self->ok($test, $name); unless( $ok ) { if( $type =~ /^(eq|==)$/ ) { $self->_is_diag($got, $type, $expect); } else { $self->_cmp_diag($got, $type, $expect); } } return $ok; } sub _cmp_diag { my($self, $got, $type, $expect) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; return $self->diag(sprintf < $Test->BAILOUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =cut sub BAILOUT { my($self, $reason) = @_; $self->_print("Bail out! $reason"); exit 255; } =item B $Test->skip; $Test->skip($why); Skips the current test, reporting $why. =cut sub skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # skip $why\n"; $Test->_print($out); return 1; } =item B $Test->todo_skip; $Test->todo_skip($why); Like skip(), only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =cut sub todo_skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "not ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $Test->_print($out); return 1; } =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like skip(), only it skips all the rest of the tests you plan to run and terminates the test. If you're running under no_plan, it skips once and terminates the test. =end _unimplemented =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should $Test look when reporting where the test failed. Defaults to 1. Setting $Test::Builder::Level overrides. This is typically useful localized: { local $Test::Builder::Level = 2; $Test->ok($test); } =cut sub level { my($self, $level) = @_; if( defined $level ) { $Level = $level; } return $Level; } $CLASS->level(1); =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Test::Harness will accept either, but avoid mixing the two styles. Defaults to on. =cut my $Use_Nums = 1; sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { $Use_Nums = $use_nums; } return $Use_Nums; } =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described in Test::Simple. If this is true, none of that will be done. =cut my($No_Header, $No_Ending) = (0,0); sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { $No_Header = $no_header; } return $No_Header; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { $No_Ending = $no_ending; } return $No_Ending; } =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given $message. Normally, it uses the failure_output() handle, but if this is for a TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because diag() is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =cut sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; s/^/# /gms; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; local $Level = $Level + 1; my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; return 0; } =begin _private =item B<_print> $Test->_print(@msgs); Prints to the output() filehandle. =end _private =cut sub _print { my($self, @msgs) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. foreach (@msgs) { s/\n(.)/\n# $1/sg; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; print $fh @msgs; } =item B $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $Test->todo_output($fh); $Test->todo_output($file); Where diagnostics about todo test failures and diag() should go. Defaults to STDOUT. =cut my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { $Out_FH = _new_fh($fh); } return $Out_FH; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { $Fail_FH = _new_fh($fh); } return $Fail_FH; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { $Todo_FH = _new_fh($fh); } return $Todo_FH; } sub _new_fh { my($file_or_fh) = shift; my $fh; unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; } else { $fh = $file_or_fh; } return $fh; } unless( $^C ) { # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush(\*TESTOUT); _autoflush(\*STDOUT); _autoflush(\*TESTERR); _autoflush(\*STDERR); $CLASS->output(\*TESTOUT); $CLASS->failure_output(\*TESTERR); $CLASS->todo_output(\*TESTOUT); } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; } =back =head2 Test Status and Info =over 4 =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test # we're on. You usually shouldn't have to set this. =cut sub current_test { my($self, $num) = @_; lock($Curr_Test); if( defined $num ) { unless( $Have_Plan ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } $Curr_Test = $num; if( $num > @Test_Results ) { my $start = @Test_Results ? $#Test_Results + 1 : 0; for ($start..$num-1) { my %result; share(%result); %result = ( ok => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef ); $Test_Results[$_] = \%result; } } } return $Curr_Test; } =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =cut sub summary { my($self) = shift; return map { $_->{'ok'} } @Test_Results; } =item B
my @tests = $Test->details; Like summary(), but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when current_test() is changed. In these cases, Test::Builder doesn't know the result of the test, so it's type is 'unkown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left undef. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since it's todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =cut sub details { return @Test_Results; } =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); todo() looks for a $TODO variable in your tests. If set, all tests will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. todo() is pretty part about finding the right package to look for $TODO in. It uses the exported_to() package to find it. If that's not set, it's pretty good at guessing the right package to look at. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { my($self, $pack) = @_; $pack = $pack || $self->exported_to || $self->caller(1); no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal caller(), except it reports according to your level(). =cut sub caller { my($self, $height) = @_; $height ||= 0; my @caller = CORE::caller($self->level + $height + 1); return wantarray ? @caller : $caller[0]; } =back =cut =begin _private =over 4 =item B<_sanity_check> _sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); _whoa(!$Have_Plan and $Curr_Test, 'Somehow your tests ran without a plan!'); _whoa($Curr_Test != @Test_Results, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> _whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my($check, $desc) = @_; if( $check ) { die < _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test_Died = 1 unless $in_eval; }; sub _ending { my $self = shift; _sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. do{ _my_exit($?) && return } if $Original_Pid != $$; # Bailout if plan() was never called. This is so # "require Test::Simple" doesn't puke. do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; # Figure out if we passed or failed and print helpful messages. if( @Test_Results ) { # The plan? We have no plan. if( $No_Plan ) { $self->_print("1..$Curr_Test\n") unless $self->no_header; $Expected_Tests = $Curr_Test; } # 5.8.0 threads bug. Shared arrays will not be auto-extended # by a slice. Worse, we have to fill in every entry else # we'll get an "Invalid value for shared scalar" error for my $idx ($#Test_Results..$Expected_Tests-1) { my %empty_result = (); share(%empty_result); $Test_Results[$idx] = \%empty_result unless defined $Test_Results[$idx]; } my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; $num_failed += abs($Expected_Tests - @Test_Results); if( $Curr_Test < $Expected_Tests ) { $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but only ran $Curr_Test. FAIL } elsif( $Curr_Test > $Expected_Tests ) { my $num_extra = $Curr_Test - $Expected_Tests; $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but ran $num_extra extra. FAIL } elsif ( $num_failed ) { $self->diag(<<"FAIL"); Looks like you failed $num_failed tests of $Expected_Tests. FAIL } if( $Test_Died ) { $self->diag(<<"FAIL"); Looks like your test died just after $Curr_Test. FAIL _my_exit( 255 ) && return; } _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } elsif ( $Skip_All ) { _my_exit( 0 ) && return; } elsif ( $Test_Died ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL } else { $self->diag("No tests run!\n"); _my_exit( 255 ) && return; } } END { $Test->_ending if defined $Test and !$Test->no_ending; } =head1 THREADS In perl 5.8.0 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, Test::Exception and Test::Differences all use Test::Builder. =head1 SEE ALSO Test::Simple, Test::More, Test::Harness =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2002 by chromatic Echromatic@wgz.orgE, Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Data-Alias-1.21/t/lib/Test/More.pm0000644000175000017500000007467611661277703016115 0ustar zeframzeframpackage Test::More; use 5.004; use strict; use Test::Builder; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.47'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag ); my $Test = Test::Builder->new; # 5.004's Exporter doesn't have export_to_level. sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => $Num_Tests; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($this eq $that, $test_name); is ($this, $that, $test_name); isnt($this, $that, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($this, qr/that/, $test_name); unlike($this, qr/that/, $test_name); cmp_ok($this, '==', $that, $test_name); is_deeply($complex_structure1, $complex_structure2, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); # Utility comparison functions. eq_array(\@this, \@that); eq_hash(\%this, \%that); eq_set(\@this, \@that); # UNIMPLEMENTED!!! my @status = Test::More::status; # UNIMPLEMENTED!!! BAIL_OUT($why); =head1 DESCRIPTION B If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the plan() function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; goto &plan; } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($this eq $that, $test_name); This simply evaluates any expression (C<$this eq $that> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 18 (foo.t at line 42) This is actually Test::Simple's ok() routine. =cut sub ok ($;$) { my($test, $name) = @_; $Test->ok($test, $name); } =item B =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test (foo.t at line 139) # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! $pope->isa('Catholic') eq 1 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); This does not check if C<$pope->isa('Catholic')> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { $Test->is_eq(@_); } sub isnt ($$;$) { $Test->isnt_eq(@_); } *isn't = \&isnt; =item B like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. So this: like($this, qr/that/, 'this is like that'); is similar to: ok( $this =~ /that/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $this, '/that/', 'this is like that' ); Regex options may be placed on the end (C<'/that/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { $Test->like(@_); } =item B unlike( $this, qr/that/, $test_name ); Works exactly as like(), only it checks if $this B match the given pattern. =cut sub unlike { $Test->unlike(@_); } =item B cmp_ok( $this, $op, $that, $test_name ); Halfway between ok() and is() lies cmp_ok(). This allows you to compare two arguments using any binary perl operator. # ok( $this eq $that ); cmp_ok( $this, 'eq', $that, 'this eq that' ); # ok( $this == $that ); cmp_ok( $this, '==', $that, 'this == that' ); # ok( $this && $that ); cmp_ok( $this, '&&', $that, 'this || that' ); ...etc... Its advantage over ok() is when the test fails you'll know what $this and $that were: not ok 1 # Failed test (foo.t at line 12) # '23' # && # undef It's also useful in those cases where you are comparing numbers and is()'s use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { $Test->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single can_ok() call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); $Test->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $Test->ok( !@nok, $name ); $Test->diag(map " $class->can('$_') failed\n", @nok); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $Test->ok( 0, $name ); $Test->diag(" $diag\n"); } else { $ok = $Test->ok( 1, $name ); } return $ok; } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { $Test->ok(1, @_); } sub fail (;$) { $Test->ok(0, @_); } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test (foo.t at line 52) # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. =cut sub diag { $Test->diag(@_); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } =cut sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $pack = caller; local($@,$!); # eval sometimes interferes with $! eval <import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $Test->diag(< require_ok($module); Like use_ok(), except it requires the $module. =cut sub require_ok ($) { my($module) = shift; my $pack = caller; local($!, $@); # eval sometimes interferes with $! eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $Test->diag(<. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut #'# sub skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->skip($why); } local $^W = 0; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. Test::Harness will interpret them as passing. =cut sub todo_skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->todo_skip($why); } local $^W = 0; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like fork() or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Comparison functions Not everything is a simple eq check or regex. There are times you need to see if two arrays are equivalent, for instance. For these instances, Test::More provides a handful of useful functions. B These are NOT well-tested on circular references. Nor am I quite sure what will happen with filehandles. =over 4 =item B is_deeply( $this, $that, $test_name ); Similar to is(), except that if $this and $that are hash or array references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. Barrie Slaymaker's Test::Differences module provides more in-depth functionality along these lines, and it plays well with Test::More. B Display of scalar refs is not quite 100% =cut use vars qw(@Data_Stack); my $DNE = bless [], 'Does::Not::Exist'; sub is_deeply { my($this, $that, $name) = @_; my $ok; if( !ref $this || !ref $that ) { $ok = $Test->is_eq($this, $that, $name); } else { local @Data_Stack = (); if( _deep_check($this, $that) ) { $ok = $Test->ok(1, $name); } else { $ok = $Test->ok(0, $name); $ok = $Test->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : $val eq $DNE ? "Does not exist" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } =item B eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $ok = 0; my $eq; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { $ok = 1; } else { if( UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY') ) { $ok = eq_array($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH') ) { $ok = eq_hash($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'REF') and UNIVERSAL::isa($e2, 'REF') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( UNIVERSAL::isa($e1, 'SCALAR') and UNIVERSAL::isa($e2, 'SCALAR') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); } else { push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } } return $ok; } =item B eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. B By historical accident, this is not a true set comparision. While the order of elements does not matter, duplicate elements do. =cut # We must make sure that references are treated neutrally. It really # doesn't matter how we sort them, as long as both arrays are sorted # with the same algorithm. sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of Test::Builder which provides a single, unified backend for any test library to use. This means two test libraries which both use Test::Builder B. If you simply want to do a little tweaking of how the tests behave, you can access the underlying Test::Builder object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the Test::Builder object underlying Test::More for you to play with. =cut sub builder { return Test::Builder->new; } =back =head1 NOTES Test::More is B tested all the way back to perl 5.004. Test::More is thread-safe for perl 5.8.0 and up. =head1 BUGS and CAVEATS =over 4 =item Making your own ok() If you are trying to extend Test::More, don't. Use Test::Builder instead. =item The eq_* family has some caveats. =item Test::Harness upgrades no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan or todo your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness will work fine. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unaware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L for more ways to test complex data structures. And it plays well with Test::More. L is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L describes a very featureful unit testing interface. L shows the idea of embedded testing. L is another approach to embedded testing. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, chromatic and the perl-qa gang. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Data-Alias-1.21/t/lib/Test/Simple.pm0000644000175000017500000001456511661277703016433 0ustar zeframzeframpackage Test::Simple; use 5.004; use strict 'vars'; use vars qw($VERSION); $VERSION = '0.47'; use Test::Builder; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; *{$caller.'::ok'} = \&ok; $Test->exported_to($caller); $Test->plan(@_); } =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { $Test->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test (t/film.t at line 14) ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. Test::Simple is thread-safe in perl 5.8.0 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Data-Alias-1.21/t/22_alias_list_slice.t0000644000175000017500000000224411661277703017141 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 12; use Data::Alias; sub refs { [map "".\$_, @_] } our ($x, $y); our ($a, $b, $c, $d); our @x; alias +($x, @x[1,0], $y) = ($a, $b, $c, $d); is_deeply refs($x, @x[1,0], $y), refs($a, $b, $c, $d); alias @x[1,0] = @x; is_deeply refs(@x), refs($b, $c); is_deeply refs(alias { local @x[0,1] = ($a, $d); @x }), refs($a, $d); is_deeply refs(@x), refs($b, $c); our %x; alias +($y, @x{1,0}, $x) = ($a, $b, $c, $d); is_deeply refs($y, @x{1,0}, $x), refs($a, $b, $c, $d); alias @x{1,0} = @x{0,1}; is_deeply refs(@x{0,1}), refs($b, $c); is_deeply refs(alias { local @x{0,1} = ($a, $d); @x{0,1} }), refs($a, $d); is_deeply refs(@x{0,1}), refs($b, $c); SKIP: { no warnings 'deprecated'; skip "pseudo-hashes not supported anymore", 4 unless eval { [{1,1},1]->{1} }; our $r = [{0=>1,1=>2}]; alias +($y, @$r{1,0}, $x) = ($a, $b, $c, $d); is_deeply refs($y, @$r[2,1], $x), refs($a, $b, $c, $d); alias @$r{1,0} = @$r[1,2]; is_deeply refs(@$r[1,2]), refs($b, $c); is_deeply refs(alias { local @$r{0,1} = ($a, $d); @$r[1,2] }), refs($a, $d); is_deeply refs(@$r[1,2]), refs($b, $c); } # vim: ft=perl Data-Alias-1.21/t/23_alias_list_whole.t0000644000175000017500000000634311661277703017165 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 51; use Data::Alias qw(alias deref); sub refs { [map "".\$_, @_] } sub srefs { [sort map "".\$_, @_] } our ($x, $y); our ($a, $b, $c, $d, $e) = (1 .. 5); our @x; is alias(($x, @x, $y) = ($a, $b, $c, $d)), 4; is_deeply refs(@x), refs($b, $c, $d); is_deeply refs($x, $y), refs($a, undef); is_deeply refs(alias +($y, @x, $x) = ($b, $c, $d)), refs($b, $c, $d, undef); is_deeply refs(@x), refs($c, $d); is_deeply refs($y, $x), refs($b, undef); is_deeply refs(alias +($x, @x, $y) = ()), refs(undef, undef); is @x, 0; is_deeply refs($x, $y), refs(undef, undef); is alias(($x, @x, $y) = ()), 0; is alias((@x) = (undef, $a, undef, $b, undef)), 5; is_deeply refs(deref \@x), refs(undef, $a, undef, $b, undef); our %x; is alias(($x, %x, $y) = ($a, $b, $c, $d, $e)), 5; is keys(%x), 2; is_deeply refs(@x{$b, $d}), refs($c, $e); is_deeply refs($x, $y), refs($a, undef); is_deeply refs(alias +($y, %x, $x) = ($b, $c, $d)), refs($b, $c, $d, undef); is keys(%x), 1; is_deeply refs($x{$c}, $y, $x), refs($d, $b, undef); is_deeply refs(alias +($x, %x, $y) = ()), refs(undef, undef); is keys(%x), 0; is_deeply refs($x, $y), refs(undef, undef); is alias(($x, %x, $y) = ()), 0; is alias((%x) = ($a, $b, $c, undef, $d, $e)), 6; is keys(%x), 2; is_deeply refs($x{$a}, $x{$d}), refs($b, $e); is alias(($x, %x, $y) = ($a, $a, $b, $b, undef, $a, undef, $b, $c)), 9; is keys(%x), 1; is_deeply refs($x{$b}, $x, $y), refs($c, $a, undef); is_deeply refs(alias +($x, %x, $y) = ($a, $a, $b, $b, undef, $a, undef, $b, $c)), refs($a, $a, undef, $b, $c, undef); eval { alias +(%x) = ($a, $b, $c) }; like $@, qr/^Odd number of elements /; { no warnings 'misc'; is alias(($y, %x, $x) = ($e, $a, $b, $c, $d, $a)), 6; is keys(%x), 1; is_deeply refs($x{$c}, $y, $x), refs($d, $e, undef); is_deeply refs(alias +($y, %x, $x) = ($e, $a, $b, $c, $d, $a)), refs($e, $c, $d, $a, undef); } SKIP: { no warnings 'deprecated'; skip "pseudo-hashes not supported anymore", 16 unless eval { [{1,1},1]->{1} }; our $r = [{$a=>1,$b=>2,$c=>3,$d=>4}]; is alias(($x, %$r, $y) = ($a, $b, $c, $d, $e)), 5; is_deeply refs($x, $y, deref $r), refs($a, undef, $$r[0], undef, $c, undef, $e); is_deeply refs(alias +($y, %$r, $x) = ($b, $c, $d)), refs($b, $c, $d, undef); is_deeply refs($y, $x, deref $r), refs($b, undef, $$r[0], undef, undef, $d); is_deeply refs(alias +($x, %$r, $y) = ()), refs(undef, undef); is_deeply refs($x, $y, deref $r), refs(undef, undef, $$r[0]); is alias(($x, %$r, $y) = ()), 0; is alias((%$r) = ($a, $b, $c, undef, $d, $e)), 6; is_deeply refs(deref $r), refs($$r[0], $b, undef, undef, $e); is alias(($x, %$r, $y) = ($a, $a, $b, $b, undef, $a, undef, $b, $c)), 9; is_deeply refs($x, $y, deref $r), refs($a, undef, $$r[0], undef, $c); is_deeply refs(alias +($x, %$r, $y) = ($a, $a, $b, $b, undef, $a, undef, $b, $c)), refs($a, $a, undef, $b, $c, undef); eval { alias +(%$r) = ($a, $b, $c) }; like $@, qr/^Odd number of elements /; { no warnings 'misc'; is alias(($y, %$r, $x) = ($e, $a, $b, $c, $d, $a)), 6; is_deeply refs($y, $x, deref $r), refs($e, undef, $$r[0], undef, undef, $d); is_deeply refs(alias +($y, %$r, $x) = ($e, $a, $b, $c, $d, $a)), refs($e, $c, $d, $a, undef); } } # vim: ft=perl Data-Alias-1.21/t/padrange.t0000644000175000017500000000224512611613332015101 0ustar zeframzeframuse strict; use warnings qw(FATAL all); use Test::More tests => 38; use Data::Alias qw(alias); our $x = 1; our $y = 2; our $z = 3; our @x = (4, 5, 6); our %x = (a => 7, b => 8); alias my($a) = ($x); ok \$a == \$x; alias +($a) = ($y); ok \$a == \$y; alias my($b, $c) = ($x, $z); ok \$b == \$x; ok \$c == \$z; alias our($j, $k) = ($b, $c); ok \$j == \$x; ok \$k == \$z; ok \$b == \$x; ok \$c == \$z; alias my($d, @d) = @x; ok \$d == \$x[0]; ok \@d != \@x; ok scalar(@d) == 2; ok \$d[0] == \$x[1]; ok \$d[1] == \$x[2]; alias my(@c) = @x; ok \@c != \@x; ok scalar(@c) == 3; ok \$c[0] == \$x[0]; ok \$c[1] == \$x[1]; ok \$c[2] == \$x[2]; alias my @e = @x; ok \@e == \@x; alias my %e = %x; ok \%e == \%x; sub t0 { alias my($f, @f) = @_; ok \$f == \$x[0]; ok \@f != \@x; ok \@f != \@_; ok scalar(@f) == 2; ok \$f[0] == \$x[1]; ok \$f[1] == \$x[2]; } t0(@x); sub t1 { alias my(@g) = @_; ok \@g != \@_; ok \@g != \@x; ok scalar(@g) == 3; ok \$g[0] == \$x[0]; ok \$g[1] == \$x[1]; ok \$g[2] == \$x[2]; } t1(@x); sub t2 { alias my @g = @_; ok \@g == \@_; ok \@g != \@x; ok scalar(@g) == 3; ok \$g[0] == \$x[0]; ok \$g[1] == \$x[1]; ok \$g[2] == \$x[2]; } t2(@x); 1; Data-Alias-1.21/t/15_alias_pkg_misc.t0000644000175000017500000000235711661277703016612 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 27; use Data::Alias; our $x; our $y = "x"; our $z = *x; # rv2sv in more detail: is \alias(${*x} = $y), \$y; # real gv is \$x, \$y; is \alias($$z = $z), \$z; # fake gv is \$x, \$z; eval { alias $$y = $y }; # symref (strict) like $@, qr/^Can't use string .* as a SCALAR ref /; is \$x, \$z; is \alias { no strict 'refs'; $$y = $y }, \$y; # symref (non-strict) is \$x, \$y; # rv2gv in more detail: is \alias { local *{*x} = *z; $x }, \$z; is \$x, \$y; is \alias { local *{\*x} = *z; $x }, \$z; is \$x, \$y; is \alias { local *{\$z} = *z; $x }, \$z; is \$x, \$y; is \alias { local *$z = *z; $x }, \$z; is \$x, \$y; is \alias { eval { local *$y = *z }; $x }, \$y; like $@, qr/^Can't use string .* as a symbol ref /; is \alias { no strict 'refs'; local *$y = *z; $x }, \$z; is \$x, \$y; eval { my $q; local *$q = *z }; like $@, qr/^Can't use an undefined value as a symbol reference /; format foo = . is alias { local *x = \&foo; \&x }, \&foo; isnt \&x, \&foo; is alias { local *x = *foo{FORMAT}; *x{FORMAT} }, *foo{FORMAT}; isnt *x{FORMAT}, *foo{FORMAT}; is alias { local *x = *STDIN{IO}; *x{IO} }, *STDIN{IO}; isnt *x{IO}, *STDIN{IO}; # vim: ft=perl Data-Alias-1.21/t/19_alias_aelem.t0000644000175000017500000000232712217326702016072 0ustar zeframzefram#!/usr/bin/perl -w use strict; use warnings qw(FATAL all); use lib 'lib'; use Test::More tests => 37; use Data::Alias; our @x; our $T = 42; is \alias($x[0] = $x[1]), \$x[1]; is \$x[0], \$x[1]; is \alias($x[0] = $x[2]), \$x[2]; is \$x[0], \$x[2]; isnt \$x[1], \$x[2]; is \alias($x[0] ||= $T), \$T; is \$x[0], \$T; isnt \alias($x[0] ||= $x[1]), \$x[1]; is \$x[0], \$T; is \alias($x[0] &&= $x[2]), \$x[2]; is \$x[0], \$x[2]; isnt \alias($x[0] &&= $T), \$T; is \$x[0], \$x[2]; alias { is \(local $x[0] = $x[1]), \$x[1]; is \$x[0], \$x[1] }; is \$x[0], \$x[2]; is \alias($x[0] = undef), \undef; ok "$]" < 5.019004 ? !exists($x[0]) : \$x[0] eq \undef; my @y; is \alias($y[0] = $y[1]), \$y[1]; is \$y[0], \$y[1]; is \alias($y[0] = $y[2]), \$y[2]; is \$y[0], \$y[2]; isnt \$y[1], \$y[2]; is \alias($y[0] ||= $T), \$T; is \$y[0], \$T; isnt \alias($y[0] ||= $y[1]), \$y[1]; is \$y[0], \$T; is \alias($y[0] &&= $y[2]), \$y[2]; is \$y[0], \$y[2]; isnt \alias($y[0] &&= $T), \$T; is \$y[0], \$y[2]; alias { is \(local $y[0] = $y[1]), \$y[1]; is \$y[0], \$y[1] }; is \$y[0], \$y[2]; is \alias($y[0] = undef), \undef; ok "$]" < 5.019004 ? !exists($y[0]) : \$y[0] eq \undef; sub{alias my ($x) = @_}->($y[0]); ok exists $y[0]; # vim: ft=perl Data-Alias-1.21/inc/0000755000175000017500000000000013212443455013443 5ustar zeframzeframData-Alias-1.21/inc/Module/0000755000175000017500000000000013212443455014670 5ustar zeframzeframData-Alias-1.21/inc/Module/Install.pm0000644000175000017500000001761111661277703016651 0ustar zeframzefram#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.004; use strict 'vars'; use vars qw{$VERSION}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.67'; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE"; Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE } # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 and (stat($0))[9] > time ) { die << "END_DIE"; Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; unshift @_, ($self, $1); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; } sub preload { my ($self) = @_; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; my $in_pod = 0; while ( ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } close PKGFILE; } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; Data-Alias-1.21/inc/Module/Install/0000755000175000017500000000000013212443455016276 5ustar zeframzeframData-Alias-1.21/inc/Module/Install/Base.pm0000644000175000017500000000203511661277703017515 0ustar zeframzefram#line 1 package Module::Install::Base; $VERSION = '0.67'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 Data-Alias-1.21/inc/Module/Install/Fetch.pm0000644000175000017500000000463011661277703017677 0ustar zeframzefram#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Data-Alias-1.21/inc/Module/Install/Metadata.pm0000644000175000017500000002153011661277703020364 0ustar zeframzefram#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests installdirs }; my @tuple_keys = qw{ build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} if defined wantarray and !@_; $self->{values}{$key} = shift; return $self; }; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{values}{$key} }, @rv; @rv; }; } # configure_requires is currently a null-op sub configure_requires { 1 } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and ! @_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0; return $self; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die "all_from called with no args without setting name() first"; $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; die "all_from: cannot find $file from $name" unless -e $file; } $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } sub provides { my $self = shift; my $provides = ( $self->{values}{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides(%{ $build->find_dist_packages || {} }); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}{no_index}{$type} }, @_ if $type; return $self->{values}{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } sub _slurp { my ( $self, $file ) = @_; local *FH; open FH, "< $file" or die "Cannot open $file.pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d_\.]+) \s* ; /ixms ) { my $v = $1; $v =~ s{_}{}g; $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser public license' => 'gpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { if ( $osi and $license_text =~ /All rights reserved/i ) { #warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it."; } $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; Data-Alias-1.21/inc/Module/Install/Can.pm0000644000175000017500000000337411661277703017353 0ustar zeframzefram#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 Data-Alias-1.21/inc/Module/Install/Makefile.pm0000644000175000017500000001351111661277703020361 0ustar zeframzefram#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(' ', grep length, $clean->{FILES}, @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join(' ', grep length, $realclean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } require File::Find; %test_dir = (); File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { $args{dist} = $preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 363 Data-Alias-1.21/inc/Module/Install/Win32.pm0000644000175000017500000000341611661277703017551 0ustar zeframzefram#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); if (!$rv) { die <<'END_MESSAGE'; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } } 1; Data-Alias-1.21/inc/Module/Install/WriteAll.pm0000644000175000017500000000162411661277703020371 0ustar zeframzefram#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_ ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; if ( $0 =~ /Build.PL$/i ) { $self->Build->write; } else { $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{'PL_FILES'} ) { $self->makemaker_args( PL_FILES => {} ); } if ($args{inline}) { $self->Inline->write; } else { $self->Makefile->write; } } } 1;