Array-Base-0.006000755001750001750 013143430634 13401 5ustar00zeframzefram000000000000Array-Base-0.006/.gitignore000444001750001750 22713143430626 15510 0ustar00zeframzefram000000000000/Build /Makefile /_build /blib /META.json /META.yml /MYMETA.json /MYMETA.yml /Makefile.PL /SIGNATURE /Array-Base-* /lib/Array/Base.c /lib/Array/Base.o Array-Base-0.006/Build.PL000444001750001750 166713143430626 15045 0ustar00zeframzefram000000000000{ use 5.006; } use warnings; use strict; use Module::Build; Module::Build->new( module_name => "Array::Base", license => "perl", configure_requires => { "Module::Build" => 0, "perl" => "5.008001", "strict" => 0, "warnings" => 0, }, build_requires => { "ExtUtils::CBuilder" => "0.15", "Module::Build" => 0, "Test::More" => 0, "perl" => "5.008001", "strict" => 0, "warnings" => 0, }, requires => { "Lexical::SealRequireHints" => "0.008", "XSLoader" => 0, "perl" => "5.008001", "strict" => 0, "warnings" => 0, }, conflicts => { "B::Hooks::OP::Check" => "< 0.19", }, dynamic_config => 0, meta_add => { distribution_type => "module" }, meta_merge => { "meta-spec" => { version => "2" }, resources => { bugtracker => { mailto => "bug-Array-Base\@rt.cpan.org", web => "https://rt.cpan.org/Public/Dist/". "Display.html?Name=Array-Base", }, }, }, sign => 1, )->create_build_script; 1; Array-Base-0.006/Changes000444001750001750 756713143430626 15051 0ustar00zeframzefram000000000000version 0.006; 2017-08-11 * bugfix: properly maintain op_last when munging ops * bugfix: require bugfixed version of Lexical::SealRequireHints (for not breaking version-implied features and for require argument context) * port to Perl 5.19.4, where there's a new pair slice operator that needs to be influenced by an index base * update to accommodate PERL_OP_PARENT builds of Perl 5.21.11 or later (which is the default from Perl 5.25.1) * be more conservative about maintaining op tree structure * update test suite to not rely on . in @INC, which is no longer necessarily there from Perl 5.25.7 * register custom op on Perl 5.13.7+ * use cleaner wrap_op_checker() API to control op checking * build custom op structures from scratch * use briefer UNOP format for custom op instead of LISTOP * in tests, muffle "experimental" warnings for lexical $_ * no longer include a Makefile.PL in the distribution * in documentation, use four-column indentation for all verbatim material * in META.{yml,json}, point to public bug tracker * consistently use THX_ prefix on internal function names version 0.005; 2012-02-01 * bugfix: require bugfixed version of Lexical::SealRequireHints (for compatibility with early-loaded warnings.pm) and invoke it earlier to make sure it takes effect in time * in doc, refer to String::Base for string index offsetting * update documentation for $[ changes in Perl 5.15.3 and 5.15.5 * in Build.PL, declare incompatibility with pre-0.19 B::Hooks::OP::Check, which doesn't play nicely around op check hooking * convert .cvsignore to .gitignore version 0.004; 2011-07-27 * bugfix: require bugfixed version of Lexical::SealRequireHints (for working around [perl #73174]) * document that Perls prior to 5.9.3 don't propagate the right lexical state into string eval version 0.003; 2011-04-09 * bugfix: correctly detect a type of malformed op tree that the module can't process * document that $[ is now due to disappear in Perl 5.15, changed from 5.13 * on Perl 5.13.6+, use new API function op_contextualize() instead of the core's private functions * in XS, use PERL_NO_GET_CONTEXT for efficiency * in XS, declare "PROTOTYPES: DISABLE" to prevent automatic generation of unintended prototypes * jump through hoops to avoid compiler warnings * use full stricture in test suite * in test suite, make all numeric comparisons against $] stringify it first, to avoid architecture-dependent problems with floating point rounding giving it an unexpected numeric value * in Build.PL, complete declaration of configure-time requirements * include META.json in distribution * add MYMETA.json to .cvsignore version 0.002; 2010-04-11 * bugfix: require bugfixed version of Lexical::SealRequireHints (for passing package through to required code in pure-Perl version of Lexical::SealRequireHints) * in XS, use macros to avoid explicit passing of aTHX, in the manner of the core * in XS, avoid using "class" as a variable name, for compatibility with C++ compilers * in Build.PL, explicitly declare configure-time requirements * add MYMETA.yml to .cvsignore version 0.001; 2009-10-21 * bugfix: correct behaviour of array slicing in scalar context * bugfix: also influence list slicing and array splicing, as $[ does * for Perl 5.11, also influence the new array keys() and each() operators * reorganise documentation, particularly expanding the comparison with $[ * use integer arithmetic operators for efficiency * test all combinations of scalar and list contexts * in documentation, correct statement about when $[ is likely to be removed from the core * split test suite into one file per affected opcode * check for required Perl version at runtime version 0.000; 2009-09-27 * initial released version Array-Base-0.006/MANIFEST000444001750001750 43313143430626 14650 0ustar00zeframzefram000000000000.gitignore Build.PL Changes MANIFEST META.json META.yml README lib/Array/Base.pm lib/Array/Base.xs t/aeach.t t/aelem.t t/akeys.t t/aslice.t t/av2arylen.t t/kvaslice.t t/lib/t/scope_0.pm t/lslice.t t/pod_cvg.t t/pod_syn.t t/scope.t t/splice.t SIGNATURE Added here by Module::Build Array-Base-0.006/META.json000444001750001750 316013143430626 15160 0ustar00zeframzefram000000000000{ "abstract" : "array index offseting", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Array-Base", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0.15", "Module::Build" : "0", "Test::More" : "0", "perl" : "5.008001", "strict" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0", "perl" : "5.008001", "strict" : "0", "warnings" : "0" } }, "runtime" : { "conflicts" : { "B::Hooks::OP::Check" : "< 0.19" }, "requires" : { "Lexical::SealRequireHints" : "0.008", "XSLoader" : "0", "perl" : "5.008001", "strict" : "0", "warnings" : "0" } } }, "provides" : { "Array::Base" : { "file" : "lib/Array/Base.pm", "version" : "0.006" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Array-Base@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Array-Base" }, "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.006", "x_serialization_backend" : "JSON::PP version 2.93" } Array-Base-0.006/META.yml000444001750001750 171213143430626 15011 0ustar00zeframzefram000000000000--- abstract: 'array index offseting' author: - 'Andrew Main (Zefram) ' build_requires: ExtUtils::CBuilder: '0.15' Module::Build: '0' Test::More: '0' perl: '5.008001' strict: '0' warnings: '0' configure_requires: Module::Build: '0' perl: '5.008001' strict: '0' warnings: '0' conflicts: B::Hooks::OP::Check: '< 0.19' dynamic_config: 0 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Array-Base provides: Array::Base: file: lib/Array/Base.pm version: '0.006' requires: Lexical::SealRequireHints: '0.008' XSLoader: '0' perl: '5.008001' strict: '0' warnings: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Array-Base license: http://dev.perl.org/licenses/ version: '0.006' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Array-Base-0.006/README000444001750001750 206613143430626 14423 0ustar00zeframzefram000000000000NAME Array::Base - array index offseting DESCRIPTION This module implements automatic offsetting of array indices. In normal Perl, the first element of an array has index 0, the second element has index 1, and so on. This module allows array indexes to start at some other value. Most commonly it is used to give the first element of an array the index 1 (and the second 2, and so on), to imitate the indexing behaviour of FORTRAN and many other languages. It is usually considered poor style to do this. The array index offset is controlled at compile time, in a lexically-scoped manner. Each block of code, therefore, is subject to a fixed offset. It is expected that the affected code is written with knowledge of what that offset is. INSTALLATION perl Build.PL ./Build ./Build test ./Build install AUTHOR Andrew Main (Zefram) COPYRIGHT Copyright (C) 2009, 2010, 2011, 2012, 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. Array-Base-0.006/SIGNATURE000644001750001750 360313143430634 15026 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.81. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 88381571be4d455b4266418c420a2797fb8f075a .gitignore SHA1 0fae27d09273ea73ca5dbdbbf8ec5e426c0e77ec Build.PL SHA1 8ee220acdc40adc31d54f4471698137c87c6d9b9 Changes SHA1 0d4cb28eaf73c0d7d7e88f833c8558e3111d9d3f MANIFEST SHA1 3c99ace3c14ee6f43510aca433238f3b4c5d33fd META.json SHA1 74922e2cd98018399897b9d8e16602bfd96389ab META.yml SHA1 6da7a880c92046370654cb86560a5bf599a99503 README SHA1 20c5d53c7ccd3988398cc004de00198a15854faf lib/Array/Base.pm SHA1 a7f8723fc2e48de09de69dd06da1e3d276b2ed2e lib/Array/Base.xs SHA1 36ab4f2819cb9b140504246e807cb7ff111f2b60 t/aeach.t SHA1 8fbab418dd4b6a8017c51c2921efe47527961182 t/aelem.t SHA1 08f5638bee0803464bbfe60409b41011cccf8d51 t/akeys.t SHA1 e61771d8c807b47a6eb0af5d110a03b3d7aeb6c2 t/aslice.t SHA1 8fe53d65992b6d61e926fc257669d07c5ff1da4e t/av2arylen.t SHA1 56d5a4e3588e8cf6c168d1ee6647cf5cbc0871be t/kvaslice.t SHA1 596de8900bd8d930221efadf1ee8270a1448b473 t/lib/t/scope_0.pm SHA1 07ec97a13ac86f318b99b200447a24575884268a t/lslice.t SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 00d97ce62df4d5f7a696595cc337939875cf1630 t/scope.t SHA1 ca190ca5aa1fee43bd3b9ed77dc978c1b7b1ff04 t/splice.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iEYEARECAAYFAlmOMZYACgkQOV9mt2VyAVE6FQCfQTf50hDpoKblMRJCgEm2QHK+ oSEAnA/3cwpwIR50Vn9bn0S7rFVy/PiI =dgLK -----END PGP SIGNATURE----- Array-Base-0.006/lib000755001750001750 013143430626 14150 5ustar00zeframzefram000000000000Array-Base-0.006/lib/Array000755001750001750 013143430626 15226 5ustar00zeframzefram000000000000Array-Base-0.006/lib/Array/Base.pm000444001750001750 1371413143430626 16621 0ustar00zeframzefram000000000000=head1 NAME Array::Base - array index offseting =head1 SYNOPSIS use Array::Base +1; no Array::Base; =head1 DESCRIPTION This module implements automatic offsetting of array indices. In normal Perl, the first element of an array has index 0, the second element has index 1, and so on. This module allows array indexes to start at some other value. Most commonly it is used to give the first element of an array the index 1 (and the second 2, and so on), to imitate the indexing behaviour of FORTRAN and many other languages. It is usually considered poor style to do this. The array index offset is controlled at compile time, in a lexically-scoped manner. Each block of code, therefore, is subject to a fixed offset. It is expected that the affected code is written with knowledge of what that offset is. =head2 Using an array index offset An array index offset is set up by a C directive, with the desired offset specified as an argument. Beware that a bare, unsigned number in that argument position, such as "C", will be interpreted as a version number to require of C. It is therefore necessary to give the offset a leading sign, or parenthesise it, or otherwise decorate it. The offset may be any integer (positive, zero, or negative) within the range of Perl's integer arithmetic. An array index offset declaration is in effect from immediately after the C line, until the end of the enclosing block or until overridden by another array index offset declaration. A declared offset always replaces the previous offset: they do not add. "C" is equivalent to "C": it returns to the Perlish state with zero offset. A declared array index offset influences these types of operation: =over =item * array indexing (C<$a[3]>) =item * array slicing (C<@a[3..5]>) =item * array pair slicing (C<%a[3..5]>) =item * list indexing/slicing (C) =item * array splicing (C) =item * array last index (C<$#a>) =item * array keys (C) (Perl 5.11 and later) =item * array each (C) (Perl 5.11 and later) =back Only forwards indexing, relative to the start of the array, is supported. End-relative indexing, normally done using negative index values, is not supported when an index offset is in effect. Use of an index that is numerically less than the index offset will have unpredictable results. =head2 Differences from C<$[> This module is a replacement for the historical L|perlvar/$[> variable. In early Perl that variable was a runtime global, affecting all array and string indexing in the program. In Perl 5, assignment to C<$[> acts as a lexically-scoped pragma. C<$[> is deprecated. The original C<$[> was removed in Perl 5.15.3, and later replaced in Perl 5.15.5 by an automatically-loaded L module. This module reimplements the index offset feature without any specific support from the core. Unlike C<$[>, this module does not affect indexing into strings. This module is concerned only with arrays. To influence string indexing, see L. This module does not show the offset value in C<$[> or any other accessible variable. With the array offset being lexically scoped, there should be no need to write code to handle a variable offset. C<$[> has some predictable, but somewhat strange, behaviour for indexes less than the offset. The behaviour differs slightly between slicing and scalar indexing. This module does not attempt to replicate it, and does not support end-relative indexing at all. The last-index operator (C<$#a>), as implemented by the Perl core, generates a magical scalar which is linked to the underlying array. The numerical value of the scalar varies if the length of the array is changed, and code with different C<$[> settings will see accordingly different values. The scalar can also be written to, to change the length of the array, and again the interpretation of the value written varies according to the C<$[> setting of the code that is doing the writing. This module does not replicate any of that behaviour. With an array index offset from this module in effect, C<$#a> evaluates to an ordinary rvalue scalar, giving the last index of the array as it was at the time the operator was evaluated, according to the array index offset in effect where the operator appears. =cut package Array::Base; { use 5.008001; } use Lexical::SealRequireHints 0.008; use warnings; use strict; our $VERSION = "0.006"; require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); =head1 PACKAGE METHODS These methods are meant to be invoked on the C package. =over =item Array::Base->import(BASE) Sets up an array index offset of I, in the lexical environment that is currently compiling. =item Array::Base->unimport Clears the array index offset, in the lexical environment that is currently compiling. =back =head1 BUGS L will generate incorrect source when deparsing code that uses an array index offset. It will include both the pragma to set up the offset and the munged form of the affected operators. Either the pragma or the munging is required to get the index offset effect; using both will double the offset. Also, the code generated for an array each (C) operation involves a custom operator, which L can't understand, so the source it emits in that case is completely wrong. The additional operators generated by this module cause spurious warnings if some of the affected array operations are used in void context. Prior to Perl 5.9.3, the lexical state of array index offset does not propagate into string eval. =head1 SEE ALSO L, L, L =head1 AUTHOR Andrew Main (Zefram) =head1 COPYRIGHT Copyright (C) 2009, 2010, 2011, 2012, 2017 Andrew Main (Zefram) =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Array-Base-0.006/lib/Array/Base.xs000444001750001750 3235513143430626 16641 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #define PERL_DECIMAL_VERSION \ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #define QHAVE_OP_AEACH PERL_VERSION_GE(5,11,0) #define QHAVE_OP_AKEYS PERL_VERSION_GE(5,11,0) #define QHAVE_OP_KVASLICE PERL_VERSION_GE(5,19,4) #ifndef cBOOL # define cBOOL(x) ((bool)!!(x)) #endif /* !cBOOL */ #ifndef newSVpvs_share # define newSVpvs_share(STR) newSVpvn_share(""STR"", sizeof(STR)-1, 0) #endif /* !newSVpvs_share */ #ifndef SvSHARED_HASH # define SvSHARED_HASH(SV) SvUVX(SV) #endif /* !SvSHARED_HASH */ #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 /* !OpMORESIB_set */ #ifndef OpSIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) # define OpSIBLING(o) (0 + (o)->op_sibling) #endif /* !OpSIBLING */ #ifndef op_contextualize # define scalar(op) Perl_scalar(aTHX_ op) # define list(op) Perl_list(aTHX_ op) # define scalarvoid(op) Perl_scalarvoid(aTHX_ op) # define op_contextualize(op, c) THX_op_contextualize(aTHX_ op, c) static OP *THX_op_contextualize(pTHX_ OP *o, I32 context) { switch (context) { case G_SCALAR: return scalar(o); case G_ARRAY: return list(o); case G_VOID: return scalarvoid(o); default: croak("panic: op_contextualize bad context"); return o; } } #endif /* !op_contextualize */ #if !PERL_VERSION_GE(5,9,3) typedef OP *(*Perl_check_t)(pTHX_ OP *); #endif /* <5.9.3 */ #if !PERL_VERSION_GE(5,10,1) typedef unsigned Optype; #endif /* <5.10.1 */ #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 /* !wrap_op_checker */ static SV *base_hint_key_sv; static U32 base_hint_key_hash; static OP *(*THX_nxck_aelem)(pTHX_ OP *o); static OP *(*THX_nxck_aslice)(pTHX_ OP *o); #if QHAVE_OP_KVASLICE static OP *(*THX_nxck_kvaslice)(pTHX_ OP *o); #endif /* QHAVE_OP_KVASLICE */ static OP *(*THX_nxck_lslice)(pTHX_ OP *o); static OP *(*THX_nxck_av2arylen)(pTHX_ OP *o); static OP *(*THX_nxck_splice)(pTHX_ OP *o); #if QHAVE_OP_AKEYS static OP *(*THX_nxck_keys)(pTHX_ OP *o); #endif /* QHAVE_OP_AKEYS */ #if QHAVE_OP_AEACH static OP *(*THX_nxck_each)(pTHX_ OP *o); #endif /* QHAVE_OP_AEACH */ #define current_base() THX_current_base(aTHX) static IV THX_current_base(pTHX) { HE *base_ent = hv_fetch_ent(GvHV(PL_hintgv), base_hint_key_sv, 0, base_hint_key_hash); return base_ent ? SvIV(HeVAL(base_ent)) : 0; } #define mapify_op(lop, base, type) THX_mapify_op(aTHX_ lop, base, type) static OP *THX_mapify_op(pTHX_ OP *lop, IV base, U16 type) { OP *mop = newLISTOP(OP_LIST, 0, newBINOP(type, 0, newGVOP(OP_GVSV, 0, PL_defgv), newSVOP(OP_CONST, 0, newSViv(base))), lop); mop->op_type = OP_MAPSTART; mop->op_ppaddr = PL_ppaddr[OP_MAPSTART]; mop = PL_check[OP_MAPSTART](aTHX_ mop); #ifdef OPpGREP_LEX if(mop->op_type == OP_MAPWHILE) { mop->op_private &= ~OPpGREP_LEX; if(cLISTOPx(mop)->op_first->op_type == OP_MAPSTART) cLISTOPx(mop)->op_first->op_private &= ~OPpGREP_LEX; } #endif /* OPpGREP_LEX */ return mop; } static OP *THX_myck_aelem(pTHX_ OP *op) { IV base; if((base = current_base()) != 0) { OP *aop, *iop; if(!(op->op_flags & OPf_KIDS)) { bad_ops: croak("strange op tree prevents applying array base"); } aop = cBINOPx(op)->op_first; iop = OpSIBLING(aop); if(!iop || OpHAS_SIBLING(iop)) goto bad_ops; OpLASTSIB_set(aop, op); cBINOPx(op)->op_last = NULL; OpLASTSIB_set(iop, NULL); iop = op_contextualize( newBINOP(OP_I_SUBTRACT, 0, iop, newSVOP(OP_CONST, 0, newSViv(base))), G_SCALAR); OpMORESIB_set(aop, iop); OpLASTSIB_set(iop, op); cBINOPx(op)->op_last = iop; } return THX_nxck_aelem(aTHX_ op); } static OP *THX_myck_aslice(pTHX_ OP *op) { IV base; if((base = current_base()) != 0) { OP *iop, *aop; if(!(op->op_flags & OPf_KIDS)) { bad_ops: croak("strange op tree prevents applying array base"); } iop = cLISTOPx(op)->op_first; aop = OpSIBLING(iop); if(!aop || OpHAS_SIBLING(aop)) goto bad_ops; OpLASTSIB_set(iop, NULL); cLISTOPx(op)->op_first = aop; iop = op_contextualize(mapify_op(iop, base, OP_I_SUBTRACT), G_ARRAY); OpMORESIB_set(iop, aop); cLISTOPx(op)->op_first = iop; } return THX_nxck_aslice(aTHX_ op); } #if QHAVE_OP_KVASLICE static OP *THX_pp_munge_kvaslice(pTHX) { dSP; dMARK; if(SP != MARK) { SV **kp; IV base = POPi; PUTBACK; if(MARK+1 != SP) { for(kp = MARK; kp != SP; kp += 2) { SV *k = kp[1]; if(SvOK(k)) kp[1] = sv_2mortal( newSViv(SvIV(k) + base)); } } } return PL_op->op_next; } #define newUNOP_munge_kvaslice(f, l) THX_newUNOP_munge_kvaslice(aTHX_ f, l) static OP *THX_newUNOP_munge_kvaslice(pTHX_ OP *kvasliceop, OP *baseop) { OP *mungeop, *pushop; pushop = newOP(OP_PUSHMARK, 0); NewOpSz(0, mungeop, sizeof(UNOP)); #ifdef XopENTRY_set mungeop->op_type = OP_CUSTOM; #else /* !XopENTRY_set */ mungeop->op_type = OP_DOFILE; #endif /* !XopENTRY_set */ mungeop->op_ppaddr = THX_pp_munge_kvaslice; mungeop->op_flags = OPf_KIDS; cUNOPx(mungeop)->op_first = pushop; OpMORESIB_set(pushop, kvasliceop); OpMORESIB_set(kvasliceop, baseop); OpLASTSIB_set(baseop, mungeop); return mungeop; } static OP *THX_myck_kvaslice(pTHX_ OP *op) { IV base; if((base = current_base()) != 0) { OP *iop, *aop; if(!(op->op_flags & OPf_KIDS)) { bad_ops: croak("strange op tree prevents applying array base"); } iop = cLISTOPx(op)->op_first; aop = OpSIBLING(iop); if(!aop || OpHAS_SIBLING(aop)) goto bad_ops; /* * A kvaslice op is built in a nasty way that interferes * with munging it through a checker. It's first built * containing the interesting operands, but missing a * necessary pushmark op. The checker gets invoked on * this incomplete op. Then the pushmark gets inserted, * without invoking any checker, provided that the op is * still of type kvaslice. If the checker changed the op * type, then instead a new kvaslice gets built containing * the pushmark and whatever the checker returned, * and the checker gets invoked a second time on that. * * The incomplete structure the first time round * means we can't very well wrap the op at that point. * We can munge the operands, but the wrapping needs to * be postponed until after the pushmark gets inserted. * But to get any control after the pushmark is inserted, * we have to change the op type the first time round, * so that we get invoked a second time. We can detect * which stage of op construction we're at by seeing * whether the first child is a pushmark. */ if(iop->op_type == OP_PUSHMARK) return newUNOP_munge_kvaslice( THX_nxck_kvaslice(aTHX_ op), newSVOP(OP_CONST, 0, newSViv(base))); OpLASTSIB_set(iop, NULL); cLISTOPx(op)->op_first = aop; iop = op_contextualize(mapify_op(iop, base, OP_I_SUBTRACT), G_ARRAY); OpMORESIB_set(iop, aop); cLISTOPx(op)->op_first = iop; op_null(op); return op; } else { return THX_nxck_kvaslice(aTHX_ op); } } #endif /* QHAVE_OP_KVASLICE */ static OP *THX_myck_lslice(pTHX_ OP *op) { IV base; if((base = current_base()) != 0) { OP *iop, *aop; if(!(op->op_flags & OPf_KIDS)) { bad_ops: croak("strange op tree prevents applying array base"); } iop = cBINOPx(op)->op_first; aop = OpSIBLING(iop); if(!aop || OpHAS_SIBLING(aop)) goto bad_ops; OpLASTSIB_set(iop, NULL); cBINOPx(op)->op_first = aop; cBINOPx(op)->op_last = NULL; iop = op_contextualize(mapify_op(iop, base, OP_I_SUBTRACT), G_ARRAY); OpMORESIB_set(iop, aop); cBINOPx(op)->op_first = iop; cBINOPx(op)->op_last = aop; } return THX_nxck_lslice(aTHX_ op); } static OP *THX_myck_av2arylen(pTHX_ OP *op) { IV base; if((base = current_base()) != 0) { op = THX_nxck_av2arylen(aTHX_ op); return newBINOP(OP_I_ADD, 0, op_contextualize(op, G_SCALAR), newSVOP(OP_CONST, 0, newSViv(base))); } else { return THX_nxck_av2arylen(aTHX_ op); } } static OP *THX_myck_splice(pTHX_ OP *op) { IV base; if((base = current_base()) != 0) { OP *pop, *aop, *iop; if(!(op->op_flags & OPf_KIDS)) { bad_ops: croak("strange op tree prevents applying array base"); } pop = cLISTOPx(op)->op_first; if(pop->op_type != OP_PUSHMARK) goto bad_ops; aop = OpSIBLING(pop); if(!aop) goto bad_ops; iop = OpSIBLING(aop); if(iop) { OP *rest = OpSIBLING(iop); OpMAYBESIB_set(aop, rest, op); OpLASTSIB_set(iop, NULL); if(!rest) cLISTOPx(op)->op_last = aop; iop = newBINOP(OP_I_SUBTRACT, 0, op_contextualize(iop, G_SCALAR), newSVOP(OP_CONST, 0, newSViv(base))); OpMAYBESIB_set(iop, rest, op); OpMORESIB_set(aop, iop); if(!rest) cLISTOPx(op)->op_last = iop; } } return THX_nxck_splice(aTHX_ op); } #if QHAVE_OP_AKEYS static OP *THX_myck_keys(pTHX_ OP *op) { /* * Annoyingly, keys(@array) ops don't go through the nominal * checker for OP_AKEYS. Instead they start out as OP_KEYS, * and get mutated to OP_AKEYS by the OP_KEYS checker. This * is therefore what we have to hook. */ OP *aop; IV base; if((op->op_flags & OPf_KIDS) && (aop = cUNOPx(op)->op_first, 1) && (aop->op_type == OP_PADAV || aop->op_type == OP_RV2AV) && (base = current_base()) != 0) { return mapify_op( op_contextualize(THX_nxck_keys(aTHX_ op), G_ARRAY), base, OP_I_ADD); } else { return THX_nxck_keys(aTHX_ op); } } #endif /* QHAVE_OP_AKEYS */ #if QHAVE_OP_AEACH static OP *THX_pp_munge_aeach(pTHX) { dSP; dMARK; if(SP != MARK) { IV base = POPi; if(SP != MARK && SvOK(MARK[1])) MARK[1] = sv_2mortal(newSViv(SvIV(MARK[1]) + base)); PUTBACK; } return PL_op->op_next; } #define newUNOP_munge_aeach(f, l) THX_newUNOP_munge_aeach(aTHX_ f, l) static OP *THX_newUNOP_munge_aeach(pTHX_ OP *aeachop, OP *baseop) { OP *mungeop, *pushop; pushop = newOP(OP_PUSHMARK, 0); NewOpSz(0, mungeop, sizeof(UNOP)); #ifdef XopENTRY_set mungeop->op_type = OP_CUSTOM; #else /* !XopENTRY_set */ mungeop->op_type = OP_DOFILE; #endif /* !XopENTRY_set */ mungeop->op_ppaddr = THX_pp_munge_aeach; mungeop->op_flags = OPf_KIDS; cUNOPx(mungeop)->op_first = pushop; OpMORESIB_set(pushop, aeachop); OpMORESIB_set(aeachop, baseop); OpLASTSIB_set(baseop, mungeop); return mungeop; } static OP *THX_myck_each(pTHX_ OP *op) { /* * Annoyingly, each(@array) ops don't go through the nominal * checker for OP_AEACH. Instead they start out as OP_EACH, * and get mutated to OP_AEACH by the OP_EACH checker. This * is therefore what we have to hook. */ OP *aop; IV base; if((op->op_flags & OPf_KIDS) && (aop = cUNOPx(op)->op_first, 1) && (aop->op_type == OP_PADAV || aop->op_type == OP_RV2AV) && (base = current_base()) != 0) { return newUNOP_munge_aeach(THX_nxck_each(aTHX_ op), newSVOP(OP_CONST, 0, newSViv(base))); } else { return THX_nxck_each(aTHX_ op); } } #endif /* QHAVE_OP_AEACH */ MODULE = Array::Base PACKAGE = Array::Base PROTOTYPES: DISABLE BOOT: { #ifdef XopENTRY_set XOP *xop; Newxz(xop, 1, XOP); XopENTRY_set(xop, xop_name, "munge_aeach"); XopENTRY_set(xop, xop_desc, "fixup following each on array"); XopENTRY_set(xop, xop_class, OA_UNOP); Perl_custom_op_register(aTHX_ THX_pp_munge_aeach, xop); # if QHAVE_OP_KVASLICE Newxz(xop, 1, XOP); XopENTRY_set(xop, xop_name, "munge_kvaslice"); XopENTRY_set(xop, xop_desc, "fixup following pair slice on array"); XopENTRY_set(xop, xop_class, OA_UNOP); Perl_custom_op_register(aTHX_ THX_pp_munge_kvaslice, xop); # endif /* QHAVE_OP_KVASLICE */ #endif /* XopENTRY_set */ } BOOT: { base_hint_key_sv = newSVpvs_share("Array::Base/base"); base_hint_key_hash = SvSHARED_HASH(base_hint_key_sv); wrap_op_checker(OP_AELEM, THX_myck_aelem, &THX_nxck_aelem); wrap_op_checker(OP_ASLICE, THX_myck_aslice, &THX_nxck_aslice); #if QHAVE_OP_KVASLICE wrap_op_checker(OP_KVASLICE, THX_myck_kvaslice, &THX_nxck_kvaslice); #endif /* QHAVE_OP_KVASLICE */ wrap_op_checker(OP_LSLICE, THX_myck_lslice, &THX_nxck_lslice); wrap_op_checker(OP_AV2ARYLEN, THX_myck_av2arylen, &THX_nxck_av2arylen); wrap_op_checker(OP_SPLICE, THX_myck_splice, &THX_nxck_splice); #if QHAVE_OP_AKEYS wrap_op_checker(OP_KEYS, THX_myck_keys, &THX_nxck_keys); #endif /* QHAVE_OP_AKEYS */ #if QHAVE_OP_AEACH wrap_op_checker(OP_EACH, THX_myck_each, &THX_nxck_each); #endif /* QHAVE_OP_AEACH */ } void import(SV *classname, IV base) CODE: PERL_UNUSED_VAR(classname); PL_hints |= HINT_LOCALIZE_HH; gv_HVadd(PL_hintgv); if(base == 0) { (void) hv_delete_ent(GvHV(PL_hintgv), base_hint_key_sv, G_DISCARD, base_hint_key_hash); } else { SV *base_sv = newSViv(base); HE *he = hv_store_ent(GvHV(PL_hintgv), base_hint_key_sv, base_sv, base_hint_key_hash); if(he) { SV *val = HeVAL(he); SvSETMAGIC(val); } else { SvREFCNT_dec(base_sv); } } void unimport(SV *classname) CODE: PERL_UNUSED_VAR(classname); PL_hints |= HINT_LOCALIZE_HH; gv_HVadd(PL_hintgv); (void) hv_delete_ent(GvHV(PL_hintgv), base_hint_key_sv, G_DISCARD, base_hint_key_hash); Array-Base-0.006/t000755001750001750 013143430626 13645 5ustar00zeframzefram000000000000Array-Base-0.006/t/aeach.t000444001750001750 107413143430626 15232 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { if("$]" < 5.011) { require Test::More; Test::More::plan(skip_all => "no array each on this Perl"); } } use Test::More tests => 2; our @activity; use Array::Base +3; our @t0 = qw(a b c); @activity = (); foreach(0..5) { push @activity, [ each(@t0) ]; } is_deeply \@activity, [ [ 3, "a" ], [ 4, "b" ], [ 5, "c" ], [], [ 3, "a" ], [ 4, "b" ], ]; our @t1 = qw(a b c); @activity = (); foreach(0..5) { push @activity, [ scalar each(@t1) ]; } is_deeply \@activity, [ [ 3 ], [ 4 ], [ 5 ], [ undef ], [ 3 ], [ 4 ], ]; 1; Array-Base-0.006/t/aelem.t000444001750001750 160413143430626 15253 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 28; our @t = qw(a b c d e f); our $r = \@t; our($i3, $i4, $i8, $i9) = (3, 4, 8, 9); our @i4 = (3, 3, 3, 3); use Array::Base +3; is $t[3], "a"; is $t[4], "b"; is $t[8], "f"; is $t[9], undef; is_deeply [ scalar $t[4] ], [ "b" ]; is_deeply [ $t[4] ], [ "b" ]; is $r->[3], "a"; is $r->[4], "b"; is $r->[8], "f"; is $r->[9], undef; is_deeply [ scalar $r->[4] ], [ "b" ]; is_deeply [ $r->[4] ], [ "b" ]; is $t[$i3], "a"; is $t[$i4], "b"; is $t[$i8], "f"; is $t[$i9], undef; is_deeply [ scalar $t[$i4] ], [ "b" ]; is_deeply [ $t[$i4] ], [ "b" ]; is_deeply [ scalar $t[@i4] ], [ "b" ]; is_deeply [ $t[@i4] ], [ "b" ]; is $r->[$i3], "a"; is $r->[$i4], "b"; is $r->[$i8], "f"; is $r->[$i9], undef; is_deeply [ scalar $r->[$i4] ], [ "b" ]; is_deeply [ $r->[$i4] ], [ "b" ]; is_deeply [ scalar $r->[@i4] ], [ "b" ]; is_deeply [ $r->[@i4] ], [ "b" ]; 1; Array-Base-0.006/t/akeys.t000444001750001750 137013143430626 15304 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { if("$]" < 5.011) { require Test::More; Test::More::plan(skip_all => "no array keys on this Perl"); } } use Test::More tests => 8; our @t; use Array::Base +3; @t = (); is_deeply [ scalar keys @t ], [ 0 ]; is_deeply [ keys @t ], []; @t = qw(a b c d e f); is_deeply [ scalar keys @t ], [ 6 ]; is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; SKIP: { skip "no lexical \$_ on this perl", 4 if "$]" < 5.009001 || "$]" >= 5.023004; eval q{ no warnings "$]" >= 5.017009 ? "experimental" : "deprecated"; my $_; @t = (); is_deeply [ scalar keys @t ], [ 0 ]; is_deeply [ keys @t ], []; @t = qw(a b c d e f); is_deeply [ scalar keys @t ], [ 6 ]; is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; }; } 1; Array-Base-0.006/t/aslice.t000444001750001750 203613143430626 15430 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 16; our @t = qw(a b c d e f); our $r = \@t; our @i4 = (3, 5, 3, 5); use Array::Base +3; is_deeply [ scalar @t[3,4] ], [ qw(b) ]; is_deeply [ @t[3,4,8,9] ], [ qw(a b f), undef ]; is_deeply [ scalar @t[@i4] ], [ qw(c) ]; is_deeply [ @t[@i4] ], [ qw(a c a c) ]; is_deeply [ scalar @{$r}[3,4] ], [ qw(b) ]; is_deeply [ @{$r}[3,4,8,9] ], [ qw(a b f), undef ]; is_deeply [ scalar @{$r}[@i4] ], [ qw(c) ]; is_deeply [ @{$r}[@i4] ], [ qw(a c a c) ]; SKIP: { skip "no lexical \$_ on this perl", 8 if "$]" < 5.009001 || "$]" >= 5.023004; eval q{ no warnings "$]" >= 5.017009 ? "experimental" : "deprecated"; my $_; is_deeply [ scalar @t[3,4] ], [ qw(b) ]; is_deeply [ @t[3,4,8,9] ], [ qw(a b f), undef ]; is_deeply [ scalar @t[@i4] ], [ qw(c) ]; is_deeply [ @t[@i4] ], [ qw(a c a c) ]; is_deeply [ scalar @{$r}[3,4] ], [ qw(b) ]; is_deeply [ @{$r}[3,4,8,9] ], [ qw(a b f), undef ]; is_deeply [ scalar @{$r}[@i4] ], [ qw(c) ]; is_deeply [ @{$r}[@i4] ], [ qw(a c a c) ]; }; } 1; Array-Base-0.006/t/av2arylen.t000444001750001750 36113143430626 16052 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 4; our @t = qw(a b c d e f); our $r = \@t; use Array::Base +3; is_deeply [ scalar $#t ], [ 8 ]; is_deeply [ $#t ], [ 8 ]; is_deeply [ scalar $#$r ], [ 8 ]; is_deeply [ $#$r ], [ 8 ]; 1; Array-Base-0.006/t/kvaslice.t000444001750001750 131213143430626 15765 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { if("$]" < 5.019004) { require Test::More; Test::More::plan(skip_all => "no array pair slice on this Perl"); } } use Test::More tests => 8; our @t = qw(a b c d e f); our $r = \@t; our @i4 = (3, 5, 3, 5); use Array::Base +3; no warnings "syntax"; is_deeply [ scalar %t[3,4] ], [ "b" ]; is_deeply [ %t[3,4,8,9] ], [ 3, "a", 4, "b", 8, "f", 9, undef ]; is_deeply [ scalar %t[@i4] ], [ "c" ]; is_deeply [ %t[@i4] ], [ 3, "a", 5, "c", 3, "a", 5, "c" ]; is_deeply [ scalar %{$r}[3,4] ], [ "b" ]; is_deeply [ %{$r}[3,4,8,9] ], [ 3, "a", 4, "b", 8, "f", 9, undef ]; is_deeply [ scalar %{$r}[@i4] ], [ "c" ]; is_deeply [ %{$r}[@i4] ], [ 3, "a", 5, "c", 3, "a", 5, "c" ]; 1; Array-Base-0.006/t/lslice.t000444001750001750 134713143430626 15447 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 8; our @i4 = (3, 5, 3, 5); use Array::Base +3; is_deeply [ scalar qw(a b c d e f)[3,4] ], [ qw(b) ]; is_deeply [ qw(a b c d e f)[3,4,8,9] ], [ qw(a b f), undef ]; is_deeply [ scalar qw(a b c d e f)[@i4] ], [ qw(c) ]; is_deeply [ qw(a b c d e f)[@i4] ], [ qw(a c a c) ]; SKIP: { skip "no lexical \$_ on this perl", 4 if "$]" < 5.009001 || "$]" >= 5.023004; eval q{ no warnings "$]" >= 5.017009 ? "experimental" : "deprecated"; my $_; is_deeply [ scalar qw(a b c d e f)[3,4] ], [ qw(b) ]; is_deeply [ qw(a b c d e f)[3,4,8,9] ], [ qw(a b f), undef ]; is_deeply [ scalar qw(a b c d e f)[@i4] ], [ qw(c) ]; is_deeply [ qw(a b c d e f)[@i4] ], [ qw(a c a c) ]; }; } 1; Array-Base-0.006/t/pod_cvg.t000444001750001750 27313143430626 15572 0ustar00zeframzefram000000000000use 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; Array-Base-0.006/t/pod_syn.t000444001750001750 23613143430626 15623 0ustar00zeframzefram000000000000use 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; Array-Base-0.006/t/scope.t000444001750001750 75713143430626 15271 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { unshift @INC, "./t/lib"; } use Test::More tests => 10; our @t = qw(a b c d e f); is $t[3], "d"; use Array::Base +3; is $t[3], "a"; { is $t[3], "a"; use Array::Base -1; is $t[3], "e"; use Array::Base +0; is $t[3], "d"; use Array::Base +1; is $t[3], "c"; no Array::Base; is $t[3], "d"; } is $t[3], "a"; use t::scope_0; is scope0_test(), "d"; is eval(q{ use Array::Base +3; BEGIN { my $x = "foo\x{666}"; $x =~ /foo\p{Alnum}/; } $t[3]; }), "a"; 1; Array-Base-0.006/t/splice.t000444001750001750 207313143430626 15450 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 20; our @t; our @i5 = (3, 3, 3, 3, 3); use Array::Base +3; @t = qw(a b c d e f); is_deeply [ scalar splice @t ], [qw(f)]; is_deeply \@t, []; @t = qw(a b c d e f); is_deeply [ splice @t ], [qw(a b c d e f)]; is_deeply \@t, []; @t = qw(a b c d e f); is_deeply [ scalar splice @t, 5 ], [qw(f)]; is_deeply \@t, [qw(a b)]; @t = qw(a b c d e f); is_deeply [ splice @t, 5 ], [qw(c d e f)]; is_deeply \@t, [qw(a b)]; @t = qw(a b c d e f); is_deeply [ scalar splice @t, @i5 ], [qw(f)]; is_deeply \@t, [qw(a b)]; @t = qw(a b c d e f); is_deeply [ splice @t, @i5 ], [qw(c d e f)]; is_deeply \@t, [qw(a b)]; @t = qw(a b c d e f); is_deeply [ scalar splice @t, 5, 2 ], [qw(d)]; is_deeply \@t, [qw(a b e f)]; @t = qw(a b c d e f); is_deeply [ splice @t, 5, 2 ], [qw(c d)]; is_deeply \@t, [qw(a b e f)]; @t = qw(a b c d e f); is_deeply [ scalar splice @t, 5, 2, qw(x y z) ], [qw(d)]; is_deeply \@t, [qw(a b x y z e f)]; @t = qw(a b c d e f); is_deeply [ splice @t, 5, 2, qw(x y z) ], [qw(c d)]; is_deeply \@t, [qw(a b x y z e f)]; 1; Array-Base-0.006/t/lib000755001750001750 013143430626 14413 5ustar00zeframzefram000000000000Array-Base-0.006/t/lib/t000755001750001750 013143430626 14656 5ustar00zeframzefram000000000000Array-Base-0.006/t/lib/t/scope_0.pm000444001750001750 10513143430626 16655 0ustar00zeframzefram000000000000use warnings; use strict; sub main::scope0_test { $main::t[3] } 1;