diff options
author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-10 13:07:28 +0000 |
---|---|---|
committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-10 13:07:28 +0000 |
commit | 7f3c4eb624730bcc71e75500f295d193b9375fbc (patch) | |
tree | d32421911d2531642810e464183757eb485d9a09 | |
download | List-MoreUtils-tarball-7f3c4eb624730bcc71e75500f295d193b9375fbc.tar.gz |
List-MoreUtils-0.413HEADList-MoreUtils-0.413master
-rw-r--r-- | Changes | 387 | ||||
-rw-r--r-- | MANIFEST | 32 | ||||
-rw-r--r-- | META.json | 92 | ||||
-rw-r--r-- | META.yml | 37 | ||||
-rw-r--r-- | Makefile.PL | 226 | ||||
-rw-r--r-- | MoreUtils.xs | 1805 | ||||
-rw-r--r-- | README.md | 722 | ||||
-rw-r--r-- | dhash.h | 137 | ||||
-rw-r--r-- | inc/Config/AutoConf/LMU.pm | 29 | ||||
-rw-r--r-- | inc/inc_Capture-Tiny/Capture/Tiny.pm | 856 | ||||
-rw-r--r-- | inc/inc_Config-AutoConf/Config/AutoConf.pm | 3733 | ||||
-rw-r--r-- | inc/latest.pm | 8 | ||||
-rw-r--r-- | inc/latest/private.pm | 147 | ||||
-rw-r--r-- | lib/List/MoreUtils.pm | 960 | ||||
-rw-r--r-- | lib/List/MoreUtils/Contributing.pod | 88 | ||||
-rw-r--r-- | lib/List/MoreUtils/PP.pm | 587 | ||||
-rw-r--r-- | lib/List/MoreUtils/XS.pm | 81 | ||||
-rw-r--r-- | multicall.h | 165 | ||||
-rw-r--r-- | ppport.h | 7748 | ||||
-rw-r--r-- | t/lib/LMU/Test/Functions.pm | 1545 | ||||
-rw-r--r-- | t/lib/LMU/Test/Import.pm | 34 | ||||
-rw-r--r-- | t/lib/LMU/Test/XS.pm | 26 | ||||
-rw-r--r-- | t/lib/LMU/Test/ab.pm | 27 | ||||
-rw-r--r-- | t/lib/Test/LMU.pm | 86 | ||||
-rw-r--r-- | t/pureperl/Functions.t | 10 | ||||
-rw-r--r-- | t/pureperl/Import.t | 10 | ||||
-rw-r--r-- | t/pureperl/XS.t | 10 | ||||
-rw-r--r-- | t/pureperl/ab.t | 10 | ||||
-rw-r--r-- | t/xs/Functions.t | 10 | ||||
-rw-r--r-- | t/xs/Import.t | 10 | ||||
-rw-r--r-- | t/xs/XS.t | 10 | ||||
-rw-r--r-- | t/xs/ab.t | 10 |
32 files changed, 19638 insertions, 0 deletions
@@ -0,0 +1,387 @@ +Revision history for Perl extension List-MoreUtils + +0.413 2015-06-10 + - Fix compiling in c++ mode (depreciated, but some people seem to + require it). Solves RT#104690 + +0.412 2015-05-19 + - release 0.411_001 without further changes + +0.411_001 2015-05-11 + - move generation of test endpoints to author stage as requested per issue/#9 + - add a rough guide for contributors + - fix rt#103251 to avoid removing bundled stuff by accident + - Fix compilation errors under cl (Thanks to jddurand) + +0.410 2015-03-30 + - release 0.409_003 after no further issues came up + +0.409_003 2015-03-27 + - update bundled bootstrap modules + * Data::Tumbler to 0.010 + * Test::WriteVariants to 0.012 + * Config::AutoConf to 0.311 + - fix spelling (and add stop-words for names etc. in author tests) + +0.409_002 2015-03-23 + - fix multiple mg_get can break weird tie's (thanks to leont) + - fix test run using PERL5OPT=d:Confess (thanks kentl & ribasushi) + - use base instead of parent, cause parent isn't bundled before 5.10.1 + (smoke report from SREZIC) + - update bundled modules (for bootstrapping) and ppport.h (from 3.25 + to 3.31) + +0.409_001 2015-03-21 + - fix RT#102885: uniq bug broke tied array (reported by louying@pwrd.com) + - fix issue/8: Macros introduced in dfd851147f cause problems with MSVC + (reported by A. Sinan Unur) + - Update ppport.h from 3.25 to 3.31 + +0.408 2015-03-18 + - fix RT#102840: uniq broken for call-by-function-return (reported by + Jean-Damien Durand), with a new test case thanks to Thomas Sibley + - fix RT#102853: hent_val accesses (reported by Brad Forschinger with + a reasonable patch) + - fix RT#102833: Compilation error with perl 5.21.7+ (reported by + Slaven Rezic) + - fix regex for RT#44518 test + +0.407 2015-03-17 + - Added one(), onlyidx(), onlyval() (RT#73134, MHASCH) and onlyres() + - improve XS maintainability + - document how uniq/distinct deal with undef (RT#49800) + - add bsearchidx to satisfy RT#63470 + - add singleton to satisfy RT#94382 + - fix RT#82039 - uniq changes the type of its arguments + - fix RT#44518 again + +0.406 2015-03-03 + - add new functions firstres and lastres in addition to firstidx, lastidx, + firstval and lastval + - regenerate MANIFEST to bundle README.md + +0.405 2015-02-14 + - fix RT#78527 - first_val/last_val in documentation + - fix RT#102055 - ExtUtils::MakeMaker required version absurdly high + - update README (deploy it as README.md now) + - fix compiler issue for older/ansi-c89 compilers + - remove local compat workarounds in favour for ppport.h + +0.404 2015-01-28 + - fix ancient toolchains (PREREQ_PM & Co. set appropriately), + reported by ilmari + - bump version required of Test::More to 0.96 (#toolchain + calls it a "sane subset") + - fix some meta-data #toolchain pointed out + +0.403 2015-01-27 + - remove most recent stable perl recommendation from meta to + workaround misbehaving CPAN clients blocking update + - update copyright date + - ensure AUTHOR is a string on older toolchains + +0.402 2014-12-17 + - bump Config::AutoConf and Test::WriteVariants requirement for + improved 5.6 compatibility (fixes rt#101121) + - use base instead of parent in configure stage (improves building + on 5.6) + - fix rt#101067 by applying patch from Father Chrysostomos (thanks + to Lukas Mai (MAUKE) for reporting and explaining) + +0.401 2014-12-08 + - update bundled Config::AutoConf to 0.307 + - release after long testing period + +0.400_010 2014-12-08 + - bundle configure_requires using inc::latest + - fix RT#96596 by checking types before starting logic ... + * RT#86260 reported the same issue + - lower minimum perl required to 5.6 + - switch to check_produce_loadable_xs_build of Config::AutoConf 0.306 + +0.400_009 2014-05-05 + - improve documentation (David Golden, Jens Rehsack) + - bundle non-core modules (compared to 5.14) + +0.400_008 2014-04-24 + - fix none for 0.24 and clarify API tag documentation (David Golden) + - refactor import tags for clarity (David Golden) + +0.400_007 2014-04-22 + - cut out exporter-related cruft; it was only necessary when needing + to choose between multiple implementations (Toby Inkster) + - Reorganize and clarify documentation (David Golden) + - revise SYNOPSIS and DESCRIPTION for revised export model (David + Golden) + - introduce ":like_*" import tags (Toby Inkster, Jens Rehsack) + - remove Data::Tumbler and Module::Pluggable from configure + dependencies, they're coming with Test::WriteVariants + +0.400_006 2014-04-01 + - fix typos in POD (RT#87490 - thanks to David Steinbrunner) + - refactor LMU as discussed with David Golden, Tim Bunce and + Toby Inkster + +0.400_005 2014-03-24 + - rename implementations from alias => relax and tassilo => strict + - remove 'sno' implementation + - add precedence 'default' in addition to 'all' for those who prefer + strict over relax + - move dependency Module::Runtime from configure to runtime + +0.400_004 2014-03-21 + - Switch from Sub::Exporter to Exporter::Tiny (Toby Inkster) + - fix issues on older perls back to 5.8.1 (Config::AutoConf + will not do out of the box, but this can be fixed) + - fix backward compatibility issues (RT#94013 in conjunction + with RT#93995) + Details needs to be discussed with Moose community (unless + they stop caring) to get out of distinguishing hell as soon + as possible + - fix some spelling issues reported by David Steinbrunner + (RT#86347) + - clarify depedencies, especially recommended ones + - add some additional tests to prove reported bugs (informed + reporters when not reproducable) + +0.400_003 2014-03-18 + - fix compile error on threaded perls (RT#93934 - thanks Andreas + Koenig for reporting) + - fix exporter configuration (RT#93929 - thanks Andreas Koenig for + reporting) + - fix RT#40905 by allowing choose an appropriate implementation + - add test for RT#76749 - seems not reproducable (but hopefully + reporter David J. Oswald can fix the test to help fixing the + issue beyond) + +0.400_002 2014-03-16 + - reduce minimum perl version to 5.8.1 + - split implementations between existing authors + - switch to DynaLoader and Sub::Exporter + - rely for testing on Test::WriteVariants and Data::Tumbler + (DBI::Test technology to improve tests) + - fix 64-bit integer precision (RT#93207 reported by Dana Jacobsen) + +0.400_001 2013-10-11 + - Reformat Changes as per CPAN::Changes::Spec + - taking FIRSTCOME power and move repository to GitHub + - merge Tassilo's 0.25_nn dev releases back + * mark "any" and "all" as "to be discussed" + ==> API changes made by Alias/ADAMK + - bump version to clarify new age (contributors welcome!) + - bump minimum perl version to 5.8.3 + +0.33 2011-08-04 + - Updated can_xs to fix a bug in it + +0.32 2011-05-20 + - Production release, no other changes + +0.31_02 2011-03-21 + - More accurate detection of XS support (ADAMK) + +0.31_01 2011-03-21 + - Updating copyright year (ADAMK) + - Teak documentation of all() and none() (WYANT) + - Memory leak fixed for apply() and XS version restored (ARC) + - Memory leak fixed for indexes() and XS version restored (ARC) + - Memory leak fixed for part() and XS version restored (ARC) + +0.30 2010-12-16 + - Change the way we localise PERL_DL_NONLAZY to false to remove + a warning that some people were seeing. The new approach is taken + from the way that List::Util does it. + +0.29 2010-12-08 + - Removed an erroneous Test::NoWarnings dependency + +0.28 2010-12-07 + - Switching to a production release + - Restored the regression test for RT #38630 from 0.23. + As apply() was disabled in 0.27_04 this test will only act + to validate the future XS restoration of apply(). + - Adding uniq warning tests, disabled initially + +0.27_04 2010-12-06 + - The behaviour of any/all/none/notall has changed when + passed a null list to treat a null list as a legitimate list. + Instead of returning C<undef> the functions now return the + following: any {} == false, all {} == true, none {} == true, + notall {} == false. + Resolves #40905: Returning undef when none is passed an empty + - Disabled the leaking XS versions of part(), apply() and indexes() + +0.27_03 2010-12-06 + - General house cleaning + +0.27_02 2010-12-01 + - Reduced test suite peak memory consumption by 5-10 meg + - Added the 'distinct' alias for the uniq function, for people that + like their chained map/grep/sort pipelines with a SQL'ish flavour. + - Expanded test suite for the any() group of functions. + - The any() group of functions now strictly always return scalar + boolean true, false and undef to match the XS version. + +0.27_01 2012-12-01 + - Refactored the split test scripts into a common test module + to be shared between both the Perl and XS versions. + - Reapply fix for http://rt.cpan.org/Ticket/Display.html?id=39847 + "minmax error: unpredictable results with lists of 1 element" + +0.26 2010-11-23 + - No changes + - Some parts of the CPAN cloud were confusing my 0.24 + release with the older deleted 0.24. Bumping version + past Tassilo's to clarify things. + +0.24 2010-11-22 + - No changes, switching to a production version + +0.23_01 2010-09-25 + - First attempt at repackaging the List::MoreUtils code in + Makefile.PL and release toolchain similar to Params::Util + +0.25_02 2009-08-01 + - MS VC++ 7 doesn't like inline nor 'long long' + (patch provided by Taro Nishino (taro DOT nishino AT gmail.com) + - Newx isbn't around in older perls so use New(0,...) instead + +0.25_01 2009-07-30 + - it seems the only way of handling the stack that works on all + flavors of the multicall API is by making a shallow copy of it + and use that between the PUSH/POP_MULTICALL bracket + - fix awkward ok() override in List-MoreUtils.t so that it reports + line numbers in test failures properly + +0.24 2009-07-19 + - List::MoreUtils was not handling the stack properly when the stack was grown + from inside code-references + - a couple of tests for each_arrayref were calling each_array + +0.23 2009-04-19 + - BACKWARDS INCOMPATIBLE CHANGE: + fixed: Returning undef when none is passed an empty array is counterintuitive + (http://rt.cpan.org/Ticket/Display.html?id=40905) + - fixed: minmax error: unpredictable results with lists of 1 element + (http://rt.cpan.org/Ticket/Display.html?id=39847) + - fixed: bug: uniq doesn't like undef values. + uniq warns on undef values + (http://rt.cpan.org/Ticket/Display.html?id=37533) + (http://rt.cpan.org/Ticket/Display.html?id=43214) + - fixed: bug in pairwise when $a and $b are lexically defined using my + (http://rt.cpan.org/Ticket/Display.html?id=44518) + - fixed: Big memory leak with XS part() + (http://rt.cpan.org/Ticket/Display.html?id=41097) + - fixed: memory leak in indexes() [XS] + (http://rt.cpan.org/Public/Bug/Display.html?id=41494) + - reduced memory-requirements for the part() tests as that was responsible + for a lot of unnecessary test-failures + - new function bsearch() which performs a binary search + +0.22 2006-07-02 + - SvPV_nolen doesn't exist on pre 5.6 perls + +0.21 2006-06-18 + - propagate dies from inside the code-reference of pairwise to + caller + +0.20 2006-04-25 + - part() would destroy the list elements when changing + an array in place (@list = part { ... } @list) + +0.19 2006-03-13 + - working down myself the queue of suggestions: + part() added + (Ricardo SIGNES <rjbs AT cpan DOT org>) + +0.18 2006-02-25 + - each_arrayref (XS) couldn't deal with refs to list literals + (brought up by David Filmer <usenet AT DavidFilmer DOT com> + in comp.lang.perl.misc) + +0.17 2005-12-07 + - each_arrayref had no XS implementation and wasn't + mentioned in the PODs + (patch by Anno Siegel <siegel AT zrz DOT tu-berlin DOT de>) + +0.16 2005-11-14 + - a dangling semicolon in some macros prevented + the XS portion to compile on some compilers + (Lars Thegler <lars AT thegler DOT dk>) + +0.15 2005-11-11 + - 0.13 and 0.14 broke the module on 5.6.x + (spotted by Thomas A. Lowery <tlowery AT cc3 DOT com>) + - internals changed to make use of the new MULTICALL API + which had to be backported to 5.005_x + +0.14 2005-11-10 + - 0.13 fixed the leaks but rendered the XS part uncompilable + for perls < 5.6.0: Fixed + (spotted by Lars Thegler <lars AT thegler DOT dk>) + +0.13 2005-11-09 + - nearly all functions receiving a CODE-block as first + argument had a hefty memory-leak: Fixed + (spotted by Thomas A. Lowery <tlowery AT cc3 DOT com>) + +0.12 2005-09-28 + - first_index and each_arrayref weren't exportable + (spotted by Darren Duncan) + +0.11 2005-09-27 + - make sure that Test::Pod and Test::Pod::Coverage are + installed in the required minimum versions + (thanks to Ricardo Signes <rjbs AT cpan DOT org>) + +0.10 2005-04-01 + - new function minmax() with comparisons in O(3n/2 - 2) + - some POD corrections (Adam Kennedy) + - POD- and POD-coverage tests + +0.09 2004-12-04 + - 0.08 only fixed uniq() for scalar context + +0.08 2004-12-03 + - uniq() was not mentioned in the perldocs and only had + the XS implementation + - uniq() also produced wrong results on 5.8.0 + (thanks to Slaven Rezic for spotting it and suggesting + a workaround) + - the test-suite triggered a bug in 5.6.x perls + - the test-suite now tests both the XS- and Perl-implementation + - a wrong example in the perldocs fixed (Ron Savage) + +0.07 2004-12-01 + - new functions: + after, after_incl, before, before_incl, indexes + lastval, firstval, pairwise, each_array, natatime, + mesh (all from Eric J. Roodes' List::MoreUtil). + +0.06 2004-11-14 + - new function 'apply' on behalf of Brian McCauley + (<nobull AT mail DOT com>) + +0.05 2004-09-18 + - merged in insert_after() and insert_after_string() from + List::Utils which is now obsolete + (thanks to James Keenan <jkeen AT verizon DOT net> and + Terrence Brannon <terry AT hcoop DOT net>) + +0.04 2004-07-10 + - renamed to List::MoreUtils on suggestion by + Steve Purkis <spurkis AT quiup DOT com> + +0.03 2004-07-09 + - some compilers don't like the stale goto labels + without any statement following. Fixed. + (Robert Rothenberg <wlkngowl AT i-2000 DOT com>) + +0.02 2004-07-08 + - added Perl implementations of all functions + as a fallback + (Adam Kennedy <adam AT phase-n DOT com>) + +0.01 2004-07-05 + - original version; created by h2xs 1.23 with options + -b 5.5.3 -A -n List::Any diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..f4543c4 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,32 @@ +Changes +dhash.h +inc/Config/AutoConf/LMU.pm +inc/inc_Capture-Tiny/Capture/Tiny.pm +inc/inc_Config-AutoConf/Config/AutoConf.pm +inc/latest.pm +inc/latest/private.pm +lib/List/MoreUtils.pm +lib/List/MoreUtils/Contributing.pod +lib/List/MoreUtils/PP.pm +lib/List/MoreUtils/XS.pm +Makefile.PL +MANIFEST This list of files +MoreUtils.xs +multicall.h +ppport.h +README.md +t/lib/LMU/Test/ab.pm +t/lib/LMU/Test/Functions.pm +t/lib/LMU/Test/Import.pm +t/lib/LMU/Test/XS.pm +t/lib/Test/LMU.pm +t/pureperl/ab.t +t/pureperl/Functions.t +t/pureperl/Import.t +t/pureperl/XS.t +t/xs/ab.t +t/xs/Functions.t +t/xs/Import.t +t/xs/XS.t +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..6b31e5f --- /dev/null +++ b/META.json @@ -0,0 +1,92 @@ +{ + "abstract" : "Provide the stuff missing in List::Util", + "author" : [ + "Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de>", + "Adam Kennedy <adamk@cpan.org>", + "Jens Rehsack <rehsack@cpan.org>" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "List-MoreUtils", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : {} + }, + "configure" : { + "recommends" : { + "Config::AutoConf" : "0.308", + "inc::latest" : "0.500" + }, + "requires" : { + "Carp" : "0", + "ExtUtils::MakeMaker" : "0", + "File::Basename" : "0", + "File::Copy" : "0", + "File::Path" : "0", + "File::Spec" : "0", + "IPC::Cmd" : "0", + "base" : "0" + } + }, + "develop" : { + "requires" : { + "Config::AutoConf" : "0.308", + "JSON::PP" : "0", + "Module::CPANTS::Analyse" : "0.96", + "Test::CPAN::Changes" : "0", + "Test::CheckManifest" : "0", + "Test::Kwalitee" : "0", + "Test::Pod" : "0", + "Test::Pod::Coverage" : "0", + "Test::Pod::Spelling::CommonMistakes" : "0", + "Test::Spelling" : "0", + "Test::WriteVariants" : "0.010", + "inc::latest" : "0.500" + } + }, + "runtime" : { + "requires" : { + "Exporter::Tiny" : "0.038", + "XSLoader" : "0" + } + }, + "test" : { + "recommends" : { + "Test::LeakTrace" : "0" + }, + "requires" : { + "Test::More" : "0.96" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-List-MoreUtils@rt.cpan.org", + "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=List-MoreUtils" + }, + "homepage" : "https://metacpan.org/release/List-MoreUtils", + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "type" : "git", + "url" : "https://github.com/perl5-utils/List-MoreUtils.git", + "web" : "https://github.com/perl5-utils/List-MoreUtils" + } + }, + "version" : "0.413" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..94e6cdc --- /dev/null +++ b/META.yml @@ -0,0 +1,37 @@ +--- +abstract: 'Provide the stuff missing in List::Util' +author: + - 'Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de>' + - 'Adam Kennedy <adamk@cpan.org>' + - 'Jens Rehsack <rehsack@cpan.org>' +build_requires: + Test::More: '0.96' +configure_requires: + Carp: '0' + ExtUtils::MakeMaker: '0' + File::Basename: '0' + File::Copy: '0' + File::Path: '0' + File::Spec: '0' + IPC::Cmd: '0' + base: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: List-MoreUtils +no_index: + directory: + - t + - inc +requires: + Exporter::Tiny: '0.038' + XSLoader: '0' +resources: + bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=List-MoreUtils + homepage: https://metacpan.org/release/List-MoreUtils + license: http://dev.perl.org/licenses/ + repository: https://github.com/perl5-utils/List-MoreUtils.git +version: '0.413' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..5efe744 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,226 @@ +#!perl + +use strict; +use warnings; + +require 5.006; + +BEGIN +{ + # to operate Capture::Tiny under perl 5.6 + eval "use Scalar::Util qw();"; + $@ and eval <<'EOSU'; +$INC{'Scalar/Util.pm'} = 'faked'; +package Scalar::Util; +use base "Exporter"; +# from PP part of Params::Util +our @EXPORT = qw(reftype blessed looks_like_number); +sub reftype { ref $_[0] } +my %types = ( + CODE => 1, + GLOB => 1, + REF => 1, + SCALAR => 1, + HASH => 1, + ARRAY => 1 +); +sub blessed { + my $t = ref $_[0]; + defined $t or return; + defined $types{$t} or return; + $t; +} +# from PP part of Params::Util +sub looks_like_number { + local $_ = shift; + + # checks from perlfaq4 + return 0 if !defined($_); + if (ref($_)) { + return overload::Overloaded($_) ? defined(0 + $_) : 0; + } + return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float + return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); + + 0; +} +EOSU +} + +use inc::latest 'Capture::Tiny'; +use inc::latest 'Config::AutoConf'; + +if ( inc::latest->can("write") ) +{ + inc::latest->write("inc"); + for my $mod ( inc::latest->loaded_modules ) + { + inc::latest->bundle_module( $mod, "inc" ); + } +} + +use ExtUtils::MakeMaker; + +use inc::Config::AutoConf::LMU (); + +if ( -d ".git" ) +{ + eval "use Sandbox::Tumble ();"; + $@ and die $@; + eval "use File::Path ();"; + File::Path->import; + -d 't/xs' and rmtree('t/xs'); + -d 't/pureperl' and rmtree('t/pureperl'); + Sandbox::Tumble->tumble(qw(t)); +} + +inc::Config::AutoConf::LMU->_set_argv(@ARGV); # XXX hack because we cannot construct for global use + +my $loadable_xs = inc::Config::AutoConf::LMU->check_produce_loadable_xs_build(); + +# Should we build the XS version? +my %RUN_DEPS = ( + 'XSLoader' => 0, + 'Exporter::Tiny' => '0.038', +); +my %BUNDLE_CONFIGURE_DEPS = ( + 'inc::latest' => '0.500', + 'Config::AutoConf' => '0.308', +); +my %CONFIGURE_DEPS = ( + 'Carp' => 0, + 'ExtUtils::MakeMaker' => 0, + 'File::Basename' => 0, + 'File::Copy' => 0, + 'File::Path' => 0, + 'File::Spec' => 0, + 'IPC::Cmd' => 0, + 'base' => 0, +); +my %BUILD_DEPS = (); + +my %TEST_DEPS = ( + 'Test::More' => 0.96, +); +my @XS_FILES = qw(MoreUtils.xs); + +WriteMakefile1( + META_MERGE => { + 'meta-spec' => { version => 2 }, + resources => { + homepage => 'https://metacpan.org/release/List-MoreUtils', + repository => { + url => 'https://github.com/perl5-utils/List-MoreUtils.git', + web => 'https://github.com/perl5-utils/List-MoreUtils', + type => 'git', + }, + bugtracker => { + web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=List-MoreUtils', + mailto => 'bug-List-MoreUtils@rt.cpan.org', + }, + license => 'http://dev.perl.org/licenses/', + }, + prereqs => { + develop => { + requires => { + 'Test::CPAN::Changes' => 0, + 'Test::CheckManifest' => 0, + 'Module::CPANTS::Analyse' => '0.96', + 'Test::Kwalitee' => 0, + 'Test::Pod' => 0, + 'Test::Pod::Coverage' => 0, + 'Test::Pod::Spelling::CommonMistakes' => 0, + 'Test::Spelling' => 0, + 'JSON::PP' => 0, + 'Test::WriteVariants' => '0.010', + %BUNDLE_CONFIGURE_DEPS, + }, + }, + configure => { + requires => {%CONFIGURE_DEPS}, + recommends => {%BUNDLE_CONFIGURE_DEPS}, + }, + build => { requires => {%BUILD_DEPS} }, + test => { + requires => {%TEST_DEPS}, + recommends => { 'Test::LeakTrace' => 0 } + }, + runtime => { + requires => { %RUN_DEPS, }, + }, + }, + }, + NAME => 'List::MoreUtils', + ABSTRACT => 'Provide the stuff missing in List::Util', + VERSION_FROM => 'lib/List/MoreUtils.pm', + AUTHOR => [ + 'Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de>', + 'Adam Kennedy <adamk@cpan.org>', + 'Jens Rehsack <rehsack@cpan.org>' + ], + LICENSE => 'perl', + CONFIGURE_REQUIRES => \%CONFIGURE_DEPS, + PREREQ_PM => \%RUN_DEPS, + BUILD_REQUIRES => \%BUILD_DEPS, + TEST_REQUIRES => \%TEST_DEPS, + ( + $loadable_xs + ? ( + XS => { map { ( my $tgt = $_ ) =~ s/\.xs$/\.c/; $_ => $tgt; } @XS_FILES }, + MAGICXS => 1, + INC => "-I." + ) + : () + ), + ( -d ".git" ? ( realclean => { FILES => "inc/latest* inc/inc_* t/pureperl t/xs" } ) : () ), + depend => { '$(FIRST_MAKEFILE)' => '$(VERSION_FROM)' }, + test => { TESTS => join( ' ', 't/*.t', 't/pureperl/*.t', ( $loadable_xs ? 't/xs/*.t' : () ), 'xt/*.t' ) }, + # Otherwise 'cxinc' isn't defined + ( $] < 5.012 ? ( DEFINE => '-DPERL_EXT' ) : (), ), +); + +sub WriteMakefile1 +{ # originally written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. + my %params = @_; + my $eumm_version = $ExtUtils::MakeMaker::VERSION; + $eumm_version = eval $eumm_version; + die "EXTRA_META is deprecated" if ( exists( $params{EXTRA_META} ) ); + die "License not specified" if ( !exists( $params{LICENSE} ) ); + $params{TEST_REQUIRES} + and $eumm_version < 6.6303 + and $params{BUILD_REQUIRES} = { %{ $params{BUILD_REQUIRES} || {} }, %{ delete $params{TEST_REQUIRES} } }; + #EUMM 6.5502 has problems with BUILD_REQUIRES + $params{BUILD_REQUIRES} + and $eumm_version < 6.5503 + and $params{PREREQ_PM} = { %{ $params{PREREQ_PM} || {} }, %{ delete $params{BUILD_REQUIRES} } }; + ref $params{AUTHOR} + and "ARRAY" eq ref $params{AUTHOR} + and $eumm_version < 6.5702 + and $params{AUTHOR} = join( ", ", @{ $params{AUTHOR} } ); + delete $params{CONFIGURE_REQUIRES} if ( $eumm_version < 6.52 ); + delete $params{MIN_PERL_VERSION} if ( $eumm_version < 6.48 ); + delete $params{META_MERGE} if ( $eumm_version < 6.46 ); + delete $params{META_ADD}{prereqs} if ( $eumm_version < 6.58 ); + delete $params{META_ADD}{'meta-spec'} if ( $eumm_version < 6.58 ); + delete $params{META_ADD} if ( $eumm_version < 6.46 ); + delete $params{LICENSE} if ( $eumm_version < 6.31 ); + delete $params{AUTHOR} if ( $] < 5.005 ); + delete $params{ABSTRACT_FROM} if ( $] < 5.005 ); + delete $params{BINARY_LOCATION} if ( $] < 5.005 ); + + # more or less taken from Moose' Makefile.PL + if ( $params{CONFLICTS} ) + { + my $ok = CheckConflicts(%params); + exit(0) if ( $params{PREREQ_FATAL} and not $ok ); + my $cpan_smoker = grep { $_ =~ m/(?:CR_SMOKER|CPAN_REPORTER|AUTOMATED_TESTING)/ } keys %ENV; + unless ( $cpan_smoker || $ENV{PERL_MM_USE_DEFAULT} ) + { + sleep 4 unless ($ok); + } + delete $params{CONFLICTS}; + } + + WriteMakefile(%params); +} diff --git a/MoreUtils.xs b/MoreUtils.xs new file mode 100644 index 0000000..6e93971 --- /dev/null +++ b/MoreUtils.xs @@ -0,0 +1,1805 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "multicall.h" +#include "ppport.h" + +#ifndef aTHX +# define aTHX +# define pTHX +#endif + +#ifdef SVf_IVisUV +# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv)) +#else +# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv)) +#endif + +/* + * Perl < 5.18 had some kind of different SvIV_please_nomg + */ +#if PERL_VERSION < 18 +#undef SvIV_please_nomg +# define SvIV_please_nomg(sv) \ + (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv)) \ + ? (SvIV_nomg(sv), SvIOK(sv)) \ + : SvIOK(sv)) +#endif + +/* compare left and right SVs. Returns: + * -1: < + * 0: == + * 1: > + * 2: left or right was a NaN + */ +static I32 +ncmp(SV* left, SV * right) +{ + /* Fortunately it seems NaN isn't IOK */ + if(SvAMAGIC(left) || SvAMAGIC(right)) + return SvIVX(amagic_call(left, right, ncmp_amg, 0)); + + if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) { + if (!SvUOK(left)) { + const IV leftiv = SvIVX(left); + if (!SvUOK(right)) { + /* ## IV <=> IV ## */ + const IV rightiv = SvIVX(right); + return (leftiv > rightiv) - (leftiv < rightiv); + } + /* ## IV <=> UV ## */ + if (leftiv < 0) + /* As (b) is a UV, it's >=0, so it must be < */ + return -1; + { + const UV rightuv = SvUVX(right); + return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv); + } + } + + if (SvUOK(right)) { + /* ## UV <=> UV ## */ + const UV leftuv = SvUVX(left); + const UV rightuv = SvUVX(right); + return (leftuv > rightuv) - (leftuv < rightuv); + } + /* ## UV <=> IV ## */ + { + const IV rightiv = SvIVX(right); + if (rightiv < 0) + /* As (a) is a UV, it's >=0, so it cannot be < */ + return 1; + { + const UV leftuv = SvUVX(left); + return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); + } + } + assert(0); /* NOTREACHED */ + } + else + { +#ifdef SvNV_nomg + NV const rnv = SvNV_nomg(right); + NV const lnv = SvNV_nomg(left); +#else + NV const rnv = slu_sv_value(right); + NV const lnv = slu_sv_value(left); +#endif + +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + if (Perl_isnan(lnv) || Perl_isnan(rnv)) { + return 2; + } + return (lnv > rnv) - (lnv < rnv); +#else + if (lnv < rnv) + return -1; + if (lnv > rnv) + return 1; + if (lnv == rnv) + return 0; + return 2; +#endif + } +} + +#define FUNC_NAME GvNAME(GvEGV(ST(items))) + +/* shameless stolen from PadWalker */ +#ifndef PadARRAY +typedef AV PADNAMELIST; +typedef SV PADNAME; +# if PERL_VERSION < 8 || (PERL_VERSION == 8 && !PERL_SUBVERSION) +typedef AV PADLIST; +typedef AV PAD; +# endif +# define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) +# define PadlistMAX(pl) AvFILLp(pl) +# define PadlistNAMES(pl) (*PadlistARRAY(pl)) +# define PadnamelistARRAY(pnl) ((PADNAME **)AvARRAY(pnl)) +# define PadnamelistMAX(pnl) AvFILLp(pnl) +# define PadARRAY AvARRAY +# define PadnameIsOUR(pn) !!(SvFLAGS(pn) & SVpad_OUR) +# define PadnameOURSTASH(pn) SvOURSTASH(pn) +# define PadnameOUTER(pn) !!SvFAKE(pn) +# define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) +#endif +#ifndef PadnameSV +# define PadnameSV(pn) pn +#endif +#ifndef PadnameFLAGS +# define PadnameFLAGS(pn) (SvFLAGS(PadnameSV(pn))) +#endif + +static int +in_pad (SV *code) +{ + GV *gv; + HV *stash; + CV *cv = sv_2cv(code, &stash, &gv, 0); + PADLIST *pad_list = (CvPADLIST(cv)); + PADNAMELIST *pad_namelist = PadlistNAMES(pad_list); + PADNAME **pad_names = PadnamelistARRAY(pad_namelist); + int i; + + for (i=PadnamelistMAX(pad_namelist); i>=0; --i) { + PADNAME* name_sv = PadnamelistARRAY(pad_namelist)[i]; + if (name_sv) { + char *name_str = PadnamePV(name_sv); + if (name_str) { + + /* perl < 5.6.0 does not yet have our */ +# ifdef SVpad_OUR + if(PadnameIsOUR(name_sv)) + continue; +# endif + + if (!(PadnameFLAGS(name_sv)) & SVf_OK) + continue; + + if (strEQ(name_str, "$a") || strEQ(name_str, "$b")) + return 1; + } + } + } + return 0; +} + +#define WARN_OFF \ + SV *oldwarn = PL_curcop->cop_warnings; \ + PL_curcop->cop_warnings = pWARN_NONE; + +#define WARN_ON \ + PL_curcop->cop_warnings = oldwarn; + +#define EACH_ARRAY_BODY \ + int i; \ + arrayeach_args * args; \ + HV *stash = gv_stashpv("List::MoreUtils_ea", TRUE); \ + CV *closure = newXS(NULL, XS_List__MoreUtils__array_iterator, __FILE__); \ + \ + /* prototype */ \ + sv_setpv((SV*)closure, ";$"); \ + \ + New(0, args, 1, arrayeach_args); \ + New(0, args->avs, items, AV*); \ + args->navs = items; \ + args->curidx = 0; \ + \ + for (i = 0; i < items; i++) { \ + if(!arraylike(ST(i))) \ + croak_xs_usage(cv, "\\@;\\@\\@..."); \ + args->avs[i] = (AV*)SvRV(ST(i)); \ + SvREFCNT_inc(args->avs[i]); \ + } \ + \ + CvXSUBANY(closure).any_ptr = args; \ + RETVAL = newRV_noinc((SV*)closure); \ + \ + /* in order to allow proper cleanup in DESTROY-handler */ \ + sv_bless(RETVAL, stash) + + +#define FOR_EACH(on_item) \ + if(!codelike(code)) \ + croak_xs_usage(cv, "code, ..."); \ + \ + if (items > 1) { \ + dMULTICALL; \ + int i; \ + HV *stash; \ + GV *gv; \ + CV *_cv; \ + SV **args = &PL_stack_base[ax]; \ + I32 gimme = G_SCALAR; \ + _cv = sv_2cv(code, &stash, &gv, 0); \ + PUSH_MULTICALL(_cv); \ + SAVESPTR(GvSV(PL_defgv)); \ + \ + for(i = 1 ; i < items ; ++i) { \ + GvSV(PL_defgv) = args[i]; \ + MULTICALL; \ + on_item; \ + } \ + POP_MULTICALL; \ + } + +#define TRUE_JUNCTION \ + FOR_EACH(if (SvTRUE(*PL_stack_sp)) ON_TRUE) \ + else ON_EMPTY; + +#define FALSE_JUNCTION \ + FOR_EACH(if (!SvTRUE(*PL_stack_sp)) ON_FALSE) \ + else ON_EMPTY; + +/* #include "dhash.h" */ + +/* need this one for array_each() */ +typedef struct { + AV **avs; /* arrays over which to iterate in parallel */ + int navs; /* number of arrays */ + int curidx; /* the current index of the iterator */ +} arrayeach_args; + +/* used for natatime */ +typedef struct { + SV **svs; + int nsvs; + int curidx; + int natatime; +} natatime_args; + +void +insert_after (int idx, SV *what, AV *av) { + int i, len; + av_extend(av, (len = av_len(av) + 1)); + + for (i = len; i > idx+1; i--) { + SV **sv = av_fetch(av, i-1, FALSE); + SvREFCNT_inc(*sv); + av_store(av, i, *sv); + } + if (!av_store(av, idx+1, what)) + SvREFCNT_dec(what); +} + +static int +is_like(SV *sv, const char *like) +{ + int likely = 0; + if( sv_isobject( sv ) ) + { + dSP; + int count; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs( sv_2mortal( newSVsv( sv ) ) ); + XPUSHs( sv_2mortal( newSVpv( like, strlen(like) ) ) ); + PUTBACK; + + if( ( count = call_pv("overload::Method", G_SCALAR) ) ) + { + I32 ax; + SPAGAIN; + + SP -= count; + ax = (SP - PL_stack_base) + 1; + if( SvTRUE(ST(0)) ) + ++likely; + } + + PUTBACK; + FREETMPS; + LEAVE; + } + + return likely; +} + +static int +is_array(SV *sv) +{ + return SvROK(sv) && ( SVt_PVAV == SvTYPE(SvRV(sv) ) ); +} + +static int +codelike(SV *code) +{ + SvGETMAGIC(code); + return SvROK(code) && ( ( SVt_PVCV == SvTYPE(SvRV(code)) ) || ( is_like(code, "&{}" ) ) ); +} + +static int +arraylike(SV *array) +{ + SvGETMAGIC(array); + return is_array(array) || is_like( array, "@{}" ); +} + +MODULE = List::MoreUtils_ea PACKAGE = List::MoreUtils_ea + +void +DESTROY(sv) + SV *sv; + CODE: + { + int i; + CV *code = (CV*)SvRV(sv); + arrayeach_args *args = (arrayeach_args *)(CvXSUBANY(code).any_ptr); + if (args) { + for (i = 0; i < args->navs; ++i) + SvREFCNT_dec(args->avs[i]); + Safefree(args->avs); + Safefree(args); + CvXSUBANY(code).any_ptr = NULL; + } + } + + +MODULE = List::MoreUtils_na PACKAGE = List::MoreUtils_na + +void +DESTROY(sv) + SV *sv; + CODE: + { + int i; + CV *code = (CV*)SvRV(sv); + natatime_args *args = (natatime_args *)(CvXSUBANY(code).any_ptr); + if (args) { + for (i = 0; i < args->nsvs; ++i) + SvREFCNT_dec(args->svs[i]); + Safefree(args->svs); + Safefree(args); + CvXSUBANY(code).any_ptr = NULL; + } + } + +MODULE = List::MoreUtils PACKAGE = List::MoreUtils + +void +any (code,...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_TRUE { POP_MULTICALL; XSRETURN_YES; } +#define ON_EMPTY XSRETURN_NO + TRUE_JUNCTION; + XSRETURN_NO; +#undef ON_EMPTY +#undef ON_TRUE +} + +void +all (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_FALSE { POP_MULTICALL; XSRETURN_NO; } +#define ON_EMPTY XSRETURN_YES + FALSE_JUNCTION; + XSRETURN_YES; +#undef ON_EMPTY +#undef ON_FALSE +} + + +void +none (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_TRUE { POP_MULTICALL; XSRETURN_NO; } +#define ON_EMPTY XSRETURN_YES + TRUE_JUNCTION; + XSRETURN_YES; +#undef ON_EMPTY +#undef ON_TRUE +} + +void +notall (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_FALSE { POP_MULTICALL; XSRETURN_YES; } +#define ON_EMPTY XSRETURN_NO + FALSE_JUNCTION; + XSRETURN_NO; +#undef ON_EMPTY +#undef ON_FALSE +} + +void +one (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + int found = 0; +#define ON_TRUE { if (found++) { POP_MULTICALL; XSRETURN_NO; }; } +#define ON_EMPTY XSRETURN_YES + TRUE_JUNCTION; + if (found) + XSRETURN_YES; + XSRETURN_NO; +#undef ON_EMPTY +#undef ON_TRUE +} + +void +any_u (code,...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_TRUE { POP_MULTICALL; XSRETURN_YES; } +#define ON_EMPTY XSRETURN_UNDEF + TRUE_JUNCTION; + XSRETURN_NO; +#undef ON_EMPTY +#undef ON_TRUE +} + +void +all_u (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_FALSE { POP_MULTICALL; XSRETURN_NO; } +#define ON_EMPTY XSRETURN_UNDEF + FALSE_JUNCTION; + XSRETURN_YES; +#undef ON_EMPTY +#undef ON_FALSE +} + + +void +none_u (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_TRUE { POP_MULTICALL; XSRETURN_NO; } +#define ON_EMPTY XSRETURN_UNDEF + TRUE_JUNCTION; + XSRETURN_YES; +#undef ON_EMPTY +#undef ON_TRUE +} + +void +notall_u (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ +#define ON_FALSE { POP_MULTICALL; XSRETURN_YES; } +#define ON_EMPTY XSRETURN_UNDEF + FALSE_JUNCTION; + XSRETURN_NO; +#undef ON_EMPTY +#undef ON_FALSE +} + +void +one_u (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + int found = 0; +#define ON_TRUE { if (found++) { POP_MULTICALL; XSRETURN_NO; }; } +#define ON_EMPTY XSRETURN_UNDEF + TRUE_JUNCTION; + if (found) + XSRETURN_YES; + XSRETURN_NO; +#undef ON_EMPTY +#undef ON_TRUE +} + +int +true (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + I32 count = 0; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) count++); + RETVAL = count; +} +OUTPUT: + RETVAL + +int +false (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + I32 count = 0; + FOR_EACH(if (!SvTRUE(*PL_stack_sp)) count++); + RETVAL = count; +} +OUTPUT: + RETVAL + +int +firstidx (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + RETVAL = -1; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) { RETVAL = i-1; break; }); +} +OUTPUT: + RETVAL + +SV * +firstval (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + RETVAL = &PL_sv_undef; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) { SvREFCNT_inc(RETVAL = args[i]); break; }); +} +OUTPUT: + RETVAL + +SV * +firstres (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + RETVAL = &PL_sv_undef; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) { SvREFCNT_inc(RETVAL = *PL_stack_sp); break; }); +} +OUTPUT: + RETVAL + +int +onlyidx (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + int found = 0; + RETVAL = -1; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) { if (found++) {RETVAL = -1; break;} RETVAL = i-1; }); +} +OUTPUT: + RETVAL + +SV * +onlyval (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + int found = 0; + RETVAL = &PL_sv_undef; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) { if (found++) {SvREFCNT_dec(RETVAL); RETVAL = &PL_sv_undef; break;} SvREFCNT_inc(RETVAL = args[i]); }); +} +OUTPUT: + RETVAL + +SV * +onlyres (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + int found = 0; + RETVAL = &PL_sv_undef; + FOR_EACH(if (SvTRUE(*PL_stack_sp)) { if (found++) {SvREFCNT_dec(RETVAL); RETVAL = &PL_sv_undef; break;}SvREFCNT_inc(RETVAL = *PL_stack_sp); }); +} +OUTPUT: + RETVAL + +int +lastidx (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + RETVAL = -1; + + if (items > 1) { + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = items-1 ; i > 0 ; --i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + RETVAL = i-1; + break; + } + } + POP_MULTICALL; + } +} +OUTPUT: + RETVAL + +SV * +lastval (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + RETVAL = &PL_sv_undef; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items > 1) { + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = items-1 ; i > 0 ; --i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + /* see comment in indexes() */ + SvREFCNT_inc(RETVAL = args[i]); + break; + } + } + POP_MULTICALL; + } +} +OUTPUT: + RETVAL + +SV * +lastres (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + RETVAL = &PL_sv_undef; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items > 1) { + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = items-1 ; i > 0 ; --i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + /* see comment in indexes() */ + SvREFCNT_inc(RETVAL = *PL_stack_sp); + break; + } + } + POP_MULTICALL; + } +} +OUTPUT: + RETVAL + +int +insert_after (code, val, avref) + SV *code; + SV *val; + SV *avref; +PROTOTYPE: &$\@ +CODE: +{ + dMULTICALL; + int i; + int len; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + CV *_cv; + AV *av; + + if(!codelike(code)) + croak_xs_usage(cv, "code, val, \\@area_of_operation"); + if(!arraylike(avref)) + croak_xs_usage(cv, "code, val, \\@area_of_operation"); + + av = (AV*)SvRV(avref); + len = av_len(av); + RETVAL = 0; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 0; i <= len ; ++i) { + GvSV(PL_defgv) = *av_fetch(av, i, FALSE); + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + RETVAL = 1; + break; + } + } + + POP_MULTICALL; + + if (RETVAL) { + SvREFCNT_inc(val); + insert_after(i, val, av); + } +} +OUTPUT: + RETVAL + +int +insert_after_string (string, val, avref) + SV *string; + SV *val; + SV *avref; + PROTOTYPE: $$\@ + CODE: + { + int i; + AV *av; + int len; + SV **sv; + STRLEN slen = 0, alen; + char *str; + char *astr; + RETVAL = 0; + + if(!arraylike(avref)) + croak_xs_usage(cv, "string, val, \\@area_of_operation"); + + av = (AV*)SvRV(avref); + len = av_len(av); + + if (SvTRUE(string)) + str = SvPV(string, slen); + else + str = NULL; + + for (i = 0; i <= len ; i++) { + sv = av_fetch(av, i, FALSE); + if (SvTRUE(*sv)) + astr = SvPV(*sv, alen); + else { + astr = NULL; + alen = 0; + } + if (slen == alen && memcmp(astr, str, slen) == 0) { + RETVAL = 1; + break; + } + } + if (RETVAL) { + SvREFCNT_inc(val); + insert_after(i, val, av); + } + + } + OUTPUT: + RETVAL + +void +apply (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + CV *_cv; + SV **args = &PL_stack_base[ax]; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items <= 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for(i = 1 ; i < items ; ++i) { + GvSV(PL_defgv) = newSVsv(args[i]); + MULTICALL; + args[i-1] = GvSV(PL_defgv); + } + POP_MULTICALL; + + for(i = 1 ; i < items ; ++i) + sv_2mortal(args[i-1]); + + XSRETURN(items-1); +} + +void +after (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i, j; + HV *stash; + CV *_cv; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items <= 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1; i < items; i++) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + break; + } + } + + POP_MULTICALL; + + for (j = i + 1; j < items; ++j) + args[j-i-1] = args[j]; + + XSRETURN(items-i-1); +} + +void +after_incl (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i, j; + HV *stash; + CV *_cv; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items <= 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1; i < items; i++) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + break; + } + } + + POP_MULTICALL; + + for (j = i; j < items; j++) + args[j-i] = args[j]; + + XSRETURN(items-i); +} + +void +before (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items <= 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1; i < items; i++) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + break; + } + args[i-1] = args[i]; + } + + POP_MULTICALL; + + XSRETURN(i-1); +} + +void +before_incl (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items <= 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1; i < items; ++i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + args[i-1] = args[i]; + if (SvTRUE(*PL_stack_sp)) { + ++i; + break; + } + } + + POP_MULTICALL; + + XSRETURN(i-1); +} + +void +indexes (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i, j; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items <= 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1, j = 0; i < items; i++) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) + /* POP_MULTICALL can free mortal temporaries, so we defer + * mortalising the returned values till after that's been + * done */ + args[j++] = newSViv(i-1); + } + + POP_MULTICALL; + + for (i = 0; i < j; i++) + sv_2mortal(args[i]); + + XSRETURN(j); +} + +void +_array_iterator (method = "") + const char *method; + PROTOTYPE: ;$ + CODE: + { + int i; + int exhausted = 1; + + /* 'cv' is the hidden argument with which XS_List__MoreUtils__array_iterator (this XSUB) + * is called. The closure_arg struct is stored in this CV. */ + + arrayeach_args *args = (arrayeach_args *)(CvXSUBANY(cv).any_ptr); + + if (strEQ(method, "index")) { + EXTEND(SP, 1); + ST(0) = args->curidx > 0 ? sv_2mortal(newSViv(args->curidx-1)) : &PL_sv_undef; + XSRETURN(1); + } + + EXTEND(SP, args->navs); + + for (i = 0; i < args->navs; i++) { + AV *av = args->avs[i]; + if (args->curidx <= av_len(av)) { + ST(i) = sv_2mortal(newSVsv(*av_fetch(av, args->curidx, FALSE))); + exhausted = 0; + continue; + } + ST(i) = &PL_sv_undef; + } + + if (exhausted) + XSRETURN_EMPTY; + + args->curidx++; + XSRETURN(args->navs); + } + +SV * +each_array (...) + PROTOTYPE: \@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@ + CODE: + { + EACH_ARRAY_BODY; + } + OUTPUT: + RETVAL + +SV * +each_arrayref (...) + CODE: + { + EACH_ARRAY_BODY; + } + OUTPUT: + RETVAL + +#if 0 +void +_pairwise (code, ...) + SV *code; + PROTOTYPE: &\@\@ + PPCODE: + { +#define av_items(a) (av_len(a)+1) + + int i; + AV *avs[2]; + SV **oldsp; + + int nitems = 0, maxitems = 0; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + /* deref AV's for convenience and + * get maximum items */ + avs[0] = (AV*)SvRV(ST(1)); + avs[1] = (AV*)SvRV(ST(2)); + maxitems = av_items(avs[0]); + if (av_items(avs[1]) > maxitems) + maxitems = av_items(avs[1]); + + if (!PL_firstgv || !PL_secondgv) { + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + } + + oldsp = PL_stack_base; + EXTEND(SP, maxitems); + ENTER; + for (i = 0; i < maxitems; i++) { + int nret; + SV **svp = av_fetch(avs[0], i, FALSE); + GvSV(PL_firstgv) = svp ? *svp : &PL_sv_undef; + svp = av_fetch(avs[1], i, FALSE); + GvSV(PL_secondgv) = svp ? *svp : &PL_sv_undef; + PUSHMARK(SP); + PUTBACK; + nret = call_sv(code, G_EVAL|G_ARRAY); + if (SvTRUE(ERRSV)) + croak("%s", SvPV_nolen(ERRSV)); + SPAGAIN; + nitems += nret; + while (nret--) { + SvREFCNT_inc(*PL_stack_sp++); + } + } + PL_stack_base = oldsp; + LEAVE; + XSRETURN(nitems); + } + +#endif + +void +pairwise (code, ...) + SV *code; + PROTOTYPE: &\@\@ + PPCODE: + { +#define av_items(a) (av_len(a)+1) + + /* This function is not quite as efficient as it ought to be: We call + * 'code' multiple times and want to gather its return values all in + * one list. However, each call resets the stack pointer so there is no + * obvious way to get the return values onto the stack without making + * intermediate copies of the pointers. The above disabled solution + * would be more efficient. Unfortunately it doesn't work (and, as of + * now, wouldn't deal with 'code' returning more than one value). + * + * The current solution is a fair trade-off. It only allocates memory + * for a list of SV-pointers, as many as there are return values. It + * temporarily stores 'code's return values in this list and, when + * done, copies them down to SP. */ + + int i, j; + AV *avs[2]; + SV **buf, **p; /* gather return values here and later copy down to SP */ + int alloc; + + int nitems = 0, maxitems = 0; + int d; + + if(!codelike(code)) + croak_xs_usage(cv, "code, list, list"); + if(!arraylike(ST(1))) + croak_xs_usage(cv, "code, list, list"); + if(!arraylike(ST(2))) + croak_xs_usage(cv, "code, list, list"); + + if (in_pad(code)) { + croak("Can't use lexical $a or $b in pairwise code block"); + } + + /* deref AV's for convenience and + * get maximum items */ + avs[0] = (AV*)SvRV(ST(1)); + avs[1] = (AV*)SvRV(ST(2)); + maxitems = av_items(avs[0]); + if (av_items(avs[1]) > maxitems) + maxitems = av_items(avs[1]); + + if (!PL_firstgv || !PL_secondgv) { + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + } + + New(0, buf, alloc = maxitems, SV*); + + ENTER; + for (d = 0, i = 0; i < maxitems; i++) { + int nret; + SV **svp = av_fetch(avs[0], i, FALSE); + GvSV(PL_firstgv) = svp ? *svp : &PL_sv_undef; + svp = av_fetch(avs[1], i, FALSE); + GvSV(PL_secondgv) = svp ? *svp : &PL_sv_undef; + PUSHMARK(SP); + PUTBACK; + nret = call_sv(code, G_EVAL|G_ARRAY); + if (SvTRUE(ERRSV)) { + Safefree(buf); + croak("%s", SvPV_nolen(ERRSV)); + } + SPAGAIN; + nitems += nret; + if (nitems > alloc) { + alloc <<= 2; + Renew(buf, alloc, SV*); + } + for (j = nret-1; j >= 0; j--) { + /* POPs would return elements in reverse order */ + buf[d] = sp[-j]; + d++; + } + sp -= nret; + } + LEAVE; + EXTEND(SP, nitems); + p = buf; + for (i = 0; i < nitems; i++) + ST(i) = *p++; + + Safefree(buf); + XSRETURN(nitems); + } + +void +_natatime_iterator () + PROTOTYPE: + CODE: + { + int i; + int nret; + + /* 'cv' is the hidden argument with which XS_List__MoreUtils__array_iterator (this XSUB) + * is called. The closure_arg struct is stored in this CV. */ + + natatime_args *args = (natatime_args*)CvXSUBANY(cv).any_ptr; + + nret = args->natatime; + + EXTEND(SP, nret); + + for (i = 0; i < args->natatime; i++) { + if (args->curidx < args->nsvs) { + ST(i) = sv_2mortal(newSVsv(args->svs[args->curidx++])); + } + else { + XSRETURN(i); + } + } + + XSRETURN(nret); + } + +SV * +natatime (n, ...) + int n; + PROTOTYPE: $@ + CODE: + { + int i; + natatime_args * args; + HV *stash = gv_stashpv("List::MoreUtils_na", TRUE); + + CV *closure = newXS(NULL, XS_List__MoreUtils__natatime_iterator, __FILE__); + + /* must NOT set prototype on iterator: + * otherwise one cannot write: &$it */ + /* !! sv_setpv((SV*)closure, ""); !! */ + + New(0, args, 1, natatime_args); + New(0, args->svs, items-1, SV*); + args->nsvs = items-1; + args->curidx = 0; + args->natatime = n; + + for (i = 1; i < items; i++) + SvREFCNT_inc(args->svs[i-1] = ST(i)); + + CvXSUBANY(closure).any_ptr = args; + RETVAL = newRV_noinc((SV*)closure); + + /* in order to allow proper cleanup in DESTROY-handler */ + sv_bless(RETVAL, stash); + } + OUTPUT: + RETVAL + +void +mesh (...) + PROTOTYPE: \@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@ + CODE: + { + int i, j, maxidx = -1; + AV **avs; + New(0, avs, items, AV*); + + for (i = 0; i < items; i++) { + if(!arraylike(ST(i))) + croak_xs_usage(cv, "\\@;\\@\\@..."); + avs[i] = (AV*)SvRV(ST(i)); + if (av_len(avs[i]) > maxidx) + maxidx = av_len(avs[i]); + } + + EXTEND(SP, items * (maxidx + 1)); + for (i = 0; i <= maxidx; i++) + for (j = 0; j < items; j++) { + SV **svp = av_fetch(avs[j], i, FALSE); + ST(i*items + j) = svp ? sv_2mortal(newSVsv(*svp)) : &PL_sv_undef; + } + + Safefree(avs); + XSRETURN(items * (maxidx + 1)); + } + +void +uniq (...) + PROTOTYPE: @ + CODE: + { + I32 i; + IV count = 0, seen_undef = 0; + HV *hv = newHV(); + SV **args = &PL_stack_base[ax]; + SV *tmp = sv_newmortal(); + sv_2mortal(newRV_noinc((SV*)hv)); + + /* don't build return list in scalar context */ + if (GIMME_V == G_SCALAR) { + for (i = 0; i < items; i++) { + SvGETMAGIC(args[i]); + if(SvOK(args[i])) { + sv_setsv_nomg(tmp, args[i]); + if (!hv_exists_ent(hv, tmp, 0)) { + ++count; + hv_store_ent(hv, tmp, &PL_sv_yes, 0); + } + } + else if(0 == seen_undef++) { + ++count; + } + } + ST(0) = sv_2mortal(newSVuv(count)); + XSRETURN(1); + } + + /* list context: populate SP with mortal copies */ + for (i = 0; i < items; i++) { + SvGETMAGIC(args[i]); + if(SvOK(args[i])) { + SvSetSV_nosteal(tmp, args[i]); + if (!hv_exists_ent(hv, tmp, 0)) { + /*ST(count) = sv_2mortal(newSVsv(ST(i))); + ++count;*/ + args[count++] = args[i]; + hv_store_ent(hv, tmp, &PL_sv_yes, 0); + } + } + else if(0 == seen_undef++) { + args[count++] = args[i]; + } + } + + XSRETURN(count); + } + +void +singleton (...) + PROTOTYPE: @ + CODE: + { + I32 i; + IV cnt = 0, count = 0, seen_undef = 0; + HV *hv = newHV(); + SV **args = &PL_stack_base[ax]; + SV *tmp = sv_newmortal(); + + sv_2mortal(newRV_noinc((SV*)hv)); + + for (i = 0; i < items; i++) { + SvGETMAGIC(args[i]); + if(SvOK(args[i])) { + HE *he; + SvSetSV_nosteal(tmp, args[i]); + he = hv_fetch_ent(hv, tmp, 0, 0); + if (NULL == he) { + /* ST(count) = sv_2mortal(newSVsv(ST(i))); */ + args[count++] = args[i]; + hv_store_ent(hv, tmp, newSViv(1), 0); + } + else { + SV *v = HeVAL(he); + IV how_many = SvIVX(v); + sv_setiv(v, ++how_many); + } + } + else if(0 == seen_undef++) { + args[count++] = args[i]; + } + } + + /* don't build return list in scalar context */ + if (GIMME_V == G_SCALAR) { + for (i = 0; i < count; i++) { + if(SvOK(args[i])) { + HE *he; + sv_setsv_nomg(tmp, args[i]); + he = hv_fetch_ent(hv, tmp, 0, 0); + if (he) { + SV *v = HeVAL(he); + IV how_many = SvIVX(v); + if( 1 == how_many ) + ++cnt; + } + } + else if(1 == seen_undef) { + ++cnt; + } + } + ST(0) = sv_2mortal(newSViv(cnt)); + XSRETURN(1); + } + + /* list context: populate SP with mortal copies */ + for (i = 0; i < count; i++) { + if(SvOK(args[i])) { + HE *he; + SvSetSV_nosteal(tmp, args[i]); + he = hv_fetch_ent(hv, tmp, 0, 0); + if (he) { + SV *v = HeVAL(he); + IV how_many = SvIVX(v); + if( 1 == how_many ) + args[cnt++] = args[i]; + } + } + else if(1 == seen_undef) { + args[cnt++] = args[i]; + } + } + + XSRETURN(cnt); + } + +void +minmax (...) + PROTOTYPE: @ + CODE: + { + I32 i; + SV *minsv, *maxsv; + + if (!items) + XSRETURN_EMPTY; + + minsv = maxsv = ST(0); + + if (items == 1) { + EXTEND(SP, 1); + ST(0) = ST(1) = minsv; + XSRETURN(2); + } + + for (i = 1; i < items; i += 2) { + SV *asv = ST(i-1); + SV *bsv = ST(i); + int cmp = ncmp(asv, bsv); + if (cmp < 0) { + int min_cmp = ncmp(minsv, asv); + int max_cmp = ncmp(maxsv, bsv); + if (min_cmp > 0) { + minsv = asv; + } + if (max_cmp < 0) { + maxsv = bsv; + } + } else { + int min_cmp = ncmp(minsv, bsv); + int max_cmp = ncmp(maxsv, asv); + if (min_cmp > 0) { + minsv = bsv; + } + if (max_cmp < 0) { + maxsv = asv; + } + } + } + + if (items & 1) { + SV *rsv = ST(items-1); + if (ncmp(minsv, rsv) > 0) { + minsv = rsv; + } + else if (ncmp(maxsv, rsv) < 0) { + maxsv = rsv; + } + } + ST(0) = minsv; + ST(1) = maxsv; + + XSRETURN(2); + } + +void +part (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int i; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *_cv; + + AV **tmp = NULL; + int last = 0; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items == 1) + XSRETURN_EMPTY; + + _cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + for(i = 1 ; i < items ; ++i) { + int idx; + GvSV(PL_defgv) = args[i]; + MULTICALL; + idx = SvIV(*PL_stack_sp); + + if (idx < 0 && (idx += last) < 0) + croak("Modification of non-creatable array value attempted, subscript %i", idx); + + if (idx >= last) { + int oldlast = last; + last = idx + 1; + Renew(tmp, last, AV*); + Zero(tmp + oldlast, last - oldlast, AV*); + } + if (!tmp[idx]) + tmp[idx] = newAV(); + av_push(tmp[idx], args[i]); + SvREFCNT_inc(args[i]); + } + POP_MULTICALL; + + EXTEND(SP, last); + for (i = 0; i < last; ++i) { + if (tmp[i]) + ST(i) = sv_2mortal(newRV_noinc((SV*)tmp[i])); + else + ST(i) = &PL_sv_undef; + } + + Safefree(tmp); + XSRETURN(last); +} + +#if 0 +void +part_dhash (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + /* We might want to keep this dhash-implementation. + * It is currently slower than the above but it uses less + * memory for sparse parts such as + * @part = part { 10_000_000 } 1 .. 100_000; + * Maybe there's a way to optimize dhash.h to get more speed + * from it. + */ + dMULTICALL; + int i, j, lastidx = -1; + int max; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + I32 count = 0; + SV **args = &PL_stack_base[ax]; + CV *cv; + + dhash_t *h = dhash_init(); + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items == 1) + XSRETURN_EMPTY; + + cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); + + for(i = 1 ; i < items ; ++i) { + int idx; + GvSV(PL_defgv) = args[i]; + MULTICALL; + idx = SvIV(*PL_stack_sp); + + if (idx < 0 && (idx += h->max) < 0) + croak("Modification of non-creatable array value attempted, subscript %i", idx); + + dhash_store(h, idx, args[i]); + } + POP_MULTICALL; + + dhash_sort_final(h); + + EXTEND(SP, max = h->max+1); + i = 0; + lastidx = -1; + while (i < h->count) { + int retidx = h->ary[i].key; + int fill = retidx - lastidx - 1; + for (j = 0; j < fill; j++) { + ST(retidx - j - 1) = &PL_sv_undef; + } + ST(retidx) = newRV_noinc((SV*)h->ary[i].val); + i++; + lastidx = retidx; + } + + dhash_destroy(h); + XSRETURN(max); +} + +#endif + +SV * +bsearch (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + HV *stash; + GV *gv; + I32 gimme = GIMME_V; /* perl-5.5.4 bus-errors out later when using GIMME + therefore we save its value in a fresh variable */ + SV **args = &PL_stack_base[ax]; + + long i, j; + int val = -1; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + if (items > 1) { + CV *_cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + i = 0; + j = items - 1; + do { + long k = (i + j) / 2; + + if (k >= items-1) + break; + + GvSV(PL_defgv) = args[1+k]; + MULTICALL; + val = SvIV(*PL_stack_sp); + + if (val == 0) { + POP_MULTICALL; + if (gimme != G_ARRAY) { + XSRETURN_YES; + } + SvREFCNT_inc(RETVAL = args[1+k]); + goto yes; + } + if (val < 0) { + i = k+1; + } else { + j = k-1; + } + } while (i <= j); + POP_MULTICALL; + } + + if (gimme == G_ARRAY) + XSRETURN_EMPTY; + else + XSRETURN_UNDEF; +yes: + ; +} +OUTPUT: + RETVAL + +int +bsearchidx (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + HV *stash; + GV *gv; + I32 gimme = GIMME_V; /* perl-5.5.4 bus-errors out later when using GIMME + therefore we save its value in a fresh variable */ + SV **args = &PL_stack_base[ax]; + + long i, j; + int val = -1; + + if(!codelike(code)) + croak_xs_usage(cv, "code, ..."); + + RETVAL = -1; + + if (items > 1) { + CV *_cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(_cv); + SAVESPTR(GvSV(PL_defgv)); + + i = 0; + j = items - 1; + do { + long k = (i + j) / 2; + + if (k >= items-1) + break; + + GvSV(PL_defgv) = args[1+k]; + MULTICALL; + val = SvIV(*PL_stack_sp); + + if (val == 0) { + RETVAL = k; + break; + } + if (val < 0) { + i = k+1; + } else { + j = k-1; + } + } while (i <= j); + POP_MULTICALL; + } +} +OUTPUT: + RETVAL + +void +_XScompiled () + CODE: + XSRETURN_YES; diff --git a/README.md b/README.md new file mode 100644 index 0000000..7bbe8ca --- /dev/null +++ b/README.md @@ -0,0 +1,722 @@ +# NAME + +List::MoreUtils - Provide the stuff missing in List::Util + +# SYNOPSIS + + # import specific functions + + use List::MoreUtils qw(any uniq); + + if ( any { /foo/ } uniq @has_duplicates ) { + # do stuff + } + + # import everything + + use List::MoreUtils ':all'; + + # import by API + + # has "original" any/all/none/notall behavior + use List::MoreUtils ':like_0.22'; + # 0.22 + bsearch + use List::MoreUtils ':like_0.24'; + # has "simplified" any/all/none/notall behavior + (n)sort_by + use List::MoreUtils ':like_0.33'; + +# DESCRIPTION + +__List::MoreUtils__ provides some trivial but commonly needed functionality on +lists which is not going to go into [List::Util](https://metacpan.org/pod/List::Util). + +All of the below functions are implementable in only a couple of lines of Perl +code. Using the functions from this module however should give slightly better +performance as everything is implemented in C. The pure-Perl implementation of +these functions only serves as a fallback in case the C portions of this module +couldn't be compiled on this machine. + +# EXPORTS + +## Default behavior + +Nothing by default. To import all of this module's symbols use the `:all` tag. +Otherwise functions can be imported by name as usual: + + use List::MoreUtils ':all'; + + use List::MoreUtils qw{ any firstidx }; + +Because historical changes to the API might make upgrading List::MoreUtils +difficult for some projects, the legacy API is available via special import +tags. + +## Like version 0.22 (last release with original API) + +This API was available from 2006 to 2009, returning undef for empty lists on +`all`/`any`/`none`/`notall`: + + use List::MoreUtils ':like_0.22'; + +This import tag will import all functions available as of version 0.22. +However, it will import `any_u` as `any`, `all_u` as `all`, `none_u` as +`none`, and `notall_u` as `notall`. + +## Like version 0.24 (first incompatible change) + +This API was available from 2010 to 2011. It changed the return value of `none` +and added the `bsearch` function. + + use List::MoreUtils ':like_0.24'; + +This import tag will import all functions available as of version 0.24. +However it will import `any_u` as `any`, `all_u` as `all`, and +`notall_u` as `notall`. It will import `none` as described in +the documentation below (true for empty list). + +## Like version 0.33 (second incompatible change) + +This API was available from 2011 to 2014. It is widely used in several CPAN +modules and thus it's closest to the current API. It changed the return values +of `any`, `all`, and `notall`. It added the `sort_by` and `nsort_by` functions +and the `distinct` alias for `uniq`. It omitted `bsearch`. + + use List::MoreUtils ':like_0.33'; + +This import tag will import all functions available as of version 0.33. Note: +it will not import `bsearch` for consistency with the 0.33 API. + +# FUNCTIONS + +## Junctions + +### _Treatment of an empty list_ + +There are two schools of thought for how to evaluate a junction on an +empty list: + +- Reduction to an identity (boolean) +- Result is undefined (three-valued) + +In the first case, the result of the junction applied to the empty list is +determined by a mathematical reduction to an identity depending on whether +the underlying comparison is "or" or "and". Conceptually: + + "any are true" "all are true" + -------------- -------------- + 2 elements: A || B || 0 A && B && 1 + 1 element: A || 0 A && 1 + 0 elements: 0 1 + +In the second case, three-value logic is desired, in which a junction +applied to an empty list returns `undef` rather than true or false + +Junctions with a `_u` suffix implement three-valued logic. Those +without are boolean. + +### all BLOCK LIST + +### all\_u BLOCK LIST + +Returns a true value if all items in LIST meet the criterion given through +BLOCK. Sets `$_` for each item in LIST in turn: + + print "All values are non-negative" + if all { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, `all` returns true (i.e. no values failed the condition) +and `all_u` returns `undef`. + +Thus, `all_u(@list)` is equivalent to `@list ? all(@list) : undef`. + +__Note__: because Perl treats `undef` as false, you must check the return value +of `all_u` with `defined` or you will get the opposite result of what you +expect. + +### any BLOCK LIST + +### any\_u BLOCK LIST + +Returns a true value if any item in LIST meets the criterion given through +BLOCK. Sets `$_` for each item in LIST in turn: + + print "At least one non-negative value" + if any { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, `any` returns false and `any_u` returns `undef`. + +Thus, `any_u(@list)` is equivalent to `@list ? any(@list) : undef`. + +### none BLOCK LIST + +### none\_u BLOCK LIST + +Logically the negation of `any`. Returns a true value if no item in LIST meets +the criterion given through BLOCK. Sets `$_` for each item in LIST in turn: + + print "No non-negative values" + if none { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, `none` returns true (i.e. no values failed the condition) +and `none_u` returns `undef`. + +Thus, `none_u(@list)` is equivalent to `@list ? none(@list) : undef`. + +__Note__: because Perl treats `undef` as false, you must check the return value +of `none_u` with `defined` or you will get the opposite result of what you +expect. + +### notall BLOCK LIST + +### notall\_u BLOCK LIST + +Logically the negation of `all`. Returns a true value if not all items in LIST +meet the criterion given through BLOCK. Sets `$_` for each item in LIST in +turn: + + print "Not all values are non-negative" + if notall { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, `notall` returns false and `notall_u` returns `undef`. + +Thus, `notall_u(@list)` is equivalent to `@list ? notall(@list) : undef`. + +## Transformation + +### apply BLOCK LIST + +Applies BLOCK to each item in LIST and returns a list of the values after BLOCK +has been applied. In scalar context, the last element is returned. This +function is similar to `map` but will not modify the elements of the input +list: + + my @list = (1 .. 4); + my @mult = apply { $_ *= 2 } @list; + print "\@list = @list\n"; + print "\@mult = @mult\n"; + __END__ + @list = 1 2 3 4 + @mult = 2 4 6 8 + +Think of it as syntactic sugar for + + for (my @mult = @list) { $_ *= 2 } + +### insert\_after BLOCK VALUE LIST + +Inserts VALUE after the first item in LIST for which the criterion in BLOCK is +true. Sets `$_` for each item in LIST in turn. + + my @list = qw/This is a list/; + insert_after { $_ eq "a" } "longer" => @list; + print "@list"; + __END__ + This is a longer list + +### insert\_after\_string STRING VALUE LIST + +Inserts VALUE after the first item in LIST which is equal to STRING. + + my @list = qw/This is a list/; + insert_after_string "a", "longer" => @list; + print "@list"; + __END__ + This is a longer list + +### pairwise BLOCK ARRAY1 ARRAY2 + +Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a +new list consisting of BLOCK's return values. The two elements are set to `$a` +and `$b`. Note that those two are aliases to the original value so changing +them will modify the input arrays. + + @a = (1 .. 5); + @b = (11 .. 15); + @x = pairwise { $a + $b } @a, @b; # returns 12, 14, 16, 18, 20 + + # mesh with pairwise + @a = qw/a b c/; + @b = qw/1 2 3/; + @x = pairwise { ($a, $b) } @a, @b; # returns a, 1, b, 2, c, 3 + +### mesh ARRAY1 ARRAY2 \[ ARRAY3 ... \] + +### zip ARRAY1 ARRAY2 \[ ARRAY3 ... \] + +Returns a list consisting of the first elements of each array, then +the second, then the third, etc, until all arrays are exhausted. + +Examples: + + @x = qw/a b c d/; + @y = qw/1 2 3 4/; + @z = mesh @x, @y; # returns a, 1, b, 2, c, 3, d, 4 + + @a = ('x'); + @b = ('1', '2'); + @c = qw/zip zap zot/; + @d = mesh @a, @b, @c; # x, 1, zip, undef, 2, zap, undef, undef, zot + +`zip` is an alias for `mesh`. + +### uniq LIST + +### distinct LIST + +Returns a new list by stripping duplicate values in LIST. The order of +elements in the returned list is the same as in LIST. In scalar context, +returns the number of unique elements in LIST. + + my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4 + my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5 + +`distinct` is an alias for `uniq`. + +## Partitioning + +### after BLOCK LIST + +Returns a list of the values of LIST after (and not including) the point +where BLOCK returns a true value. Sets `$_` for each element in LIST in turn. + + @x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9 + +### after\_incl BLOCK LIST + +Same as `after` but also includes the element for which BLOCK is true. + +### before BLOCK LIST + +Returns a list of values of LIST up to (and not including) the point where BLOCK +returns a true value. Sets `$_` for each element in LIST in turn. + +### before\_incl BLOCK LIST + +Same as `before` but also includes the element for which BLOCK is true. + +### part BLOCK LIST + +Partitions LIST based on the return value of BLOCK which denotes into which +partition the current value is put. + +Returns a list of the partitions thusly created. Each partition created is a +reference to an array. + + my $i = 0; + my @part = part { $i++ % 2 } 1 .. 8; # returns [1, 3, 5, 7], [2, 4, 6, 8] + +You can have a sparse list of partitions as well where non-set partitions will +be undef: + + my @part = part { 2 } 1 .. 10; # returns undef, undef, [ 1 .. 10 ] + +Be careful with negative values, though: + + my @part = part { -1 } 1 .. 10; + __END__ + Modification of non-creatable array value attempted, subscript -1 ... + +Negative values are only ok when they refer to a partition previously created: + + my @idx = ( 0, 1, -1 ); + my $i = 0; + my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] + +## Iteration + +### each\_array ARRAY1 ARRAY2 ... + +Creates an array iterator to return the elements of the list of arrays ARRAY1, +ARRAY2 throughout ARRAYn in turn. That is, the first time it is called, it +returns the first element of each array. The next time, it returns the second +elements. And so on, until all elements are exhausted. + +This is useful for looping over more than one array at once: + + my $ea = each_array(@a, @b, @c); + while ( my ($a, $b, $c) = $ea->() ) { .... } + +The iterator returns the empty list when it reached the end of all arrays. + +If the iterator is passed an argument of '`index`', then it returns +the index of the last fetched set of values, as a scalar. + +### each\_arrayref LIST + +Like each\_array, but the arguments are references to arrays, not the +plain arrays. + +### natatime EXPR, LIST + +Creates an array iterator, for looping over an array in chunks of +`$n` items at a time. (n at a time, get it?). An example is +probably a better explanation than I could give in words. + +Example: + + my @x = ('a' .. 'g'); + my $it = natatime 3, @x; + while (my @vals = $it->()) + { + print "@vals\n"; + } + +This prints + + a b c + d e f + g + +## Searching + +### bsearch BLOCK LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in `$_`) is smaller, +a positive value if it is bigger and zero if it matches. + +Returns a boolean value in scalar context. In list context, it returns the element +if it was found, otherwise the empty list. + +### firstval BLOCK LIST + +### first\_value BLOCK LIST + +Returns the first element in LIST for which BLOCK evaluates to true. Each +element of LIST is set to `$_` in turn. Returns `undef` if no such element +has been found. + +`first_value` is an alias for `firstval`. + +### lastval BLOCK LIST + +### last\_value BLOCK LIST + +Returns the last value in LIST for which BLOCK evaluates to true. Each element +of LIST is set to `$_` in turn. Returns `undef` if no such element has been +found. + +`last_value` is an alias for `lastval`. + +### indexes BLOCK LIST + +Evaluates BLOCK for each element in LIST (assigned to `$_`) and returns a list +of the indices of those elements for which BLOCK returned a true value. This is +just like `grep` only that it returns indices instead of values: + + @x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9 + +### firstidx BLOCK LIST + +### first\_index BLOCK LIST + +Returns the index of the first element in LIST for which the criterion in BLOCK +is true. Sets `$_` for each item in LIST in turn: + + my @list = (1, 4, 3, 2, 4, 6); + printf "item with index %i in list is 4", firstidx { $_ == 4 } @list; + __END__ + item with index 1 in list is 4 + + +Returns `-1` if no such item could be found. + +`first_index` is an alias for `firstidx`. + +### lastidx BLOCK LIST + +### last\_index BLOCK LIST + +Returns the index of the last element in LIST for which the criterion in BLOCK +is true. Sets `$_` for each item in LIST in turn: + + my @list = (1, 4, 3, 2, 4, 6); + printf "item with index %i in list is 4", lastidx { $_ == 4 } @list; + __END__ + item with index 4 in list is 4 + +Returns `-1` if no such item could be found. + +`last_index` is an alias for `lastidx`. + +## Sorting + +### sort\_by BLOCK LIST + +Returns the list of values sorted according to the string values returned by the +KEYFUNC block or function. A typical use of this may be to sort objects according +to the string value of some accessor, such as + + sort_by { $_->name } @people + +The key function is called in scalar context, being passed each value in turn as +both $\_ and the only argument in the parameters, @\_. The values are then sorted +according to string comparisons on the values returned. +This is equivalent to + + sort { $a->name cmp $b->name } @people + +except that it guarantees the name accessor will be executed only once per value. +One interesting use-case is to sort strings which may have numbers embedded in them +"naturally", rather than lexically. + + sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings + +This sorts strings by generating sort keys which zero-pad the embedded numbers to +some level (9 digits in this case), helping to ensure the lexical sort puts them +in the correct order. + +### nsort\_by BLOCK LIST + +Similar to sort\_by but compares its key values numerically. + +## Counting and calculation + +### true BLOCK LIST + +Counts the number of elements in LIST for which the criterion in BLOCK is true. +Sets `$_` for each item in LIST in turn: + + printf "%i item(s) are defined", true { defined($_) } @list; + +### false BLOCK LIST + +Counts the number of elements in LIST for which the criterion in BLOCK is false. +Sets `$_` for each item in LIST in turn: + + printf "%i item(s) are not defined", false { defined($_) } @list; + +### minmax LIST + +Calculates the minimum and maximum of LIST and returns a two element list with +the first element being the minimum and the second the maximum. Returns the +empty list if LIST was empty. + +The `minmax` algorithm differs from a naive iteration over the list where each +element is compared to two values being the so far calculated min and max value +in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient +possible algorithm. + +However, the Perl implementation of it has some overhead simply due to the fact +that there are more lines of Perl code involved. Therefore, LIST needs to be +fairly big in order for `minmax` to win over a naive implementation. This +limitation does not apply to the XS version. + +# ENVIRONMENT + +When `LIST_MOREUTILS_PP` is set, the module will always use the pure-Perl +implementation and not the XS one. This environment variable is really just +there for the test-suite to force testing the Perl implementation, and possibly +for reporting of bugs. I don't see any reason to use it in a production +environment. + +# MAINTENANCE + +The maintenance goal is to preserve the documented semantics of the API; +bug fixes that bring actual behavior in line with semantics are allowed. +New API functions may be added over time. If a backwards incompatible +change is unavoidable, we will attempt to provide support for the legacy +API using the same export tag mechanism currently in place. + +This module attempts to use few non-core dependencies. Non-core +configuration and testing modules will be bundled when reasonable; +run-time dependencies will be added only if they deliver substantial +benefit. + +# BUGS + +There is a problem with a bug in 5.6.x perls. It is a syntax error to write +things like: + + my @x = apply { s/foo/bar/ } qw{ foo bar baz }; + +It has to be written as either + + my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz'; + +or + + my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/; + +Perl 5.5.x and Perl 5.8.x don't suffer from this limitation. + +If you have a functionality that you could imagine being in this module, please +drop me a line. This module's policy will be less strict than [List::Util](https://metacpan.org/pod/List::Util)'s +when it comes to additions as it isn't a core module. + +When you report bugs, it would be nice if you could additionally give me the +output of your program with the environment variable `LIST_MOREUTILS_PP` set +to a true value. That way I know where to look for the problem (in XS, +pure-Perl or possibly both). + +# SUPPORT + +Bugs should always be submitted via the CPAN bug tracker. + +You can find documentation for this module with the perldoc command. + + perldoc List::MoreUtils + +You can also look for information at: + +- RT: CPAN's request tracker + + [http://rt.cpan.org/NoAuth/Bugs.html?Dist=List-MoreUtils](http://rt.cpan.org/NoAuth/Bugs.html?Dist=List-MoreUtils) + +- AnnoCPAN: Annotated CPAN documentation + + [http://annocpan.org/dist/List-MoreUtils](http://annocpan.org/dist/List-MoreUtils) + +- CPAN Ratings + + [http://cpanratings.perl.org/l/List-MoreUtils](http://cpanratings.perl.org/l/List-MoreUtils) + +- CPAN Search + + [http://search.cpan.org/dist/List-MoreUtils/](http://search.cpan.org/dist/List-MoreUtils/) + +- Git Repository + + [https://github.com/perl5-utils/List-MoreUtils](https://github.com/perl5-utils/List-MoreUtils) + +## Where can I go for help? + +If you have a bug report, a patch or a suggestion, please open a new +report ticket at CPAN (but please check previous reports first in case +your issue has already been addressed) or open an issue on GitHub. + +Report tickets should contain a detailed description of the bug or +enhancement request and at least an easily verifiable way of +reproducing the issue or fix. Patches are always welcome, too - and +it's cheap to send pull-requests on GitHub. Please keep in mind that +code changes are more likely accepted when they're bundled with an +approving test. + +If you think you've found a bug then please read +"How to Report Bugs Effectively" by Simon Tatham: +[http://www.chiark.greenend.org.uk/~sgtatham/bugs.html](http://www.chiark.greenend.org.uk/~sgtatham/bugs.html). + +## Where can I go for help with a concrete version? + +Bugs and feature requests are accepted against the latest version +only. To get patches for earlier versions, you need to get an +agreement with a developer of your choice - who may or not report the +issue and a suggested fix upstream (depends on the license you have +chosen). + +## Business support and maintenance + +Generally, in volunteered projects, there is no right for support. +While every maintainer is happy to improve the provided software, +spare time is limited. + +For those who have a use case which requires guaranteed support, one of +the maintainers should be hired or contracted. For business support you +can contact Jens via his CPAN email address rehsackATcpan.org. Please +keep in mind that business support is neither available for free nor +are you eligible to receive any support based on the license distributed +with this package. + +# THANKS + +## Tassilo von Parseval + +Credits go to a number of people: Steve Purkis for giving me namespace advice +and James Keenan and Terrence Branno for their effort of keeping the CPAN +tidier by making [List::Utils](https://metacpan.org/pod/List::Utils) obsolete. + +Brian McCauley suggested the inclusion of apply() and provided the pure-Perl +implementation for it. + +Eric J. Roode asked me to add all functions from his module `List::MoreUtil` +into this one. With minor modifications, the pure-Perl implementations of those +are by him. + +The bunch of people who almost immediately pointed out the many problems with +the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers). + +A particularly nasty memory leak was spotted by Thomas A. Lowery. + +Lars Thegler made me aware of problems with older Perl versions. + +Anno Siegel de-orphaned each\_arrayref(). + +David Filmer made me aware of a problem in each\_arrayref that could ultimately +lead to a segfault. + +Ricardo Signes suggested the inclusion of part() and provided the +Perl-implementation. + +Robin Huston kindly fixed a bug in perl's MULTICALL API to make the +XS-implementation of part() work. + +## Jens Rehsack + +Credits goes to all people contributing feedback during the v0.400 +development releases. + +Special thanks goes to David Golden who spent a lot of effort to develop +a design to support current state of CPAN as well as ancient software +somewhere in the dark. He also contributed a lot of patches to refactor +the API frontend to welcome any user of List::MoreUtils - from ancient +past to recently last used. + +Toby Inkster provided a lot of useful feedback for sane importer code +and was a nice sounding board for API discussions. + +Peter Rabbitson provided a sane git repository setup containing entire +package history. + +# TODO + +A pile of requests from other people is still pending further processing in +my mailbox. This includes: + +- List::Util export pass-through + + Allow __List::MoreUtils__ to pass-through the regular [List::Util](https://metacpan.org/pod/List::Util) + functions to end users only need to `use` the one module. + +- uniq\_by(&@) + + Use code-reference to extract a key based on which the uniqueness is + determined. Suggested by Aaron Crane. + +- delete\_index +- random\_item +- random\_item\_delete\_index +- list\_diff\_hash +- list\_diff\_inboth +- list\_diff\_infirst +- list\_diff\_insecond + + These were all suggested by Dan Muey. + +- listify + + Always return a flat list when either a simple scalar value was passed or an + array-reference. Suggested by Mark Summersault. + +# SEE ALSO + +[List::Util](https://metacpan.org/pod/List::Util), [List::AllUtils](https://metacpan.org/pod/List::AllUtils), [List::UtilsBy](https://metacpan.org/pod/List::UtilsBy) + +# AUTHOR + +Jens Rehsack <rehsack AT cpan.org> + +Adam Kennedy <adamk@cpan.org> + +Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de> + +# COPYRIGHT AND LICENSE + +Some parts copyright 2011 Aaron Crane. + +Copyright 2004 - 2010 by Tassilo von Parseval + +Copyright 2013 - 2015 by Jens Rehsack + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.4 or, +at your option, any later version of Perl 5 you may have available. @@ -0,0 +1,137 @@ +#ifndef __DHASH_H__ +#define __DHASH_H__ + +/* A special hash-type for use in part(). It is a store-only + * hash in that all key/value pairs are put into the hash. Then it is sorted by + * keys ascending with dhash_sort_final where the empty elements come at the end + * of the internal array. This need for sorting is actually what prevents us from + * using a dhash-based implementaion right now as it is the bottleneck for cases + * with many very small partitions. + * + * It doesn't use a linked list for collision recovery. Instead, on collision it will + * walk right in the array to find the first free spot. This search should never take + * too long as it uses a fairly good integer-hash function. + * + * The 'step' parameter isn't currently used. + */ + +#include <stdlib.h> /* for qsort() */ + +#define INITIAL_SIZE 4 + +typedef unsigned int hash_t; + +typedef struct { + int key; + AV *val; +} dhash_val_t; + +typedef struct { + int max; + int size; + int count; + int step; + dhash_val_t *ary; +} dhash_t; + +void dhash_dump(dhash_t *h); + +int cmp (dhash_val_t *a, dhash_val_t *b) { + /* all empty buckets should be at the end of the array */ + if (!a->val) + return 1; + if (!b->val) + return -1; + return a->key - b->key; +} + +dhash_t * dhash_init() { + dhash_t *h; + New(0, h, 1, dhash_t); + Newz(0, h->ary, INITIAL_SIZE, dhash_val_t); + h->max = 0; + h->size = INITIAL_SIZE; + h->count = 0; + return h; +} + +void dhash_destroy(dhash_t *h) { + Safefree(h->ary); + Safefree(h); +} + +inline hash_t HASH(register hash_t k) { + k += (k << 12); + k ^= (k >> 22); + k += (k << 4); + k ^= (k >> 9); + k += (k << 10); + k ^= (k >> 2); + k += (k << 7); + k ^= (k >> 12); + return k; +} + +void dhash_insert(dhash_t *h, int key, SV *sv, register hash_t hash) { + + while (h->ary[hash].val && h->ary[hash].key != key) + hash = (hash + 1) % h->size; + + if (!h->ary[hash].val) { + h->ary[hash].val = newAV(); + h->ary[hash].key = key; + h->count++; + } + + av_push(h->ary[hash].val, sv); + SvREFCNT_inc(sv); +} + +void dhash_resize(dhash_t *h) { + + register int i; + register hash_t hash; + dhash_val_t *old = h->ary; + + h->size <<= 1; + h->count = 0; + Newz(0, h->ary, h->size, dhash_val_t); + + for (i = 0; i < h->size>>1; ++i) { + if (!old[i].val) + continue; + hash = HASH(old[i].key) % h->size; + while (h->ary[hash].val) + hash = (hash + 1) % h->size; + h->ary[hash] = old[i]; + ++h->count; + } + Safefree(old); +} + +void dhash_store(dhash_t *h, int key, SV *val) { + hash_t hash; + if ((double)h->count / (double)h->size > 0.75) + dhash_resize(h); + hash = HASH(key) % h->size; + dhash_insert(h, key, val, hash); + if (key > h->max) + h->max = key; +} + +/* Once this is called, the hash is no longer useable. The only thing + * that may be done with it is iterate over h->ary to get the values + * sorted by keys */ +void dhash_sort_final(dhash_t *h) { + qsort(h->ary, h->size, sizeof(dhash_val_t), (int(*)(const void*,const void*))cmp); +} + +void dhash_dump(dhash_t *h) { + int i; + fprintf(stderr, "max=%i, size=%i, count=%i, ary=%p\n", h->max, h->size, h->count, h->ary); + for (i = 0; i < h->size; i++) { + fprintf(stderr, "%2i: key=%-5i => val=(AV*)%p\n", i, h->ary[i].key, h->ary[i].val); + } +} + +#endif diff --git a/inc/Config/AutoConf/LMU.pm b/inc/Config/AutoConf/LMU.pm new file mode 100644 index 0000000..55d02f9 --- /dev/null +++ b/inc/Config/AutoConf/LMU.pm @@ -0,0 +1,29 @@ +package inc::Config::AutoConf::LMU; + +use strict; +use warnings; + +use Config::AutoConf '0.306'; + +use base qw(Config::AutoConf); + +sub _check_pureperl_required +{ + my $self = shift->_get_instance; + foreach ( @{ $self->{_argv} } ) + { + /^-pm/ and warn "-pm is depreciated, please use PUREPERL_ONLY=1" and return 0; + /^-xs/ and warn "-xs is depreciated, building XS is default anyway" and return $self->{_force_xs} = 1; + } + return $self->SUPER::_check_pureperl_required(@_); +} + +sub check_produce_xs_build +{ + my $self = shift->_get_instance; + my $xs = $self->SUPER::check_produce_xs_build(@_); + $self->{_force_xs} and !$xs and $self->msg_error("XS forced but can't compile - giving up"); + return $xs; +} + +1; diff --git a/inc/inc_Capture-Tiny/Capture/Tiny.pm b/inc/inc_Capture-Tiny/Capture/Tiny.pm new file mode 100644 index 0000000..6c0ff51 --- /dev/null +++ b/inc/inc_Capture-Tiny/Capture/Tiny.pm @@ -0,0 +1,856 @@ +use 5.006; +use strict; +use warnings; +package Capture::Tiny; +# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs +our $VERSION = '0.30'; +use Carp (); +use Exporter (); +use IO::Handle (); +use File::Spec (); +use File::Temp qw/tempfile tmpnam/; +use Scalar::Util qw/reftype blessed/; +# Get PerlIO or fake it +BEGIN { + local $@; + eval { require PerlIO; PerlIO->can('get_layers') } + or *PerlIO::get_layers = sub { return () }; +} + +#--------------------------------------------------------------------------# +# create API subroutines and export them +# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] +#--------------------------------------------------------------------------# + +my %api = ( + capture => [1,1,0,0], + capture_stdout => [1,0,0,0], + capture_stderr => [0,1,0,0], + capture_merged => [1,1,1,0], + tee => [1,1,0,1], + tee_stdout => [1,0,0,1], + tee_stderr => [0,1,0,1], + tee_merged => [1,1,1,1], +); + +for my $sub ( keys %api ) { + my $args = join q{, }, @{$api{$sub}}; + eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic +} + +our @ISA = qw/Exporter/; +our @EXPORT_OK = keys %api; +our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); + +#--------------------------------------------------------------------------# +# constants and fixtures +#--------------------------------------------------------------------------# + +my $IS_WIN32 = $^O eq 'MSWin32'; + +##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; +## +##my $DEBUGFH; +##open $DEBUGFH, "> DEBUG" if $DEBUG; +## +##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; + +our $TIMEOUT = 30; + +#--------------------------------------------------------------------------# +# command to tee output -- the argument is a filename that must +# be opened to signal that the process is ready to receive input. +# This is annoying, but seems to be the best that can be done +# as a simple, portable IPC technique +#--------------------------------------------------------------------------# +my @cmd = ($^X, '-C0', '-e', <<'HERE'); +use Fcntl; +$SIG{HUP}=sub{exit}; +if ( my $fn=shift ) { + sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; + print {$fh} $$; + close $fh; +} +my $buf; while (sysread(STDIN, $buf, 2048)) { + syswrite(STDOUT, $buf); syswrite(STDERR, $buf); +} +HERE + +#--------------------------------------------------------------------------# +# filehandle manipulation +#--------------------------------------------------------------------------# + +sub _relayer { + my ($fh, $layers) = @_; + # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); + my %seen = ( unix => 1, perlio => 1 ); # filter these out + my @unique = grep { !$seen{$_}++ } @$layers; + # _debug("# applying unique layers (@unique) to @{[fileno $fh]}\n"); + binmode($fh, join(":", ":raw", @unique)); +} + +sub _name { + my $glob = shift; + no strict 'refs'; ## no critic + return *{$glob}{NAME}; +} + +sub _open { + open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; + # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); +} + +sub _close { + # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); + close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; +} + +my %dup; # cache this so STDIN stays fd0 +my %proxy_count; +sub _proxy_std { + my %proxies; + if ( ! defined fileno STDIN ) { + $proxy_count{stdin}++; + if (defined $dup{stdin}) { + _open \*STDIN, "<&=" . fileno($dup{stdin}); + # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); + } + else { + _open \*STDIN, "<" . File::Spec->devnull; + # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); + _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; + } + $proxies{stdin} = \*STDIN; + binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic + } + if ( ! defined fileno STDOUT ) { + $proxy_count{stdout}++; + if (defined $dup{stdout}) { + _open \*STDOUT, ">&=" . fileno($dup{stdout}); + # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); + } + else { + _open \*STDOUT, ">" . File::Spec->devnull; + # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); + _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; + } + $proxies{stdout} = \*STDOUT; + binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic + } + if ( ! defined fileno STDERR ) { + $proxy_count{stderr}++; + if (defined $dup{stderr}) { + _open \*STDERR, ">&=" . fileno($dup{stderr}); + # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); + } + else { + _open \*STDERR, ">" . File::Spec->devnull; + # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); + _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; + } + $proxies{stderr} = \*STDERR; + binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic + } + return %proxies; +} + +sub _unproxy { + my (%proxies) = @_; + # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); + for my $p ( keys %proxies ) { + $proxy_count{$p}--; + # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); + if ( ! $proxy_count{$p} ) { + _close $proxies{$p}; + _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup + delete $dup{$p}; + } + } +} + +sub _copy_std { + my %handles; + for my $h ( qw/stdout stderr stdin/ ) { + next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied + my $redir = $h eq 'stdin' ? "<&" : ">&"; + _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" + } + return \%handles; +} + +# In some cases we open all (prior to forking) and in others we only open +# the output handles (setting up redirection) +sub _open_std { + my ($handles) = @_; + _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; + _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; + _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; +} + +#--------------------------------------------------------------------------# +# private subs +#--------------------------------------------------------------------------# + +sub _start_tee { + my ($which, $stash) = @_; # $which is "stdout" or "stderr" + # setup pipes + $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; + pipe $stash->{reader}{$which}, $stash->{tee}{$which}; + # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); + select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush + # setup desired redirection for parent and child + $stash->{new}{$which} = $stash->{tee}{$which}; + $stash->{child}{$which} = { + stdin => $stash->{reader}{$which}, + stdout => $stash->{old}{$which}, + stderr => $stash->{capture}{$which}, + }; + # flag file is used to signal the child is ready + $stash->{flag_files}{$which} = scalar tmpnam(); + # execute @cmd as a separate process + if ( $IS_WIN32 ) { + local $@; + eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; + # _debug( "# Win32API::File loaded\n") unless $@; + my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); + # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); + my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); + # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); + _open_std( $stash->{child}{$which} ); + $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); + # not restoring std here as it all gets redirected again shortly anyway + } + else { # use fork + _fork_exec( $which, $stash ); + } +} + +sub _fork_exec { + my ($which, $stash) = @_; # $which is "stdout" or "stderr" + my $pid = fork; + if ( not defined $pid ) { + Carp::confess "Couldn't fork(): $!"; + } + elsif ($pid == 0) { # child + # _debug( "# in child process ...\n" ); + untie *STDIN; untie *STDOUT; untie *STDERR; + _close $stash->{tee}{$which}; + # _debug( "# redirecting handles in child ...\n" ); + _open_std( $stash->{child}{$which} ); + # _debug( "# calling exec on command ...\n" ); + exec @cmd, $stash->{flag_files}{$which}; + } + $stash->{pid}{$which} = $pid +} + +my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; +sub _files_exist { + return 1 if @_ == grep { -f } @_; + Time::HiRes::usleep(1000) if $have_usleep; + return 0; +} + +sub _wait_for_tees { + my ($stash) = @_; + my $start = time; + my @files = values %{$stash->{flag_files}}; + my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} + ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; + 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); + Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); + unlink $_ for @files; +} + +sub _kill_tees { + my ($stash) = @_; + if ( $IS_WIN32 ) { + # _debug( "# closing handles\n"); + close($_) for values %{ $stash->{tee} }; + # _debug( "# waiting for subprocesses to finish\n"); + my $start = time; + 1 until wait == -1 || (time - $start > 30); + } + else { + _close $_ for values %{ $stash->{tee} }; + waitpid $_, 0 for values %{ $stash->{pid} }; + } +} + +sub _slurp { + my ($name, $stash) = @_; + my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; + # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); + seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; + my $text = do { local $/; scalar readline $fh }; + return defined($text) ? $text : ""; +} + +#--------------------------------------------------------------------------# +# _capture_tee() -- generic main sub for capturing or teeing +#--------------------------------------------------------------------------# + +sub _capture_tee { + # _debug( "# starting _capture_tee with (@_)...\n" ); + my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; + my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); + Carp::confess("Custom capture options must be given as key/value pairs\n") + unless @opts % 2 == 0; + my $stash = { capture => { @opts } }; + for ( keys %{$stash->{capture}} ) { + my $fh = $stash->{capture}{$_}; + Carp::confess "Custom handle for $_ must be seekable\n" + unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); + } + # save existing filehandles and setup captures + local *CT_ORIG_STDIN = *STDIN ; + local *CT_ORIG_STDOUT = *STDOUT; + local *CT_ORIG_STDERR = *STDERR; + # find initial layers + my %layers = ( + stdin => [PerlIO::get_layers(\*STDIN) ], + stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], + stderr => [PerlIO::get_layers(\*STDERR, output => 1)], + ); + # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # get layers from underlying glob of tied filehandles if we can + # (this only works for things that work like Tie::StdHandle) + $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] + if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); + $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] + if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); + # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # bypass scalar filehandles and tied handles + # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN + my %localize; + $localize{stdin}++, local(*STDIN) + if grep { $_ eq 'scalar' } @{$layers{stdin}}; + $localize{stdout}++, local(*STDOUT) + if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; + $localize{stderr}++, local(*STDERR) + if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; + $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") + if tied *STDIN && $] >= 5.008; + $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") + if $do_stdout && tied *STDOUT && $] >= 5.008; + $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") + if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; + # _debug( "# localized $_\n" ) for keys %localize; + # proxy any closed/localized handles so we don't use fds 0, 1 or 2 + my %proxy_std = _proxy_std(); + # _debug( "# proxy std: @{ [%proxy_std] }\n" ); + # update layers after any proxying + $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; + $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; + # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # store old handles and setup handles for capture + $stash->{old} = _copy_std(); + $stash->{new} = { %{$stash->{old}} }; # default to originals + for ( keys %do ) { + $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); + seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; + $stash->{pos}{$_} = tell $stash->{capture}{$_}; + # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); + _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} + } + _wait_for_tees( $stash ) if $do_tee; + # finalize redirection + $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; + # _debug( "# redirecting in parent ...\n" ); + _open_std( $stash->{new} ); + # execute user provided code + my ($exit_code, $inner_error, $outer_error, @result); + { + local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN + # _debug( "# finalizing layers ...\n" ); + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; + # _debug( "# running code $code ...\n" ); + local $@; + eval { @result = $code->(); $inner_error = $@ }; + $exit_code = $?; # save this for later + $outer_error = $@; # save this for later + STDOUT->flush if $do_stdout; + STDERR->flush if $do_stderr; + } + # restore prior filehandles and shut down tees + # _debug( "# restoring filehandles ...\n" ); + _open_std( $stash->{old} ); + _close( $_ ) for values %{$stash->{old}}; # don't leak fds + # shouldn't need relayering originals, but see rt.perl.org #114404 + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; + _unproxy( %proxy_std ); + # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; + _kill_tees( $stash ) if $do_tee; + # return captured output, but shortcut in void context + # unless we have to echo output to tied/scalar handles; + my %got; + if ( defined wantarray or ($do_tee && keys %localize) ) { + for ( keys %do ) { + _relayer($stash->{capture}{$_}, $layers{$_}); + $got{$_} = _slurp($_, $stash); + # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); + } + print CT_ORIG_STDOUT $got{stdout} + if $do_stdout && $do_tee && $localize{stdout}; + print CT_ORIG_STDERR $got{stderr} + if $do_stderr && $do_tee && $localize{stderr}; + } + $? = $exit_code; + $@ = $inner_error if $inner_error; + die $outer_error if $outer_error; + # _debug( "# ending _capture_tee with (@_)...\n" ); + return unless defined wantarray; + my @return; + push @return, $got{stdout} if $do_stdout; + push @return, $got{stderr} if $do_stderr && ! $do_merge; + push @return, @result; + return wantarray ? @return : $return[0]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs + +=head1 VERSION + +version 0.30 + +=head1 SYNOPSIS + + use Capture::Tiny ':all'; + + # capture from external command + + ($stdout, $stderr, $exit) = capture { + system( $cmd, @args ); + }; + + # capture from arbitrary code (Perl or external) + + ($stdout, $stderr, @result) = capture { + # your code here + }; + + # capture partial or merged output + + $stdout = capture_stdout { ... }; + $stderr = capture_stderr { ... }; + $merged = capture_merged { ... }; + + # tee output + + ($stdout, $stderr) = tee { + # your code here + }; + + $stdout = tee_stdout { ... }; + $stderr = tee_stderr { ... }; + $merged = tee_merged { ... }; + +=head1 DESCRIPTION + +Capture::Tiny provides a simple, portable way to capture almost anything sent +to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or +from an external program. Optionally, output can be teed so that it is +captured while being passed through to the original filehandles. Yes, it even +works on Windows (usually). Stop guessing which of a dozen capturing modules +to use in any particular situation and just use this one. + +=head1 USAGE + +The following functions are available. None are exported by default. + +=head2 capture + + ($stdout, $stderr, @result) = capture \&code; + $stdout = capture \&code; + +The C<<< capture >>> function takes a code reference and returns what is sent to +STDOUT and STDERR as well as any return values from the code reference. In +scalar context, it returns only STDOUT. If no output was received for a +filehandle, it returns an empty string for that filehandle. Regardless of calling +context, all output is captured -- nothing is passed to the existing filehandles. + +It is prototyped to take a subroutine reference as an argument. Thus, it +can be called in block form: + + ($stdout, $stderr) = capture { + # your code here ... + }; + +Note that the coderef is evaluated in list context. If you wish to force +scalar context on the return value, you must use the C<<< scalar >>> keyword. + + ($stdout, $stderr, $count) = capture { + my @list = qw/one two three/; + return scalar @list; # $count will be 3 + }; + +Also note that within the coderef, the C<<< @_ >>> variable will be empty. So don't +use arguments from a surrounding subroutine without copying them to an array +first: + + sub wont_work { + my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG + ... + } + + sub will_work { + my @args = @_; + my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT + ... + } + +Captures are normally done to an anonymous temporary filehandle. To +capture via a named file (e.g. to externally monitor a long-running capture), +provide custom filehandles as a trailing list of option pairs: + + my $out_fh = IO::File->new("out.txt", "w+"); + my $err_fh = IO::File->new("out.txt", "w+"); + capture { ... } stdout => $out_fh, stderr => $err_fh; + +The filehandles must be readE<sol>write and seekable. Modifying the files or +filehandles during a capture operation will give unpredictable results. +Existing IO layers on them may be changed by the capture. + +When called in void context, C<<< capture >>> saves memory and time by +not reading back from the capture handles. + +=head2 capture_stdout + + ($stdout, @result) = capture_stdout \&code; + $stdout = capture_stdout \&code; + +The C<<< capture_stdout >>> function works just like C<<< capture >>> except only +STDOUT is captured. STDERR is not captured. + +=head2 capture_stderr + + ($stderr, @result) = capture_stderr \&code; + $stderr = capture_stderr \&code; + +The C<<< capture_stderr >>> function works just like C<<< capture >>> except only +STDERR is captured. STDOUT is not captured. + +=head2 capture_merged + + ($merged, @result) = capture_merged \&code; + $merged = capture_merged \&code; + +The C<<< capture_merged >>> function works just like C<<< capture >>> except STDOUT and +STDERR are merged. (Technically, STDERR is redirected to the same capturing +handle as STDOUT before executing the function.) + +Caution: STDOUT and STDERR output in the merged result are not guaranteed to be +properly ordered due to buffering. + +=head2 tee + + ($stdout, $stderr, @result) = tee \&code; + $stdout = tee \&code; + +The C<<< tee >>> function works just like C<<< capture >>>, except that output is captured +as well as passed on to the original STDOUT and STDERR. + +When called in void context, C<<< tee >>> saves memory and time by +not reading back from the capture handles, except when the +original STDOUT OR STDERR were tied or opened to a scalar +handle. + +=head2 tee_stdout + + ($stdout, @result) = tee_stdout \&code; + $stdout = tee_stdout \&code; + +The C<<< tee_stdout >>> function works just like C<<< tee >>> except only +STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). + +=head2 tee_stderr + + ($stderr, @result) = tee_stderr \&code; + $stderr = tee_stderr \&code; + +The C<<< tee_stderr >>> function works just like C<<< tee >>> except only +STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). + +=head2 tee_merged + + ($merged, @result) = tee_merged \&code; + $merged = tee_merged \&code; + +The C<<< tee_merged >>> function works just like C<<< capture_merged >>> except that output +is captured as well as passed on to STDOUT. + +Caution: STDOUT and STDERR output in the merged result are not guaranteed to be +properly ordered due to buffering. + +=head1 LIMITATIONS + +=head2 Portability + +Portability is a goal, not a guarantee. C<<< tee >>> requires fork, except on +Windows where C<<< system(1, @cmd) >>> is used instead. Not tested on any +particularly esoteric platforms yet. See the +L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny> +for test result by platform. + +=head2 PerlIO layers + +Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or +':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to +STDOUT or STDERR I<before> the call to C<<< capture >>> or C<<< tee >>>. This may not work +for tied filehandles (see below). + +=head2 Modifying filehandles before capturing + +Generally speaking, you should do little or no manipulation of the standard IO +filehandles prior to using Capture::Tiny. In particular, closing, reopening, +localizing or tying standard filehandles prior to capture may cause a variety of +unexpected, undesirable andE<sol>or unreliable behaviors, as described below. +Capture::Tiny does its best to compensate for these situations, but the +results may not be what you desire. + +B<Closed filehandles> + +Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously +closed. However, since they will be reopened to capture or tee output, any +code within the captured block that depends on finding them closed will, of +course, not find them to be closed. If they started closed, Capture::Tiny will +close them again when the capture block finishes. + +Note that this reopening will happen even for STDIN or a filehandle not being +captured to ensure that the filehandle used for capture is not opened to file +descriptor 0, as this causes problems on various platforms. + +Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles +and also breaks tee() for undiagnosed reasons. So don't do that. + +B<Localized filehandles> + +If code localizes any of Perl's standard filehandles before capturing, the capture +will affect the localized filehandles and not the original ones. External system +calls are not affected by localizing a filehandle in Perl and will continue +to send output to the original filehandles (which will thus not be captured). + +B<Scalar filehandles> + +If STDOUT or STDERR are reopened to scalar filehandles prior to the call to +C<<< capture >>> or C<<< tee >>>, then Capture::Tiny will override the output filehandle for +the duration of the C<<< capture >>> or C<<< tee >>> call and then, for C<<< tee >>>, send captured +output to the output filehandle after the capture is complete. (Requires Perl +5.8) + +Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar +reference, but note that external processes will not be able to read from such +a handle. Capture::Tiny tries to ensure that external processes will read from +the null device instead, but this is not guaranteed. + +B<Tied output filehandles> + +If STDOUT or STDERR are tied prior to the call to C<<< capture >>> or C<<< tee >>>, then +Capture::Tiny will attempt to override the tie for the duration of the +C<<< capture >>> or C<<< tee >>> call and then send captured output to the tied filehandle after +the capture is complete. (Requires Perl 5.8) + +Capture::Tiny may not succeed resending UTF-8 encoded data to a tied +STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle +is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine +appropriate layers like C<<< :utf8 >>> from the underlying filehandle and do the right +thing. + +B<Tied input filehandle> + +Capture::Tiny attempts to preserve the semantics of tied STDIN, but this +requires Perl 5.8 and is not entirely predictable. External processes +will not be able to read from such a handle. + +Unless having STDIN tied is crucial, it may be safest to localize STDIN when +capturing: + + my ($out, $err) = do { local *STDIN; capture { ... } }; + +=head2 Modifying filehandles during a capture + +Attempting to modify STDIN, STDOUT or STDERR I<during> C<<< capture >>> or C<<< tee >>> is +almost certainly going to cause problems. Don't do that. + +=head2 No support for Perl 5.8.0 + +It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later +is recommended. + +=head2 Limited support for Perl 5.6 + +Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. + +=head1 ENVIRONMENT + +=head2 PERL_CAPTURE_TINY_TIMEOUT + +Capture::Tiny uses subprocesses internally for C<<< tee >>>. By default, +Capture::Tiny will timeout with an error if such subprocesses are not ready to +receive data within 30 seconds (or whatever is the value of +C<<< $Capture::Tiny::TIMEOUT >>>). An alternate timeout may be specified by setting +the C<<< PERL_CAPTURE_TINY_TIMEOUT >>> environment variable. Setting it to zero will +disable timeouts. BE<lt>NOTEE<gt>, this does not timeout the code reference being +captured -- this only prevents Capture::Tiny itself from hanging your process +waiting for its child processes to be ready to proceed. + +=head1 SEE ALSO + +This module was, inspired by L<IO::CaptureOutput>, which provides +similar functionality without the ability to tee output and with more +complicated code and API. L<IO::CaptureOutput> does not handle layers +or most of the unusual cases described in the L</Limitations> section and +I no longer recommend it. + +There are many other CPAN modules that provide some sort of output capture, +albeit with various limitations that make them appropriate only in particular +circumstances. I'm probably missing some. The long list is provided to show +why I felt Capture::Tiny was necessary. + +=over + +=item * + +L<IO::Capture> + +=item * + +L<IO::Capture::Extended> + +=item * + +L<IO::CaptureOutput> + +=item * + +L<IPC::Capture> + +=item * + +L<IPC::Cmd> + +=item * + +L<IPC::Open2> + +=item * + +L<IPC::Open3> + +=item * + +L<IPC::Open3::Simple> + +=item * + +L<IPC::Open3::Utils> + +=item * + +L<IPC::Run> + +=item * + +L<IPC::Run::SafeHandles> + +=item * + +L<IPC::Run::Simple> + +=item * + +L<IPC::Run3> + +=item * + +L<IPC::System::Simple> + +=item * + +L<Tee> + +=item * + +L<IO::Tee> + +=item * + +L<File::Tee> + +=item * + +L<Filter::Handle> + +=item * + +L<Tie::STDERR> + +=item * + +L<Tie::STDOUT> + +=item * + +L<Test::Output> + +=back + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L<https://github.com/dagolden/Capture-Tiny/issues>. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L<https://github.com/dagolden/Capture-Tiny> + + git clone https://github.com/dagolden/Capture-Tiny.git + +=head1 AUTHOR + +David Golden <dagolden@cpan.org> + +=head1 CONTRIBUTORS + +=for stopwords Dagfinn Ilmari MannsÃ¥ker David E. Wheeler + +=over 4 + +=item * + +Dagfinn Ilmari MannsÃ¥ker <ilmari@ilmari.org> + +=item * + +David E. Wheeler <david@justatheory.com> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2009 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + +=cut diff --git a/inc/inc_Config-AutoConf/Config/AutoConf.pm b/inc/inc_Config-AutoConf/Config/AutoConf.pm new file mode 100644 index 0000000..ea093d8 --- /dev/null +++ b/inc/inc_Config-AutoConf/Config/AutoConf.pm @@ -0,0 +1,3733 @@ +package Config::AutoConf; + +use warnings; +use strict; + +use base 'Exporter'; + +our @EXPORT = ( '$LIBEXT', '$EXEEXT' ); + +use constant QUOTE => do { $^O eq "MSWin32" ? q["] : q['] }; + +use Config; +use Carp qw/croak/; + +use File::Temp qw/tempfile/; +use File::Basename; +use File::Spec; +use Text::ParseWords qw//; + +use Capture::Tiny qw/capture/; + +# in core since 5.7.3 +eval "use Scalar::Util qw/looks_like_number/;"; +__PACKAGE__->can("looks_like_number") or eval <<'EOP'; +=begin private + +=head2 looks_like_number + +=end private + +=cut + +# from PP part of Params::Util +sub looks_like_number { + local $_ = shift; + + # checks from perlfaq4 + return 0 if !defined($_); + if (ref($_)) { + return overload::Overloaded($_) ? defined(0 + $_) : 0; + } + return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float + return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); + + 0; +} +EOP + +eval "use File::Slurp::Tiny qw/read_file/;"; +__PACKAGE__->can("read_file") or eval <<'EOP'; +=begin private + +=head2 read_file + +=end private + +=cut + +sub read_file { + my $fn = shift; + local $@ = ""; + open( my $fh, "<", $fn ) or croak "Error opening $fn: $!"; + my $fc = <$fh>; + close($fh) or croak "I/O error closing $fn: $!"; + return $fc; +} +EOP + +# PA-RISC1.1-thread-multi +my %special_dlext = ( + darwin => ".dylib", + MSWin32 => ".dll", + ( $Config{archname} =~ m/PA-RISC/i ? ( "hpux" => ".sl" ) : () ), +); + +our ( $LIBEXT, $EXEEXT ); + +defined $LIBEXT + or $LIBEXT = + defined $Config{so} ? "." . $Config{so} + : defined $special_dlext{$^O} ? $special_dlext{$^O} + : ".so"; +defined $EXEEXT + or $EXEEXT = ( $^O eq "MSWin32" ) ? ".exe" : ""; + +=encoding UTF-8 + +=head1 NAME + +Config::AutoConf - A module to implement some of AutoConf macros in pure perl. + +=cut + +our $VERSION = '0.311'; +$VERSION = eval $VERSION; + +=head1 ABSTRACT + +With this module I pretend to simulate some of the tasks AutoConf +macros do. To detect a command, to detect a library, etc. + +=head1 SYNOPSIS + + use Config::AutoConf; + + Config::AutoConf->check_prog("agrep"); + my $grep = Config::AutoConf->check_progs("agrep", "egrep", "grep"); + + Config::AutoConf->check_header("ncurses.h"); + my $curses = Config::AutoConf->check_headers("ncurses.h","curses.h"); + + Config::AutoConf->check_prog_awk; + Config::AutoConf->check_prog_egrep; + + Config::AutoConf->check_cc(); + + Config::AutoConf->check_lib("ncurses", "tgoto"); + + Config::AutoConf->check_file("/etc/passwd"); # -f && -r + +=head1 DESCRIPTION + +Config::AutoConf is intended to provide the same opportunities to Perl +developers as L<GNU Autoconf|http://www.gnu.org/software/autoconf/> +does for Shell developers. + +As Perl is the second most deployed language (mind: every Unix comes +with Perl, several mini-computers have Perl and even lot's of Windows +machines run Perl software - which requires deployed Perl there, too), +this gives wider support than Shell based probes. + +The API is leaned against GNU Autoconf, but we try to make the API +(especially optional arguments) more Perl'ish than m4 abilities allow +to the original. + +=head1 FUNCTIONS + +=cut + +my $glob_instance; + +=head2 new + +This function instantiates a new instance of Config::AutoConf, eg. to +configure child components. The constructor adds also values set via +environment variable C<PERL5_AUTOCONF_OPTS>. + +=cut + +sub new +{ + my $class = shift; + ref $class and $class = ref $class; + my %args = @_; + + my %flags = map { + my ( $k, $v ) = split( "=", $_, 2 ); + defined $v or $v = 1; + ( $k, $v ) + } split( ":", $ENV{PERL5_AC_OPTS} ) if ( $ENV{PERL5_AC_OPTS} ); + + my %instance = ( + msg_prefix => 'configure: ', + lang => "C", + lang_stack => [], + lang_supported => { + "C" => $class->can("check_prog_cc"), + }, + cache => {}, + defines => {}, + extra_libs => [], + extra_lib_dirs => [], + extra_include_dirs => [], + extra_preprocess_flags => [], + extra_compile_flags => { + "C" => [], + }, + extra_link_flags => [], + logfile => "config.log", + c_ac_flags => {%flags}, + %args + ); + bless( \%instance, $class ); +} + +=head2 check_file + +This function checks if a file exists in the system and is readable by +the user. Returns a boolean. You can use '-f $file && -r $file' so you +don't need to use a function call. + +=cut + +sub check_file +{ + my ( $self, $file ) = @_; + -f $file && -r $file; +} + +=head2 check_files + +This function checks if a set of files exist in the system and are +readable by the user. Returns a boolean. + +=cut + +sub check_files +{ + my $self = shift; + + for (@_) + { + return 0 unless $self->check_file($_); + } + + 1; +} + +sub _sanitize_prog +{ + my ( $self, $prog ) = @_; + ( scalar Text::ParseWords::shellwords $prog) > 1 and $prog = QUOTE . $prog . QUOTE; + $prog; +} + +my @exe_exts = ( $^O eq "MSWin32" ? qw(.exe .com .bat .cmd) : ("") ); + +=head2 check_prog( $prog, \@dirlist?, \%options? ) + +This function checks for a program with the supplied name. In success +returns the full path for the executable; + +An optional array reference containing a list of directories to be searched +instead of $PATH is gracefully honored. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. + +=cut + +sub check_prog +{ + my $self = shift; + # sanitize ac_prog + my $ac_prog = _sanitize( shift @_ ); + + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + + my @dirlist; + @_ and scalar @_ > 1 and @dirlist = @_; + @_ and scalar @_ == 1 and ref $_[0] eq "ARRAY" and @dirlist = @{ $_[0] }; + @dirlist or @dirlist = split( /$Config{path_sep}/, $ENV{PATH} ); + + for my $p (@dirlist) + { + for my $e (@exe_exts) + { + my $cmd = $self->_sanitize_prog( File::Spec->catfile( $p, $ac_prog . $e ) ); + -x $cmd + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + -x $cmd and return $cmd; + } + } + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and $options->{action_on_false}->(); + + return; +} + +=head2 check_progs(progs, [dirlist]) + +This function takes a list of program names. Returns the full path for +the first found on the system. Returns undef if none was found. + +An optional array reference containing a list of directories to be searched +instead of $PATH is gracefully honored. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. The +name of the I<$prog> to check and the found full path are passed as first +and second argument to the I<action_on_true> callback. + +=cut + +sub check_progs +{ + my $self = shift; + + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + + my @dirlist; + scalar @_ > 1 and ref $_[-1] eq "ARRAY" and @dirlist = @{ pop @_ }; + @dirlist or @dirlist = split( /$Config{path_sep}/, $ENV{PATH} ); + + my @progs = @_; + foreach my $prog (@progs) + { + defined $prog or next; + + my $ans = $self->check_prog( $prog, \@dirlist ); + $ans + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_if_true}->( $prog, $ans ); + + $ans and return $ans; + } + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and $options->{action_on_false}->(); + + return; +} + +sub _append_prog_args +{ + my ( $self, $prog ) = @_; + join( " ", $self->_sanitize_prog($prog), @_ ); +} + +=head2 check_prog_yacc + +From the autoconf documentation, + + If `bison' is found, set [...] `bison -y'. + Otherwise, if `byacc' is found, set [...] `byacc'. + Otherwise set [...] `yacc'. The result of this test can be influenced + by setting the variable YACC or the cache variable ac_cv_prog_YACC. + +Returns the full path, if found. + +=cut + +sub check_prog_yacc +{ + my $self = shift; + + # my ($self, $cache_name, $message, $check_sub) = @_; + + my $cache_name = $self->_cache_name( "prog", "YACC" ); + $self->check_cached( + $cache_name, + "for yacc", + sub { + defined $ENV{YACC} and return $ENV{YACC}; + my $binary = $self->check_progs(qw/bison byacc yacc/); + defined $binary + and $binary =~ /bison(?:\.(?:exe|com|bat|cmd))?$/ + and $binary = $self->_append_prog_args( $binary, "-y" ); + return $binary; + } + ); +} + +=head2 check_prog_awk + +From the autoconf documentation, + + Check for `gawk', `mawk', `nawk', and `awk', in that order, and + set output [...] to the first one that is found. It tries + `gawk' first because that is reported to be the best implementation. + The result can be overridden by setting the variable AWK or the + cache variable ac_cv_prog_AWK. + +Note that it returns the full path, if found. + +=cut + +sub check_prog_awk +{ + my $self = shift; + my $cache_name = $self->_cache_name( "prog", "AWK" ); + $self->check_cached( $cache_name, "for awk", sub { $ENV{AWK} || $self->check_progs(qw/gawk mawk nawk awk/) } ); +} + +=head2 check_prog_egrep + +From the autoconf documentation, + + Check for `grep -E' and `egrep', in that order, and [...] output + [...] the first one that is found. The result can be overridden by + setting the EGREP variable and is cached in the ac_cv_path_EGREP + variable. + +Note that it returns the full path, if found. + +=cut + +sub check_prog_egrep +{ + my $self = shift; + + my $cache_name = $self->_cache_name( "prog", "EGREP" ); + $self->check_cached( + $cache_name, + "for egrep", + sub { + defined $ENV{EGREP} and return $ENV{EGREP}; + my $grep; + $grep = $self->check_progs("egrep") and return $grep; + + if ( $grep = $self->check_prog("grep") ) + { + # check_run - Capture::Tiny, Open3 ... ftw! + my $ans = `echo a | ($grep -E '(a|b)') 2>/dev/null`; + chomp $ans; + $ans eq "a" and return $self->_append_prog_args( $grep, "-E" ); + } + } + ); +} + +=head2 check_prog_lex + +From the autoconf documentation, + + If flex is found, set output [...] to ‘flex’ and [...] to -lfl, if that + library is in a standard place. Otherwise set output [...] to ‘lex’ and + [...] to -ll, if found. If [...] packages [...] ship the generated + file.yy.c alongside the source file.l, this [...] allows users without a + lexer generator to still build the package even if the timestamp for + file.l is inadvertently changed. + +Note that it returns the full path, if found. + +The structure $self->{lex} is set with attributes + + prog => $LEX + lib => $LEXLIB + root => $lex_root + +=cut + +sub check_prog_lex +{ + my $self = shift->_get_instance; + my $cache_name = $self->_cache_name( "prog", "LEX" ); + my $lex = $self->check_cached( $cache_name, "for lex", sub { $ENV{LEX} || $self->check_progs(qw/flex lex/) } ); + if ($lex) + { + defined $self->{lex}->{prog} or $self->{lex}->{prog} = $lex; + my $lex_root_var = $self->check_cached( + "ac_cv_prog_lex_root", + "for lex output file root", + sub { + my ( $fh, $filename ) = tempfile( "testXXXXXX", SUFFIX => '.l' ); + my $src = <<'EOLEX'; +%% +a { ECHO; } +b { REJECT; } +c { yymore (); } +d { yyless (1); } +e { /* IRIX 6.5 flex 2.5.4 underquotes its yyless argument. */ + yyless ((input () != 0)); } +f { unput (yytext[0]); } +. { BEGIN INITIAL; } +%% +#ifdef YYTEXT_POINTER +extern char *yytext; +#endif +int +main (void) +{ + return ! yylex () + ! yywrap (); +} +EOLEX + + print {$fh} $src; + close $fh; + + my ( $stdout, $stderr, $exit ) = + capture { system( $lex, $filename ); }; + chomp $stdout; + unlink $filename; + -f "lex.yy.c" and return "lex.yy"; + -f "lexyy.c" and return "lexyy"; + $self->msg_error("cannot find output from $lex; giving up"); + } + ); + defined $self->{lex}->{root} or $self->{lex}->{root} = $lex_root_var; + + my $conftest = read_file( $lex_root_var . ".c" ); + unlink $lex_root_var . ".c"; + + $cache_name = $self->_cache_name( "lib", "lex" ); + my $check_sub = sub { + my @save_libs = @{ $self->{extra_libs} }; + my $have_lib = 0; + foreach my $libstest ( undef, qw(-lfl -ll) ) + { + # XXX would local work on array refs? can we omit @save_libs? + $self->{extra_libs} = [@save_libs]; + defined($libstest) and unshift( @{ $self->{extra_libs} }, $libstest ); + $self->link_if_else($conftest) + and ( $have_lib = defined($libstest) ? $libstest : "none required" ) + and last; + } + $self->{extra_libs} = [@save_libs]; + + if ($have_lib) + { + $self->define_var( _have_lib_define_name("lex"), $have_lib, "defined when lex library is available" ); + } + else + { + $self->define_var( _have_lib_define_name("lex"), undef, "defined when lex library is available" ); + } + return $have_lib; + }; + + my $lex_lib = $self->check_cached( $cache_name, "lex library", $check_sub ); + defined $self->{lex}->{lib} or $self->{lex}->{lib} = $lex_lib; + } + + $lex; +} + +=head2 check_prog_sed + +From the autoconf documentation, + + Set output variable [...] to a Sed implementation that conforms to Posix + and does not have arbitrary length limits. Report an error if no + acceptable Sed is found. See Limitations of Usual Tools, for more + information about portability problems with Sed. + + The result of this test can be overridden by setting the SED variable and + is cached in the ac_cv_path_SED variable. + +Note that it returns the full path, if found. + +=cut + +sub check_prog_sed +{ + my $self = shift; + my $cache_name = $self->_cache_name( "prog", "SED" ); + $self->check_cached( $cache_name, "for sed", sub { $ENV{SED} || $self->check_progs(qw/gsed sed/) } ); +} + +=head2 check_prog_pkg_config + +Checks for C<pkg-config> program. No additional tests are made for it ... + +=cut + +sub check_prog_pkg_config +{ + my $self = shift->_get_instance(); + my $cache_name = $self->_cache_name( "prog", "PKG_CONFIG" ); + $self->check_cached( $cache_name, "for pkg-config", sub { $self->check_prog("pkg-config") } ); +} + +=head2 check_prog_cc + +Determine a C compiler to use. Currently the probe is delegated to L<ExtUtils::CBuilder>. + +=cut + +sub check_prog_cc +{ + my $self = shift; + my $cache_name = $self->_cache_name( "prog", "CC" ); + + $self->check_cached( + $cache_name, + "for cc", + sub { + $self->{lang_supported}->{C} = undef; + eval "use ExtUtils::CBuilder;"; + $@ and return; + my $cb = ExtUtils::CBuilder->new( quiet => 1 ); + $cb->have_compiler or return; + $self->{lang_supported}->{C} = "ExtUtils::CBuilder"; + $cb->{config}->{cc}; + } + ); +} + +=head2 check_cc + +(Deprecated) Old name of L</check_prog_cc>. + +=cut + +sub check_cc { shift->check_prog_cc(@_) } + +=head2 check_valid_compiler + +This function checks for a valid compiler for the currently active language. +At the very moment only C<C> is understood (corresponding to your compiler +default options, e.g. -std=gnu89). + +=cut + +sub check_valid_compiler +{ + my $self = shift->_get_instance; + my $lang = $self->{lang}; + $lang eq "C" or $self->msg_error("Language $lang is not supported"); + $self->check_prog_cc; +} + +=head2 check_valid_compilers(;\@) + +Checks for valid compilers for each given language. When unspecified +defaults to C<[ "C" ]>. + +=cut + +sub check_valid_compilers +{ + my $self = shift; + for my $lang ( @{ $_[0] } ) + { + $self->push_lang($lang); + my $supp = $self->check_valid_compiler; + $self->pop_lang($lang); + $supp or return 0; + } + + 1; +} + +=head2 msg_checking + +Prints "Checking @_ ..." + +=cut + +sub msg_checking +{ + my $self = shift->_get_instance(); + $self->{quiet} + or print "Checking " . join( " ", @_ ) . "... "; + $self->_add_log_entry( "Checking " . join( " ", @_, "..." ) ); + return; +} + +=head2 msg_result + +Prints result \n + +=cut + +my @_num_to_msg = qw/no yes/; + +sub _neat +{ + defined $_[0] or return ""; + looks_like_number( $_[0] ) and defined $_num_to_msg[ $_[0] ] and return $_num_to_msg[ $_[0] ]; + $_[0]; +} + +sub msg_result +{ + my $self = shift->_get_instance(); + $self->{quiet} + or print join( " ", map { _neat $_ } @_ ), "\n"; + $self->_add_log_entry( join( " ", map { _neat $_ } @_ ), "\n" ); + return; +} + +=head2 msg_notice + +Prints "configure: " @_ to stdout + +=cut + +sub msg_notice +{ + my $self = shift->_get_instance(); + $self->{quiet} + or print $self->{msg_prefix} . join( " ", @_ ) . "\n"; + $self->_add_log_entry( $self->{msg_prefix} . join( " ", @_ ) . "\n" ); + return; +} + +=head2 msg_warn + +Prints "configure: " @_ to stderr + +=cut + +sub msg_warn +{ + my $self = shift->_get_instance(); + print STDERR $self->{msg_prefix} . join( " ", @_ ) . "\n"; + $self->_add_log_entry( "WARNING: " . $self->{msg_prefix} . join( " ", @_ ) . "\n" ); + return; +} + +=head2 msg_error + +Prints "configure: " @_ to stderr and exits with exit code 0 (tells +toolchain to stop here and report unsupported environment) + +=cut + +sub msg_error +{ + my $self = shift->_get_instance(); + print STDERR $self->{msg_prefix} . join( " ", @_ ) . "\n"; + $self->_add_log_entry( "ERROR: " . $self->{msg_prefix} . join( " ", @_ ) . "\n" ); + exit(0); # #toolchain agreement: prevents configure stage to finish +} + +=head2 msg_failure + +Prints "configure: " @_ to stderr and exits with exit code 0 (tells +toolchain to stop here and report unsupported environment). Additional +details are provides in config.log (probably more information in a +later stage). + +=cut + +sub msg_failure +{ + my $self = shift->_get_instance(); + print STDERR $self->{msg_prefix} . join( " ", @_ ) . "\n"; + $self->_add_log_entry( "FAILURE: " . $self->{msg_prefix} . join( " ", @_ ) . "\n" ); + exit(0); # #toolchain agreement: prevents configure stage to finish +} + +=head2 define_var( $name, $value [, $comment ] ) + +Defines a check variable for later use in further checks or code to compile. +Returns the value assigned value + +=cut + +sub define_var +{ + my $self = shift->_get_instance(); + my ( $name, $value, $comment ) = @_; + + defined($name) or croak("Need a name to add a define"); + $self->{defines}->{$name} = [ $value, $comment ]; + $value; +} + +=head2 write_config_h( [$target] ) + +Writes the defined constants into given target: + + Config::AutoConf->write_config_h( "config.h" ); + +=cut + +sub write_config_h +{ + my $self = shift->_get_instance(); + my $tgt; + + defined( $_[0] ) + ? ( + ref( $_[0] ) + ? $tgt = $_[0] + : open( $tgt, ">", $_[0] ) + ) + : open( $tgt, ">", "config.h" ); + + my $conf_h = <<'EOC'; +/** + * Generated from Config::AutoConf + * + * Do not edit this file, all modifications will be lost, + * modify Makefile.PL or Build.PL instead. + * + * Inspired by GNU AutoConf. + * + * (c) 2011 Alberto Simoes & Jens Rehsack + */ +#ifndef __CONFIG_H__ + +EOC + + while ( my ( $defname, $defcnt ) = each( %{ $self->{defines} } ) ) + { + if ( $defcnt->[0] ) + { + defined $defcnt->[1] and $conf_h .= "/* " . $defcnt->[1] . " */\n"; + $conf_h .= join( " ", "#define", $defname, $defcnt->[0] ) . "\n"; + } + else + { + defined $defcnt->[1] and $conf_h .= "/* " . $defcnt->[1] . " */\n"; + $conf_h .= "/* " . join( " ", "#undef", $defname ) . " */\n\n"; + } + } + $conf_h .= "#endif /* ?__CONFIG_H__ */\n"; + + print {$tgt} $conf_h; + + return; +} + +=head2 push_lang(lang [, implementor ]) + +Puts the current used language on the stack and uses specified language +for subsequent operations until ending pop_lang call. + +=cut + +sub push_lang +{ + my $self = shift->_get_instance(); + + push @{ $self->{lang_stack} }, [ $self->{lang} ]; + + $self->_set_language(@_); +} + +=head2 pop_lang([ lang ]) + +Pops the currently used language from the stack and restores previously used +language. If I<lang> specified, it's asserted that the current used language +equals to specified language (helps finding control flow bugs). + +=cut + +sub pop_lang +{ + my $self = shift->_get_instance(); + + scalar( @{ $self->{lang_stack} } ) > 0 or croak("Language stack empty"); + defined( $_[0] ) + and $self->{lang} ne $_[0] + and croak( "pop_lang( $_[0] ) doesn't match language in use (" . $self->{lang} . ")" ); + + $self->_set_language( @{ pop @{ $self->{lang_stack} } } ); +} + +=head2 lang_call( [prologue], function ) + +Builds program which simply calls given function. +When given, prologue is prepended otherwise, the default +includes are used. + +=cut + +sub lang_call +{ + my ( $self, $prologue, $function ) = @_; + ref $self or $self = $self->_get_instance(); + + defined($prologue) or $prologue = $self->_default_includes(); + $prologue .= <<"_ACEOF"; +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" { +#endif +char $function (); +#ifdef __cplusplus +} +#endif +_ACEOF + my $body = "return $function ();"; + $body = $self->_build_main($body); + + $self->_fill_defines() . "\n$prologue\n\n$body\n"; +} + +=head2 lang_build_program( prologue, body ) + +Builds program for current chosen language. If no prologue is given +(I<undef>), the default headers are used. If body is missing, default +body is used. + +Typical call of + + Config::AutoConf->lang_build_program( "const char hw[] = \"Hello, World\\n\";", + "fputs (hw, stdout);" ) + +will create + + const char hw[] = "Hello, World\n"; + + /* Override any gcc2 internal prototype to avoid an error. */ + #ifdef __cplusplus + extern "C" { + #endif + + int + main (int argc, char **argv) + { + (void)argc; + (void)argv; + fputs (hw, stdout);; + return 0; + } + + #ifdef __cplusplus + } + #endif + +=cut + +sub lang_build_program +{ + my ( $self, $prologue, $body ) = @_; + ref $self or $self = $self->_get_instance(); + + defined($prologue) or $prologue = $self->_default_includes(); + defined($body) or $body = ""; + $body = $self->_build_main($body); + + $self->_fill_defines() . "\n$prologue\n\n$body\n"; +} + +=head2 lang_build_bool_test (prologue, test, [@decls]) + +Builds a static test which will fail to compile when test +evaluates to false. If C<@decls> is given, it's prepended +before the test code at the variable definition place. + +=cut + +sub lang_build_bool_test +{ + my ( $self, $prologue, $test, @decls ) = @_; + ref $self or $self = $self->_get_instance(); + + defined($test) or $test = "1"; + my $test_code = <<ACEOF; + static int test_array [($test) ? 1 : -1 ]; + test_array [0] = 0 +ACEOF + if (@decls) + { + $test_code = join( "\n", @decls, $test_code ); + } + $self->lang_build_program( $prologue, $test_code ); +} + +=head2 push_includes + +Adds given list of directories to preprocessor/compiler +invocation. This is not proved to allow adding directories +which might be created during the build. + +=cut + +sub push_includes +{ + my ( $self, @includes ) = @_; + ref $self or $self = $self->_get_instance(); + + push( @{ $self->{extra_include_dirs} }, @includes ); + + return; +} + +=head2 push_preprocess_flags + +Adds given flags to the parameter list for preprocessor invocation. + +=cut + +sub push_preprocess_flags +{ + my ( $self, @cpp_flags ) = @_; + ref $self or $self = $self->_get_instance(); + + push( @{ $self->{extra_preprocess_flags} }, @cpp_flags ); + + return; +} + +=head2 push_compiler_flags + +Adds given flags to the parameter list for compiler invocation. + +=cut + +sub push_compiler_flags +{ + my ( $self, @compiler_flags ) = @_; + ref $self or $self = $self->_get_instance(); + my $lang = $self->{lang}; + + if ( scalar(@compiler_flags) && ( ref( $compiler_flags[-1] ) eq "HASH" ) ) + { + my $lang_opt = pop(@compiler_flags); + defined( $lang_opt->{lang} ) or croak("Missing lang attribute in language options"); + $lang = $lang_opt->{lang}; + defined( $self->{lang_supported}->{$lang} ) or croak("Unsupported language '$lang'"); + } + + push( @{ $self->{extra_compile_flags}->{$lang} }, @compiler_flags ); + + return; +} + +=head2 push_libraries + +Adds given list of libraries to the parameter list for linker invocation. + +=cut + +sub push_libraries +{ + my ( $self, @libs ) = @_; + ref $self or $self = $self->_get_instance(); + + push( @{ $self->{extra_libs} }, @libs ); + + return; +} + +=head2 push_library_paths + +Adds given list of library paths to the parameter list for linker invocation. + +=cut + +sub push_library_paths +{ + my ( $self, @libdirs ) = @_; + ref $self or $self = $self->_get_instance(); + + push( @{ $self->{extra_lib_dirs} }, @libdirs ); + + return; +} + +=head2 push_link_flags + +Adds given flags to the parameter list for linker invocation. + +=cut + +sub push_link_flags +{ + my ( $self, @link_flags ) = @_; + ref $self or $self = $self->_get_instance(); + + push( @{ $self->{extra_link_flags} }, @link_flags ); + + return; +} + +=head2 compile_if_else( $src, \%options? ) + +This function tries to compile specified code and returns a boolean value +containing check success state. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. + +=cut + +sub compile_if_else +{ + my ( $self, $src ) = @_; + ref $self or $self = $self->_get_instance(); + + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + my $builder = $self->_get_builder(); + + my ( $fh, $filename ) = tempfile( + "testXXXXXX", + SUFFIX => '.c', + , UNLINK => 0 + ); + + print {$fh} $src; + close $fh; + + my ( $obj_file, $outbuf, $errbuf, $exception ); + ( $outbuf, $errbuf ) = capture + { + eval { + $obj_file = $builder->compile( + source => $filename, + include_dirs => $self->{extra_include_dirs}, + extra_compiler_flags => $self->_get_extra_compiler_flags() + ); + }; + + $exception = $@; + }; + + unlink $filename; + unlink $obj_file if $obj_file; + + if ( $exception || !$obj_file ) + { + $self->_add_log_lines( "compile stage failed" . ( $exception ? " - " . $exception : "" ) ); + $errbuf + and $self->_add_log_lines($errbuf); + $self->_add_log_lines( "failing program is:\n" . $src ); + $outbuf + and $self->_add_log_lines( "stdout was :\n" . $outbuf ); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and $options->{action_on_false}->(); + + return 0; + } + + $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + 1; +} + +=head2 link_if_else( $src, \%options? ) + +This function tries to compile and link specified code and returns a boolean +value containing check success state. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. + +=cut + +sub link_if_else +{ + my ( $self, $src ) = @_; + ref $self or $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + my $builder = $self->_get_builder(); + + my ( $fh, $filename ) = tempfile( "testXXXXXX", SUFFIX => '.c' ); + + print {$fh} $src; + close $fh; + + my ( $obj_file, $outbuf, $errbuf, $exception ); + ( $outbuf, $errbuf ) = capture + { + eval { + $obj_file = $builder->compile( + source => $filename, + include_dirs => $self->{extra_include_dirs}, + extra_compiler_flags => $self->_get_extra_compiler_flags() + ); + }; + + $exception = $@; + }; + + if ( $exception || !$obj_file ) + { + $self->_add_log_lines( "compile stage failed" . ( $exception ? " - " . $exception : "" ) ); + $errbuf + and $self->_add_log_lines($errbuf); + $self->_add_log_lines( "failing program is:\n" . $src ); + $outbuf + and $self->_add_log_lines( "stdout was :\n" . $outbuf ); + + unlink $filename; + unlink $obj_file if $obj_file; + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and $options->{action_on_false}->(); + + return 0; + } + + my $exe_file; + ( $outbuf, $errbuf ) = capture + { + eval { + $exe_file = $builder->link_executable( + objects => $obj_file, + extra_linker_flags => $self->_get_extra_linker_flags() + ); + }; + + $exception = $@; + }; + unlink $filename; + unlink $obj_file if $obj_file; + unlink $exe_file if $exe_file; + + if ( $exception || !$exe_file ) + { + $self->_add_log_lines( "link stage failed" . ( $exception ? " - " . $exception : "" ) ); + $errbuf + and $self->_add_log_lines($errbuf); + $self->_add_log_lines( "failing program is:\n" . $src ); + $outbuf + and $self->_add_log_lines( "stdout was :\n" . $outbuf ); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and $options->{action_on_false}->(); + + return 0; + } + + $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + 1; +} + +=head2 check_cached( $cache-key, $check-title, \&check-call, \%options? ) + +Retrieves the result of a previous L</check_cached> invocation from +C<cache-key>, or (when called for the first time) populates the cache +by invoking C<\&check_call>. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed on B<every> call +to check_cached (not just the first cache-populating invocation), respectively. + +=cut + +sub check_cached +{ + my ( $self, $cache_name, $message, $check_sub ) = @_; + ref $self or $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 4 and ref $_[-1] eq "HASH" and $options = pop @_; + + $self->msg_checking($message); + + defined $ENV{$cache_name} + and not defined $self->{cache}->{$cache_name} + and $self->{cache}->{$cache_name} = $ENV{$cache_name}; + + my @cached_result; + defined( $self->{cache}->{$cache_name} ) and push @cached_result, "(cached)"; + defined( $self->{cache}->{$cache_name} ) or $self->{cache}->{$cache_name} = $check_sub->(); + + $self->msg_result( @cached_result, $self->{cache}->{$cache_name} ); + + $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $self->{cache}->{$cache_name} + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$self->{cache}->{$cache_name} + and $options->{action_on_false}->(); + + $self->{cache}->{$cache_name}; +} + +=head2 cache_val + +This function returns the value of a previously check_cached call. + +=cut + +sub cache_val +{ + my ( $self, $cache_name ) = @_; + ref $self or $self = $self->_get_instance(); + defined $self->{cache}->{$cache_name} or return; + $self->{cache}->{$cache_name}; +} + +=head2 check_decl( $symbol, \%options? ) + +This method actually tests whether symbol is defined as a macro or can be +used as an r-value, not whether it is really declared, because it is much +safer to avoid introducing extra declarations when they are not needed. +In order to facilitate use of C++ and overloaded function declarations, it +is possible to specify function argument types in parentheses for types +which can be zero-initialized: + + Config::AutoConf->check_decl("basename(char *)") + +This method caches its result in the C<ac_cv_decl_E<lt>set langE<gt>>_symbol +variable. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub check_decl +{ + my ( $self, $symbol ) = @_; + $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + defined($symbol) or return croak("No symbol to check for"); + ref($symbol) eq "" or return croak("No symbol to check for"); + ( my $sym_plain = $symbol ) =~ s/ *\(.*//; + my $sym_call = $symbol; + $sym_call =~ s/\(/((/; + $sym_call =~ s/\)/) 0)/; + $sym_call =~ s/,/) 0, (/g; + + my $cache_name = $self->_cache_name( "decl", $self->{lang}, $symbol ); + my $check_sub = sub { + + my $body = <<ACEOF; +#ifndef $sym_plain + (void) $sym_call; +#endif +ACEOF + my $conftest = $self->lang_build_program( $options->{prologue}, $body ); + + my $have_decl = $self->compile_if_else( + $conftest, + { + ( $options->{action_on_true} ? ( action_on_true => $options->{action_on_true} ) : () ), + ( $options->{action_on_false} ? ( action_on_false => $options->{action_on_false} ) : () ) + } + ); + + $have_decl; + }; + + $self->check_cached( + $cache_name, + "whether $symbol is declared", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_decls( symbols, \%options? ) + +For each of the symbols (with optional function argument types for C++ +overloads), run L<check_decl>. + +Contrary to GNU autoconf, this method does not declare HAVE_DECL_symbol +macros for the resulting C<confdefs.h>, because it differs as C<check_decl> +between compiling languages. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. +Given callbacks for I<action_on_symbol_true> or I<action_on_symbol_false> are +called for each symbol checked using L</check_decl> receiving the symbol as +first argument. + +=cut + +sub check_decls +{ + my ( $self, $symbols ) = @_; + $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + my $have_syms = 1; + foreach my $symbol (@$symbols) + { + $have_syms &= $self->check_decl( + $symbol, + { + %pass_options, + ( + $options->{action_on_symbol_true} && "CODE" eq ref $options->{action_on_symbol_true} + ? ( action_on_true => sub { $options->{action_on_symbol_true}->($symbol) } ) + : () + ), + ( + $options->{action_on_symbol_false} && "CODE" eq ref $options->{action_on_symbol_false} + ? ( action_on_false => sub { $options->{action_on_symbol_false}->($symbol) } ) + : () + ), + } + ); + } + + $have_syms + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_syms + and $options->{action_on_false}->(); + + $have_syms; +} + +sub _have_func_define_name +{ + my $func = $_[0]; + my $have_name = "HAVE_" . uc($func); + $have_name =~ tr/_A-Za-z0-9/_/c; + $have_name; +} + +=head2 check_func( $function, \%options? ) + +This method actually tests whether I<$funcion> can be linked into a program +trying to call I<$function>. This method caches its result in the +ac_cv_func_FUNCTION variable. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +If any of I<action_on_cache_true>, I<action_on_cache_false> is defined, +both callbacks are passed to L</check_cached> as I<action_on_true> or +I<action_on_false> to C<check_cached>, respectively. + +Returns: True if the function was found, false otherwise + +=cut + +sub check_func +{ + my ( $self, $function ) = @_; + $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + # Build the name of the cache variable. + my $cache_name = $self->_cache_name( 'func', $function ); + # Wrap the actual check in a closure so that we can use check_cached. + my $check_sub = sub { + my $have_func = $self->link_if_else( + $self->lang_call( q{}, $function ), + { + ( $options->{action_on_true} ? ( action_on_true => $options->{action_on_true} ) : () ), + ( $options->{action_on_false} ? ( action_on_false => $options->{action_on_false} ) : () ) + } + ); + $have_func; + }; + + # Run the check and cache the results. + return $self->check_cached( + $cache_name, + "for $function", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_funcs( \@functions-list, $action-if-true?, $action-if-false? ) + +The same as check_func, but takes a list of functions in I<\@functions-list> +to look for and checks for each in turn. Define HAVE_FUNCTION for each +function that was found. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +If any of I<action_on_cache_true>, I<action_on_cache_false> is defined, +both callbacks are passed to L</check_cached> as I<action_on_true> or +I<action_on_false> to C<check_cached>, respectively. Given callbacks +for I<action_on_function_true> or I<action_on_function_false> are called for +each symbol checked using L</check_func> receiving the symbol as first +argument. + +=cut + +sub check_funcs +{ + my ( $self, $functions_ref ) = @_; + $self = $self->_get_instance(); + + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + my %pass_options; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + # Go through the list of functions and call check_func for each one. We + # generate new closures for the found and not-found functions that pass in + # the relevant function name. + my $have_funcs = 1; + for my $function ( @{$functions_ref} ) + { + + # Build the code reference to run when a function was found. This defines + # a HAVE_FUNCTION symbol, plus runs the current $action-if-true if there is + # one. + $pass_options{action_on_true} = sub { + # XXX think about doing this always (move to check_func) + $self->define_var( _have_func_define_name($function), 1, "Defined when $function is available" ); + + # Run the user-provided hook, if there is one. + defined $options->{action_on_function_true} + and ref $options->{action_on_function_true} eq "CODE" + and $options->{action_on_function_true}->($function); + }; + + defined $options->{action_on_function_false} + and ref $options->{action_on_function_false} eq "CODE" + and $pass_options{action_on_false} = sub { $options->{action_on_function_false}->($function); }; + + $have_funcs &= check_func( $self, $function, \%pass_options ); + } + + $have_funcs + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_funcs + and $options->{action_on_false}->(); + + return $have_funcs; +} + +sub _have_type_define_name +{ + my $type = $_[0]; + my $have_name = "HAVE_" . uc($type); + $have_name =~ tr/*/P/; + $have_name =~ tr/_A-Za-z0-9/_/c; + $have_name; +} + +=head2 check_type( $symbol, \%options? ) + +Check whether type is defined. It may be a compiler builtin type or defined +by the includes. In C, type must be a type-name, so that the expression +C<sizeof (type)> is valid (but C<sizeof ((type))> is not). + +If I<type> type is defined, preprocessor macro HAVE_I<type> (in all +capitals, with "*" replaced by "P" and spaces and dots replaced by +underscores) is defined. + +This method caches its result in the C<ac_cv_type_>type variable. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub check_type +{ + my ( $self, $type ) = @_; + $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + defined($type) or return croak("No type to check for"); + ref($type) eq "" or return croak("No type to check for"); + + my $cache_name = $self->_cache_type_name( "type", $type ); + my $check_sub = sub { + + my $body = <<ACEOF; + if( sizeof ($type) ) + return 0; +ACEOF + my $conftest = $self->lang_build_program( $options->{prologue}, $body ); + + my $have_type = $self->compile_if_else( + $conftest, + { + ( $options->{action_on_true} ? ( action_on_true => $options->{action_on_true} ) : () ), + ( $options->{action_on_false} ? ( action_on_false => $options->{action_on_false} ) : () ) + } + ); + $self->define_var( _have_type_define_name($type), $have_type ? $have_type : undef, "defined when $type is available" ); + $have_type; + }; + + $self->check_cached( + $cache_name, + "for $type", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_types( \@type-list, \%options? ) + +For each type in I<@type-list>, call L<check_type> is called to check +for type and return the accumulated result (accumulation op is binary and). + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. +Given callbacks for I<action_on_type_true> or I<action_on_type_false> are +called for each symbol checked using L</check_type> receiving the symbol as +first argument. + +=cut + +sub check_types +{ + my ( $self, $types ) = @_; + $self = $self->_get_instance(); + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + my $have_types = 1; + foreach my $type (@$types) + { + $have_types &= $self->check_type( + $type, + { + %pass_options, + ( + $options->{action_on_type_true} && "CODE" eq ref $options->{action_on_type_true} + ? ( action_on_true => sub { $options->{action_on_type_true}->($type) } ) + : () + ), + ( + $options->{action_on_type_false} && "CODE" eq ref $options->{action_on_type_false} + ? ( action_on_false => sub { $options->{action_on_type_false}->($type) } ) + : () + ), + } + ); + } + + $have_types + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_types + and $options->{action_on_false}->(); + + $have_types; +} + +sub _compute_int_compile +{ + my ( $self, $expr, $prologue, @decls ) = @_; + $self = $self->_get_instance(); + + my ( $body, $conftest, $compile_result ); + + my ( $low, $mid, $high ) = ( 0, 0, 0 ); + if ( $self->compile_if_else( $self->lang_build_bool_test( $prologue, "((long int)($expr)) >= 0", @decls ) ) ) + { + $low = $mid = 0; + while (1) + { + if ( $self->compile_if_else( $self->lang_build_bool_test( $prologue, "((long int)($expr)) <= $mid", @decls ) ) ) + { + $high = $mid; + last; + } + $low = $mid + 1; + # avoid overflow + if ( $low <= $mid ) + { + $low = 0; + last; + } + $mid = $low * 2; + } + } + elsif ( $self->compile_if_else( $self->lang_build_bool_test( $prologue, "((long int)($expr)) < 0", @decls ) ) ) + { + $high = $mid = -1; + while (1) + { + if ( $self->compile_if_else( $self->lang_build_bool_test( $prologue, "((long int)($expr)) >= $mid", @decls ) ) ) + { + $low = $mid; + last; + } + $high = $mid - 1; + # avoid overflow + if ( $mid < $high ) + { + $high = 0; + last; + } + $mid = $high * 2; + } + } + + # perform binary search between $low and $high + while ( $low <= $high ) + { + $mid = int( ( $high - $low ) / 2 + $low ); + if ( $self->compile_if_else( $self->lang_build_bool_test( $prologue, "((long int)($expr)) < $mid", @decls ) ) ) + { + $high = $mid - 1; + } + elsif ( $self->compile_if_else( $self->lang_build_bool_test( $prologue, "((long int)($expr)) > $mid", @decls ) ) ) + { + $low = $mid + 1; + } + else + { + return $mid; + } + } + + return; +} + +=head2 compute_int( $expression, @decls?, \%options ) + +Returns the value of the integer I<expression>. The value should fit in an +initializer in a C variable of type signed long. It should be possible +to evaluate the expression at compile-time. If no includes are specified, +the default includes are used. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub compute_int +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $expr, @decls ) = @_; + $self = $self->_get_instance(); + + my $cache_name = $self->_cache_type_name( "compute_int", $self->{lang}, $expr ); + my $check_sub = sub { + my $val = $self->_compute_int_compile( $expr, $options->{prologue}, @decls ); + + defined $val + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !defined $val + and $options->{action_on_false}->(); + + $val; + }; + + $self->check_cached( + $cache_name, + "for compute result of ($expr)", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +sub _sizeof_type_define_name +{ + my $type = $_[0]; + my $have_name = "SIZEOF_" . uc($type); + $have_name =~ tr/*/P/; + $have_name =~ tr/_A-Za-z0-9/_/c; + $have_name; +} + +=head2 check_sizeof_type( $type, \%options? ) + +Checks for the size of the specified type by compiling and define +C<SIZEOF_type> using the determined size. + +In opposition to GNU AutoConf, this method can determine size of structure +members, eg. + + $ac->check_sizeof_type( "SV.sv_refcnt", { prologue => $include_perl } ); + # or + $ac->check_sizeof_type( "struct utmpx.ut_id", { prologue => "#include <utmpx.h>" } ); + +This method caches its result in the C<ac_cv_sizeof_E<lt>set langE<gt>>_type variable. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub check_sizeof_type +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $type ) = @_; + $self = $self->_get_instance(); + defined($type) or return croak("No type to check for"); + ref($type) eq "" or return croak("No type to check for"); + + my $cache_name = $self->_cache_type_name( "sizeof", $self->{lang}, $type ); + my $check_sub = sub { + my @decls; + if ( $type =~ m/^([^.]+)\.([^.]+)$/ ) + { + my $struct = $1; + $type = "_ac_test_aggr.$2"; + my $decl = "static $struct _ac_test_aggr;"; + push( @decls, $decl ); + } + + my $typesize = $self->_compute_int_compile( "sizeof($type)", $options->{prologue}, @decls ); + $self->define_var( + _sizeof_type_define_name($type), + $typesize ? $typesize : undef, + "defined when sizeof($type) is available" + ); + + $typesize + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$typesize + and $options->{action_on_false}->(); + + $typesize; + }; + + $self->check_cached( + $cache_name, + "for size of $type", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_sizeof_types( type, \%options? ) + +For each type L<check_sizeof_type> is called to check for size of type. + +If I<action-if-found> is given, it is additionally executed when all of the +sizes of the types could determined. If I<action-if-not-found> is given, it +is executed when one size of the types could not determined. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. +Given callbacks for I<action_on_size_true> or I<action_on_size_false> are +called for each symbol checked using L</check_sizeof_type> receiving the +symbol as first argument. + +=cut + +sub check_sizeof_types +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $types ) = @_; + $self = $self->_get_instance(); + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + my $have_sizes = 1; + foreach my $type (@$types) + { + $have_sizes &= !!( + $self->check_sizeof_type( + $type, + { + %pass_options, + ( + $options->{action_on_size_true} && "CODE" eq ref $options->{action_on_size_true} + ? ( action_on_true => sub { $options->{action_on_size_true}->($type) } ) + : () + ), + ( + $options->{action_on_size_false} && "CODE" eq ref $options->{action_on_size_false} + ? ( action_on_false => sub { $options->{action_on_size_false}->($type) } ) + : () + ), + } + ) + ); + } + + $have_sizes + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_sizes + and $options->{action_on_false}->(); + + $have_sizes; +} + +sub _alignof_type_define_name +{ + my $type = $_[0]; + my $have_name = "ALIGNOF_" . uc($type); + $have_name =~ tr/*/P/; + $have_name =~ tr/_A-Za-z0-9/_/c; + $have_name; +} + +=head2 check_alignof_type( type, \%options? ) + +Define ALIGNOF_type to be the alignment in bytes of type. I<type> must +be valid as a structure member declaration or I<type> must be a structure +member itself. + +This method caches its result in the C<ac_cv_alignof_E<lt>set langE<gt>>_type +variable, with I<*> mapped to C<p> and other characters not suitable for a +variable name mapped to underscores. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub check_alignof_type +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $type ) = @_; + $self = $self->_get_instance(); + defined($type) or return croak("No type to check for"); + ref($type) eq "" or return croak("No type to check for"); + + my $cache_name = $self->_cache_type_name( "alignof", $self->{lang}, $type ); + my $check_sub = sub { + my @decls = ( + "#ifndef offsetof", + "# ifdef __ICC", + "# define offsetof(type,memb) ((size_t)(((char *)(&((type*)0)->memb)) - ((char *)0)))", + "# else", "# define offsetof(type,memb) ((size_t)&((type*)0)->memb)", + "# endif", "#endif" + ); + + my ( $struct, $memb ); + if ( $type =~ m/^([^.]+)\.([^.]+)$/ ) + { + $struct = $1; + $memb = $2; + } + else + { + push( @decls, "typedef struct { char x; $type y; } ac__type_alignof_;" ); + $struct = "ac__type_alignof_"; + $memb = "y"; + } + + my $typealign = $self->_compute_int_compile( "offsetof($struct, $memb)", $options->{prologue}, @decls ); + $self->define_var( + _alignof_type_define_name($type), + $typealign ? $typealign : undef, + "defined when alignof($type) is available" + ); + + $typealign + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$typealign + and $options->{action_on_false}->(); + + $typealign; + }; + + $self->check_cached( + $cache_name, + "for align of $type", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_alignof_types (type, [action-if-found], [action-if-not-found], [prologue = default includes]) + +For each type L<check_alignof_type> is called to check for align of type. + +If I<action-if-found> is given, it is additionally executed when all of the +aligns of the types could determined. If I<action-if-not-found> is given, it +is executed when one align of the types could not determined. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. +Given callbacks for I<action_on_align_true> or I<action_on_align_false> are +called for each symbol checked using L</check_alignof_type> receiving the +symbol as first argument. + +=cut + +sub check_alignof_types +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $types ) = @_; + $self = $self->_get_instance(); + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + my $have_aligns = 1; + foreach my $type (@$types) + { + $have_aligns &= !!( + $self->check_alignof_type( + $type, + { + %pass_options, + ( + $options->{action_on_align_true} && "CODE" eq ref $options->{action_on_align_true} + ? ( action_on_true => sub { $options->{action_on_align_true}->($type) } ) + : () + ), + ( + $options->{action_on_align_false} && "CODE" eq ref $options->{action_on_align_false} + ? ( action_on_false => sub { $options->{action_on_align_false}->($type) } ) + : () + ), + } + ) + ); + } + + $have_aligns + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_aligns + and $options->{action_on_false}->(); + + $have_aligns; +} + +sub _have_member_define_name +{ + my $member = $_[0]; + my $have_name = "HAVE_" . uc($member); + $have_name =~ tr/_A-Za-z0-9/_/c; + $have_name; +} + +=head2 check_member( member, \%options? ) + +Check whether I<member> is in form of I<aggregate>.I<member> and +I<member> is a member of the I<aggregate> aggregate. + +which are used prior to the aggregate under test. + + Config::AutoConf->check_member( + "struct STRUCT_SV.sv_refcnt", + { + action_on_false => sub { Config::AutoConf->msg_failure( "sv_refcnt member required for struct STRUCT_SV" ); }, + prologue => "#include <EXTERN.h>\n#include <perl.h>" + } + ); + +This function will return a true value (1) if the member is found. + +If I<aggregate> aggregate has I<member> member, preprocessor +macro HAVE_I<aggregate>_I<MEMBER> (in all capitals, with spaces +and dots replaced by underscores) is defined. + +This macro caches its result in the C<ac_cv_>aggr_member variable. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub check_member +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $member ) = @_; + $self = $self->_get_instance(); + defined($member) or return croak("No type to check for"); + ref($member) eq "" or return croak("No type to check for"); + + $member =~ m/^([^.]+)\.([^.]+)$/ or return croak("check_member(\"struct foo.member\", \%options)"); + my $type = $1; + $member = $2; + + my $cache_name = $self->_cache_type_name( "$type.$member" ); + my $check_sub = sub { + + my $body = <<ACEOF; + static $type check_aggr; + if( check_aggr.$member ) + return 0; +ACEOF + my $conftest = $self->lang_build_program( $options->{prologue}, $body ); + + my $have_member = $self->compile_if_else( + $conftest, + { + ( $options->{action_on_true} ? ( action_on_true => $options->{action_on_true} ) : () ), + ( $options->{action_on_false} ? ( action_on_false => $options->{action_on_false} ) : () ) + } + ); + $self->define_var( + _have_member_define_name("$type.$member"), + $have_member ? $have_member : undef, + "defined when $type.$member is available" + ); + $have_member; + }; + + $self->check_cached( + $cache_name, + "for $type.$member", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_members( members, \%options? ) + +For each member L<check_member> is called to check for member of aggregate. + +This function will return a true value (1) if at least one member is found. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be favoured +over C<default includes> (represented by L</_default_includes>). If any of +I<action_on_cache_true>, I<action_on_cache_false> is defined, both callbacks +are passed to L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. +Given callbacks for I<action_on_member_true> or I<action_on_member_false> are +called for each symbol checked using L</check_member> receiving the symbol as +first argument. + +=cut + +sub check_members +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $members ) = @_; + $self = $self->_get_instance(); + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + my $have_members = 0; + foreach my $member (@$members) + { + $have_members |= ( + $self->check_member( + $member, + { + %pass_options, + ( + $options->{action_on_member_true} && "CODE" eq ref $options->{action_on_member_true} + ? ( action_on_true => sub { $options->{action_on_member_true}->($member) } ) + : () + ), + ( + $options->{action_on_member_false} && "CODE" eq ref $options->{action_on_member_false} + ? ( action_on_false => sub { $options->{action_on_member_false}->($member) } ) + : () + ), + } + ) + ); + } + + $have_members + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_members + and $options->{action_on_false}->(); + + $have_members; +} + +sub _have_header_define_name +{ + my $header = $_[0]; + my $have_name = "HAVE_" . uc($header); + $have_name =~ tr/_A-Za-z0-9/_/c; + return $have_name; +} + +sub _check_header +{ + my $options = {}; + scalar @_ > 4 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $header, $prologue, $body ) = @_; + + $prologue .= <<"_ACEOF"; + #include <$header> +_ACEOF + my $conftest = $self->lang_build_program( $prologue, $body ); + + $self->compile_if_else( $conftest, $options ); +} + +=head2 check_header( $header, \%options? ) + +This function is used to check if a specific header file is present in +the system: if we detect it and if we can compile anything with that +header included. Note that normally you want to check for a header +first, and then check for the corresponding library (not all at once). + +The standard usage for this module is: + + Config::AutoConf->check_header("ncurses.h"); + +This function will return a true value (1) on success, and a false value +if the header is not present or not available for common usage. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +When a I<prologue> exists in the optional hash at end, it will be prepended +to the tested header. If any of I<action_on_cache_true>, +I<action_on_cache_false> is defined, both callbacks are passed to +L</check_cached> as I<action_on_true> or I<action_on_false> to +C<check_cached>, respectively. + +=cut + +sub check_header +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $header ) = @_; + $self = $self->_get_instance(); + defined($header) or return croak("No type to check for"); + ref($header) eq "" or return croak("No type to check for"); + + return 0 unless $header; + my $cache_name = $self->_cache_name($header); + my $check_sub = sub { + my $prologue = defined $options->{prologue} ? $options->{prologue} : ""; + + my $have_header = $self->_check_header( + $header, + $prologue, + "", + { + ( $options->{action_on_true} ? ( action_on_true => $options->{action_on_true} ) : () ), + ( $options->{action_on_false} ? ( action_on_false => $options->{action_on_false} ) : () ) + } + ); + $self->define_var( + _have_header_define_name($header), + $have_header ? $have_header : undef, + "defined when $header is available" + ); + + $have_header; + }; + + $self->check_cached( + $cache_name, + "for $header", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 check_headers + +This function uses check_header to check if a set of include files exist +in the system and can be included and compiled by the available compiler. +Returns the name of the first header file found. + +Passes an optional \%options hash to each L</check_header> call. + +=cut + +sub check_headers +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + $self->check_header( $_, $options ) and return $_ for (@_); + return; +} + +=head2 check_all_headers + +This function checks each given header for usability and returns true +when each header can be used -- otherwise false. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +Each of existing key/value pairs using I<prologue>, I<action_on_cache_true> +or I<action_on_cache_false> as key are passed-through to each call of +L</check_header>. +Given callbacks for I<action_on_header_true> or I<action_on_header_false> are +called for each symbol checked using L</check_header> receiving the symbol as +first argument. + +=cut + +sub check_all_headers +{ + my $options = {}; + scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + @_ or return; + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + + my $all_headers = 1; + foreach my $header (@_) + { + $all_headers &= $self->check_header( + $header, + { + %pass_options, + ( + $options->{action_on_header_true} && "CODE" eq ref $options->{action_on_header_true} + ? ( action_on_true => sub { $options->{action_on_header_true}->($header) } ) + : () + ), + ( + $options->{action_on_header_false} && "CODE" eq ref $options->{action_on_header_false} + ? ( action_on_false => sub { $options->{action_on_header_false}->($header) } ) + : () + ), + } + ); + } + + $all_headers + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$all_headers + and $options->{action_on_false}->(); + + $all_headers; +} + +=head2 check_stdc_headers + +Checks for standard C89 headers, namely stdlib.h, stdarg.h, string.h and float.h. +If those are found, additional all remaining C89 headers are checked: assert.h, +ctype.h, errno.h, limits.h, locale.h, math.h, setjmp.h, signal.h, stddef.h, +stdio.h and time.h. + +Returns a false value if it fails. + +Passes an optional \%options hash to each L</check_all_headers> call. + +=cut + +my @ansi_c_headers = qw(stdlib stdarg string float assert ctype errno limits locale math setjmp signal stddef stdio time); + +sub check_stdc_headers +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + + # XXX for C++ the map should look like "c${_}" ... + my @c_ansi_c_headers = map { "${_}.h" } @ansi_c_headers; + my $rc = $self->check_all_headers( @c_ansi_c_headers, $options ); + $rc and $self->define_var( "STDC_HEADERS", 1, "Define to 1 if you have the ANSI C header files." ); + $rc; +} + +=head2 check_default_headers + +This function checks for some default headers, the std c89 headers and +sys/types.h, sys/stat.h, memory.h, strings.h, inttypes.h, stdint.h and unistd.h + +Passes an optional \%options hash to each L</check_all_headers> call. + +=cut + +sub check_default_headers +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + $self->check_stdc_headers($options) + and $self->check_all_headers( qw(sys/types.h sys/stat.h memory.h strings.h inttypes.h stdint.h unistd.h), $options ); +} + +=head2 check_dirent_header + +Check for the following header files. For the first one that is found and +defines 'DIR', define the listed C preprocessor macro: + + dirent.h HAVE_DIRENT_H + sys/ndir.h HAVE_SYS_NDIR_H + sys/dir.h HAVE_SYS_DIR_H + ndir.h HAVE_NDIR_H + +The directory-library declarations in your source code should look +something like the following: + + #include <sys/types.h> + #ifdef HAVE_DIRENT_H + # include <dirent.h> + # define NAMLEN(dirent) strlen ((dirent)->d_name) + #else + # define dirent direct + # define NAMLEN(dirent) ((dirent)->d_namlen) + # ifdef HAVE_SYS_NDIR_H + # include <sys/ndir.h> + # endif + # ifdef HAVE_SYS_DIR_H + # include <sys/dir.h> + # endif + # ifdef HAVE_NDIR_H + # include <ndir.h> + # endif + #endif + +Using the above declarations, the program would declare variables to be of +type C<struct dirent>, not C<struct direct>, and would access the length +of a directory entry name by passing a pointer to a C<struct dirent> to +the C<NAMLEN> macro. + +This method might be obsolescent, as all current systems with directory +libraries have C<<E<lt>dirent.hE<gt>>>. Programs supporting only newer OS +might not need to use this method. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +Each of existing key/value pairs using I<prologue>, I<action_on_header_true> +(as I<action_on_true> having the name of the tested header as first argument) +or I<action_on_header_false> (as I<action_on_false> having the name of the +tested header as first argument) as key are passed-through to each call of +L</_check_header>. +Given callbacks for I<action_on_cache_true> or I<action_on_cache_false> are +passed to the call of L</check_cached>. + +=cut + +sub check_dirent_header +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + + my %pass_options; + defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; + + my $cache_name = $self->_cache_name("header_dirent"); + my $check_sub = sub { + my $have_dirent; + foreach my $header (qw(dirent.h sys/ndir.h sys/dir.h ndir.h)) + { + $have_dirent = $self->_check_header( + $header, + "#include <sys/types.h>\n", + "if ((DIR *) 0) { return 0; }", + { + %pass_options, + ( + $options->{action_on_header_true} && "CODE" eq ref $options->{action_on_header_true} + ? ( action_on_true => sub { $options->{action_on_header_true}->($header) } ) + : () + ), + ( + $options->{action_on_header_false} && "CODE" eq ref $options->{action_on_header_false} + ? ( action_on_false => sub { $options->{action_on_header_false}->($header) } ) + : () + ), + } + ); + $self->define_var( + _have_header_define_name($header), + $have_dirent ? $have_dirent : undef, + "defined when $header is available" + ); + $have_dirent and $have_dirent = $header and last; + } + + $have_dirent + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_dirent + and $options->{action_on_false}->(); + + $have_dirent; + }; + + my $dirent_header = $self->check_cached( + $cache_name, + "for header defining DIR *", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on__true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on__false => $options->{action_on_cache_false} ) : () ), + } + ); + + $dirent_header; +} + +=head2 _check_perlapi_program + +This method provides the program source which is suitable to do basic +compile/link tests to prove perl development environment. + +=cut + +sub _check_perlapi_program +{ + my $self = shift; + + my $includes = $self->_default_includes_with_perl(); + my $perl_check_body = <<'EOB'; + I32 rc; + SV *foo = newSVpv("Perl rocks", 11); + rc = SvCUR(foo); +EOB + $self->lang_build_program( $includes, $perl_check_body ); +} + +=head2 _check_compile_perlapi + +This method can be used from other checks to prove whether we have a perl +development environment or not (perl.h, reasonable basic checks - types, etc.) + +=cut + +sub _check_compile_perlapi +{ + my $self = shift; + + my $conftest = $self->_check_perlapi_program(); + $self->compile_if_else($conftest); +} + +=head2 check_compile_perlapi + +This method can be used from other checks to prove whether we have a perl +development environment or not (perl.h, reasonable basic checks - types, etc.) + +=cut + +sub check_compile_perlapi +{ + my $self = shift->_get_instance; + my $cache_name = $self->_cache_name(qw(compile perlapi)); + + $self->check_cached( $cache_name, "whether perlapi is accessible", sub { $self->_check_compile_perlapi } ); +} + +=head2 check_compile_perlapi_or_die + +Dies when not being able to compile using the Perl API + +=cut + +sub check_compile_perlapi_or_die +{ + my $self = shift; + $self->check_compile_perlapi(@_) or $self->msg_error("Cannot use Perl API - giving up"); +} + +=head2 check_linkable_xs_so + +Checks whether a dynamic loadable object containing an XS module can be +linked or not. Due the nature of the beast, this test currently always +succeed. + +=cut + +sub check_linkable_xs_so { 1 } + +=head2 check_linkable_xs_so_or_die + +Dies when L</check_linkable_xs_so> fails. + +=cut + +sub check_linkable_xs_so_or_die +{ + my $self = shift; + $self->check_linkable_xs_so(@_) or $self->msg_error("Cannot link XS dynamic loadable - giving up"); +} + +=head2 check_loadable_xs_so + +Checks whether a dynamic loadable object containing an XS module can be +loaded or not. Due the nature of the beast, this test currently always +succeed. + +=cut + +sub check_loadable_xs_so { 1 } + +=head2 check_loadable_xs_so_or_die + +Dies when L</check_loadable_xs_so> fails. + +=cut + +sub check_loadable_xs_so_or_die +{ + my $self = shift; + $self->check_loadable_xs_so(@_) or $self->msg_error("Cannot load XS dynamic loadable - giving up"); +} + +=head2 _check_link_perlapi + +This method can be used from other checks to prove whether we have a perl +development environment including a suitable libperl or not (perl.h, +reasonable basic checks - types, etc.) + +Caller must ensure that the linker flags are set appropriate (C<-lperl> +or similar). + +=cut + +sub _check_link_perlapi +{ + my $self = shift; + + my $conftest = $self->_check_perlapi_program(); + my @save_libs = @{ $self->{extra_libs} }; + my @save_extra_link_flags = @{ $self->{extra_link_flags} }; + + my $libperl = $Config{libperl}; + $libperl =~ s/^lib//; + $libperl =~ s/\.[^\.]*$//; + + push @{ $self->{extra_link_flags} }, "-L" . File::Spec->catdir( $Config{installarchlib}, "CORE" ); + push @{ $self->{extra_libs} }, "$libperl"; + if ( $Config{perllibs} ) + { + foreach my $perllib ( split( " ", $Config{perllibs} ) ) + { + $perllib =~ m/^\-l(\w+)$/ and push @{ $self->{extra_libs} }, "$1" and next; + push @{ $self->{extra_link_flags} }, $perllib; + } + } + + my $have_libperl = $self->link_if_else($conftest); + + $have_libperl or $self->{extra_libs} = [@save_libs]; + $have_libperl or $self->{extra_link_flags} = [@save_extra_link_flags]; + + $have_libperl; +} + +=head2 check_link_perlapi + +This method can be used from other checks to prove whether we have a perl +development environment or not (perl.h, libperl.la, reasonable basic +checks - types, etc.) + +=cut + +sub check_link_perlapi +{ + my $self = shift->_get_instance; + my $cache_name = $self->_cache_name(qw(link perlapi)); + + $self->check_cached( $cache_name, "whether perlapi is linkable", sub { $self->_check_link_perlapi } ); +} + +sub _have_lib_define_name +{ + my $lib = $_[0]; + my $have_name = "HAVE_LIB" . uc($lib); + $have_name =~ tr/_A-Za-z0-9/_/c; + return $have_name; +} + +=head2 check_lib( lib, func, @other-libs?, \%options? ) + +This function is used to check if a specific library includes some +function. Call it with the library name (without the lib portion), and +the name of the function you want to test: + + Config::AutoConf->check_lib("z", "gzopen"); + +It returns 1 if the function exist, 0 otherwise. + +In case of function found, the HAVE_LIBlibrary (all in capitals) +preprocessor macro is defined with 1 and $lib together with @other_libs +are added to the list of libraries to link with. + +If linking with library results in unresolved symbols that would be +resolved by linking with additional libraries, give those libraries +as the I<other-libs> argument: e.g., C<[qw(Xt X11)]>. +Otherwise, this routine may fail to detect that library is present, +because linking the test program can fail with unresolved symbols. +The other-libraries argument should be limited to cases where it is +desirable to test for one library in the presence of another that +is not already in LIBS. + +This method caches its result in the C<ac_cv_lib_>lib_func variable. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +If any of I<action_on_cache_true>, I<action_on_cache_false> is defined, +both callbacks are passed to L</check_cached> as I<action_on_true> or +I<action_on_false> to C<check_cached>, respectively. + +It's recommended to use L<search_libs> instead of check_lib these days. + +=cut + +sub check_lib +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + my ( $lib, $func, @other_libs ) = @_; + + return 0 unless $lib and $func; + + scalar(@other_libs) == 1 + and ref( $other_libs[0] ) eq "ARRAY" + and @other_libs = @{ $other_libs[0] }; + + my $cache_name = $self->_cache_name( "lib", $lib, $func ); + my $check_sub = sub { + my $conftest = $self->lang_call( "", $func ); + + my @save_libs = @{ $self->{extra_libs} }; + push( @{ $self->{extra_libs} }, $lib, @other_libs ); + my $have_lib = $self->link_if_else( + $conftest, + { + ( $options->{action_on_true} ? ( action_on_true => $options->{action_on_true} ) : () ), + ( $options->{action_on_false} ? ( action_on_false => $options->{action_on_false} ) : () ) + } + ); + $self->{extra_libs} = [@save_libs]; + + $have_lib + and $self->define_var( _have_lib_define_name($lib), $have_lib, "defined when library $lib is available" ) + and push( @{ $self->{extra_libs} }, $lib, @other_libs ); + $have_lib + or $self->define_var( _have_lib_define_name($lib), undef, "defined when library $lib is available" ); + $have_lib; + }; + + $self->check_cached( + $cache_name, + "for $func in -l$lib", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 search_libs( function, search-libs, @other-libs?, \%options? ) + +Search for a library defining function if it's not already available. +This equates to calling + + Config::AutoConf->link_if_else( + Config::AutoConf->lang_call( "", "$function" ) ); + +first with no libraries, then for each library listed in search-libs. +I<search-libs> must be specified as an array reference to avoid +confusion in argument order. + +Prepend -llibrary to LIBS for the first library found to contain function. + +If linking with library results in unresolved symbols that would be +resolved by linking with additional libraries, give those libraries as +the I<other-libraries> argument: e.g., C<[qw(Xt X11)]>. Otherwise, this +method fails to detect that function is present, because linking the +test program always fails with unresolved symbols. + +The result of this test is cached in the ac_cv_search_function variable +as "none required" if function is already available, as C<0> if no +library containing function was found, otherwise as the -llibrary option +that needs to be prepended to LIBS. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +If any of I<action_on_cache_true>, I<action_on_cache_false> is defined, +both callbacks are passed to L</check_cached> as I<action_on_true> or +I<action_on_false> to C<check_cached>, respectively. Given callbacks +for I<action_on_lib_true> or I<action_on_lib_false> are called for +each library checked using L</link_if_else> receiving the library as +first argument and all C<@other_libs> subsequently. + +=cut + +sub search_libs +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + my ( $func, $libs, @other_libs ) = @_; + + ( defined($libs) and "ARRAY" eq ref($libs) and scalar( @{$libs} ) > 0 ) + or return 0; # XXX would prefer croak + return 0 unless $func; + + scalar(@other_libs) == 1 + and ref( $other_libs[0] ) eq "ARRAY" + and @other_libs = @{ $other_libs[0] }; + + my $cache_name = $self->_cache_name( "search", $func ); + my $check_sub = sub { + my $conftest = $self->lang_call( "", $func ); + + my @save_libs = @{ $self->{extra_libs} }; + my $have_lib = 0; + foreach my $libstest ( undef, @$libs ) + { + # XXX would local work on array refs? can we omit @save_libs? + $self->{extra_libs} = [@save_libs]; + defined($libstest) and unshift( @{ $self->{extra_libs} }, $libstest, @other_libs ); + $self->link_if_else( + $conftest, + { + ( + $options->{action_on_lib_true} && "CODE" eq ref $options->{action_on_lib_true} + ? ( action_on_true => sub { $options->{action_on_lib_true}->( $libstest, @other_libs, @_ ) } ) + : () + ), + ( + $options->{action_on_lib_false} && "CODE" eq ref $options->{action_on_lib_false} + ? ( action_on_false => sub { $options->{action_on_lib_false}->( $libstest, @other_libs, @_ ) } ) + : () + ), + } + ) + and ( $have_lib = defined($libstest) ? $libstest : "none required" ) + and last; + } + $self->{extra_libs} = [@save_libs]; + + $have_lib eq "none required" or unshift( @{ $self->{extra_libs} }, $have_lib ); + + $have_lib + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$have_lib + and $options->{action_on_false}->(); + + $have_lib; + }; + + return $self->check_cached( + $cache_name, + "for library containing $func", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +sub _check_lm_funcs { qw(log2 pow log10 log exp sqrt) } + +=head2 check_lm( \%options? ) + +This method is used to check if some common C<math.h> functions are +available, and if C<-lm> is needed. Returns the empty string if no +library is needed, or the "-lm" string if libm is needed. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +Each of existing key/value pairs using I<action_on_func_true> (as +I<action_on_true> having the name of the tested functions as first argument), +I<action_on_func_false> (as I<action_on_false> having the name of the tested +functions as first argument), I<action_on_func_lib_true> (as +I<action_on_lib_true> having the name of the tested functions as first +argument), I<action_on_func_lib_false> (as I<action_on_lib_false> having +the name of the tested functions as first argument) as key are passed- +through to each call of L</search_libs>. +Given callbacks for I<action_on_lib_true>, I<action_on_lib_false>, +I<action_on_cache_true> or I<action_on_cache_false> are passed to the +call of L</search_libs>. + +B<Note> that I<action_on_lib_true> and I<action_on_func_lib_true> or +I<action_on_lib_false> and I<action_on_func_lib_false> cannot be used +at the same time, respectively. + +=cut + +sub check_lm +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance(); + + defined $options->{action_on_lib_true} + and defined $options->{action_on_func_lib_true} + and croak("action_on_lib_true and action_on_func_lib_true cannot be used together"); + defined $options->{action_on_lib_false} + and defined $options->{action_on_func_lib_false} + and croak("action_on_lib_false and action_on_func_lib_false cannot be used together"); + + my %pass_options; + defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; + defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; + defined $options->{action_on_lib_true} and $pass_options{action_on_lib_true} = $options->{action_on_lib_true}; + defined $options->{action_on_lib_false} and $pass_options{action_on_lib_false} = $options->{action_on_lib_false}; + + my $fail = 0; + my $required = ""; + my @math_funcs = $self->_check_lm_funcs; + for my $func (@math_funcs) + { + my $ans = $self->search_libs( + $func, + ['m'], + { + %pass_options, + ( + $options->{action_on_func_true} && "CODE" eq ref $options->{action_on_func_true} + ? ( action_on_true => sub { $options->{action_on_func_true}->( $func, @_ ) } ) + : () + ), + ( + $options->{action_on_func_false} && "CODE" eq ref $options->{action_on_func_false} + ? ( action_on_false => sub { $options->{action_on_func_false}->( $func, @_ ) } ) + : () + ), + ( + $options->{action_on_func_lib_true} && "CODE" eq ref $options->{action_on_func_lib_true} + ? ( action_on_lib_true => sub { $options->{action_on_func_lib_true}->( $func, @_ ) } ) + : () + ), + ( + $options->{action_on_func_lib_false} && "CODE" eq ref $options->{action_on_func_lib_false} + ? ( action_on_lib_false => sub { $options->{action_on_func_lib_false}->( $func, @_ ) } ) + : () + ), + }, + ); + + $ans or $fail = 1; + $ans ne "none required" and $required = $ans; + } + + !$fail + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $fail + and $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and $options->{action_on_false}->(); + + $required; +} + +=head2 pkg_config_package_flags($package, \%options?) + +Search for pkg-config flags for package as specified. The flags which are +extracted are C<--cflags> and C<--libs>. The extracted flags are appended +to the global C<extra_compile_flags> and C<extra_link_flags>, respectively. + +Call it with the package you're looking for and optional callback whether +found or not. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. +If any of I<action_on_cache_true>, I<action_on_cache_false> is defined, +both callbacks are passed to L</check_cached> as I<action_on_true> or +I<action_on_false> to L</check_cached>, respectively. + +=cut + +my $_pkg_config_prog; + +sub _pkg_config_flag +{ + defined $_pkg_config_prog or croak("pkg_config_prog required"); + my @pkg_config_args = @_; + my ( $stdout, $stderr, $exit ) = + capture { system( $_pkg_config_prog, @pkg_config_args ); }; + chomp $stdout; + 0 == $exit and return $stdout; + return; +} + +sub pkg_config_package_flags +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my ( $self, $package ) = @_; + $self = $self->_get_instance(); + + ( my $pkgpfx = $package ) =~ s/^(\w+).*?$/$1/; + my $cache_name = $self->_cache_name( "pkg", $pkgpfx ); + + defined $_pkg_config_prog or $_pkg_config_prog = $self->check_prog_pkg_config; + my $check_sub = sub { + my ( @pkg_cflags, @pkg_libs ); + + ( my $ENV_CFLAGS = $package ) =~ s/^(\w+).*?$/$1_CFLAGS/; + my $CFLAGS = + defined $ENV{$ENV_CFLAGS} + ? $ENV{$ENV_CFLAGS} + : _pkg_config_flag( $package, "--cflags" ); + $CFLAGS and @pkg_cflags = ( + map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; Text::ParseWords::shellwords $_; } + split( m/\n/, $CFLAGS ) + ) and push @{ $self->{extra_preprocess_flags} }, @pkg_cflags; + + ( my $ENV_LIBS = $package ) =~ s/^(\w+).*?$/$1_LIBS/; + # do not separate between libs and extra (for now) - they come with -l prepended + my $LIBS = + defined $ENV{$ENV_LIBS} + ? $ENV{$ENV_LIBS} + : _pkg_config_flag( $package, "--libs" ); + $LIBS and @pkg_libs = ( + map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; Text::ParseWords::shellwords $_; } + split( m/\n/, $LIBS ) + ) and push @{ $self->{extra_link_flags} }, @pkg_libs; + + my $pkg_config_flags = join( " ", @pkg_cflags, @pkg_libs ); + + $pkg_config_flags + and $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + $options->{action_on_false} + and ref $options->{action_on_false} eq "CODE" + and !$pkg_config_flags + and $options->{action_on_false}->(); + + $pkg_config_flags; + }; + + $self->check_cached( + $cache_name, + "for pkg-config package of $package", + $check_sub, + { + ( $options->{action_on_cache_true} ? ( action_on_true => $options->{action_on_cache_true} ) : () ), + ( $options->{action_on_cache_false} ? ( action_on_false => $options->{action_on_cache_false} ) : () ) + } + ); +} + +=head2 _check_mm_pureperl_build_wanted + +This method proves the C<_argv> attribute and (when set) the C<PERL_MM_OPT> +whether they contain I<PUREPERL_ONLY=(0|1)> or not. The attribute C<_force_xs> +is set as appropriate, which allows a compile test to bail out when C<Makefile.PL> +is called with I<PUREPERL_ONLY=0>. + +=cut + +sub _check_mm_pureperl_build_wanted +{ + my $self = shift->_get_instance; + + defined $ENV{PERL_MM_OPT} and my @env_args = split " ", $ENV{PERL_MM_OPT}; + + foreach my $arg ( @{ $self->{_argv} }, @env_args ) + { + $arg =~ m/^PUREPERL_ONLY=(.*)$/ and return int($1); + } + + 0; +} + +=head2 _check_mb_pureperl_build_wanted + +This method proves the C<_argv> attribute and (when set) the C<PERL_MB_OPT> +whether they contain I<--pureperl-only> or not. + +=cut + +sub _check_mb_pureperl_build_wanted +{ + my $self = shift->_get_instance; + + defined $ENV{PERL_MB_OPT} and my @env_args = split " ", $ENV{PERL_MB_OPT}; + + foreach my $arg ( @{ $self->{_argv} }, @env_args ) + { + $arg eq "--pureperl-only" and return 1; + } + + 0; +} + +=head2 _check_pureperl_required + +This method calls C<_check_mm_pureperl_build_wanted> when running under +L<ExtUtils::MakeMaker> (C<Makefile.PL>) or C<_check_mb_pureperl_build_wanted> +when running under a C<Build.PL> (L<Module::Build> compatible) environment. + +When neither is found (C<$0> contains neither C<Makefile.PL> nor C<Build.PL>), +simply 0 is returned. + +=cut + +sub _check_pureperl_required +{ + my $self = shift; + $0 =~ m/Makefile\.PL$/i and return $self->_check_mm_pureperl_build_wanted(@_); + $0 =~ m/Build\.PL$/i and return $self->_check_mb_pureperl_build_wanted(@_); + + 0; +} + +=head2 check_pureperl_required + +This check method proves whether a pureperl build is wanted or not by +cached-checking C<< $self->_check_pureperl_required >>. + +=cut + +sub check_pureperl_required +{ + my $self = shift->_get_instance; + my $cache_name = $self->_cache_name(qw(pureperl required)); + $self->check_cached( $cache_name, "whether pureperl is required", sub { $self->_check_pureperl_required } ); +} + +=head2 check_produce_xs_build + +This routine checks whether XS can be produced. Therefore it does +following checks in given order: + +=over 4 + +=item * + +check pureperl environment variables (L</check_pureperl_required>) or +command line arguments and return false when pure perl is requested + +=item * + +check whether a compiler is available (L</check_valid_compilers>) and +return false if none found + +=item * + +check whether a test program accessing Perl API can be compiled and +die with error if not + +=back + +When all checks passed successfully, return a true value. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. + +=cut + +sub check_produce_xs_build +{ + my $options = {}; + scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; + my $self = shift->_get_instance; + $self->check_pureperl_required() and return _on_return_callback_helper( 0, $options, "action_on_false" ); + eval { $self->check_valid_compilers( $_[0] || [qw(C)] ) } or return _on_return_callback_helper( 0, $options, "action_on_false" ); + # XXX necessary check for $Config{useshrlib}? (need to dicuss with eg. TuX, 99% likely return 0) + $self->check_compile_perlapi_or_die(); + + $options->{action_on_true} + and ref $options->{action_on_true} eq "CODE" + and $options->{action_on_true}->(); + + return 1; +} + +=head2 check_produce_loadable_xs_build + +This routine proves whether XS should be built and it's possible to create +a dynamic linked object which can be loaded using Perl's Dynaloader. + +The extension over L</check_produce_xs_build> can be avoided by adding the +C<notest_loadable_xs> to C<$ENV{PERL5_AC_OPTS}>. + +If the very last parameter contains a hash reference, C<CODE> references +to I<action_on_true> or I<action_on_false> are executed, respectively. + +=cut + +sub check_produce_loadable_xs_build +{ + my $self = shift->_get_instance; + $self->check_produce_xs_build(@_) + and !$self->{c_ac_flags}->{notest_loadable_xs} + and $self->check_linkable_xs_so_or_die + and $self->check_loadable_xs_so_or_die; +} + +# +# +# Auxiliary funcs +# + +=head2 _set_argv + +Intended to act as a helper for evaluating given command line arguments. +Stores given arguments in instances C<_argv> attribute. + +Call once at very begin of C<Makefile.PL> or C<Build.PL>: + + Your::Pkg::Config::AutoConf->_set_args(@ARGV); + +=cut + +sub _set_argv +{ + my ( $self, @argv ) = @_; + $self = $self->_get_instance; + $self->{_argv} = \@argv; + return; +} + +sub _sanitize +{ + # This is hard coded, and maybe a little stupid... + my $x = shift; + $x =~ s/ //g; + $x =~ s/\///g; + $x =~ s/\\//g; + $x; +} + +sub _get_instance +{ + ref $_[0] and return $_[0]; + defined $glob_instance or $glob_instance = $_[0]->new(); + $glob_instance; +} + +sub _get_builder +{ + my $self = $_[0]->_get_instance(); + + ref $self->{lang_supported}->{ $self->{lang} } eq "CODE" and $self->{lang_supported}->{ $self->{lang} }->($self); + defined( $self->{lang_supported}->{ $self->{lang} } ) or croak( "Unsupported compile language \"" . $self->{lang} . "\"" ); + + $self->{lang_supported}->{ $self->{lang} }->new(); +} + +sub _set_language +{ + my $self = shift->_get_instance(); + my ( $lang, $impl ) = @_; + + defined($lang) or croak("Missing language"); + + defined($impl) + and defined( $self->{lang_supported}->{$lang} ) + and $impl ne $self->{lang_supported}->{$lang} + and croak( "Language implementor ($impl) doesn't match exisiting one (" . $self->{lang_supported}->{$lang} . ")" ); + + defined($impl) + and !defined( $self->{lang_supported}->{$lang} ) + and $self->{lang_supported}->{$lang} = $impl; + + ref $self->{lang_supported}->{$lang} eq "CODE" and $self->{lang_supported}->{$lang}->($self); + defined( $self->{lang_supported}->{$lang} ) or croak("Unsupported language \"$lang\""); + + defined( $self->{extra_compile_flags}->{$lang} ) or $self->{extra_compile_flags}->{$lang} = []; + + $self->{lang} = $lang; + + return; +} + +sub _on_return_callback_helper +{ + my $callback = pop @_; + my $options = pop @_; + $options->{$callback} + and ref $options->{$callback} eq "CODE" + and $options->{$callback}->(); + @_ and wantarray and return @_; + 1 == scalar @_ and return $_[0]; + return; +} + +sub _fill_defines +{ + my ( $self, $src, $action_if_true, $action_if_false ) = @_; + ref $self or $self = $self->_get_instance(); + + my $conftest = ""; + while ( my ( $defname, $defcnt ) = each( %{ $self->{defines} } ) ) + { + $defcnt->[0] or next; + defined $defcnt->[1] and $conftest .= "/* " . $defcnt->[1] . " */\n"; + $conftest .= join( " ", "#define", $defname, $defcnt->[0] ) . "\n"; + } + $conftest .= "/* end of conftest.h */\n"; + + $conftest; +} + +# +# default includes taken from autoconf/headers.m4 +# + +=head2 _default_includes + +returns a string containing default includes for program prologue taken +from autoconf/headers.m4: + + #include <stdio.h> + #ifdef HAVE_SYS_TYPES_H + # include <sys/types.h> + #endif + #ifdef HAVE_SYS_STAT_H + # include <sys/stat.h> + #endif + #ifdef STDC_HEADERS + # include <stdlib.h> + # include <stddef.h> + #else + # ifdef HAVE_STDLIB_H + # include <stdlib.h> + # endif + #endif + #ifdef HAVE_STRING_H + # if !defined STDC_HEADERS && defined HAVE_MEMORY_H + # include <memory.h> + # endif + # include <string.h> + #endif + #ifdef HAVE_STRINGS_H + # include <strings.h> + #endif + #ifdef HAVE_INTTYPES_H + # include <inttypes.h> + #endif + #ifdef HAVE_STDINT_H + # include <stdint.h> + #endif + #ifdef HAVE_UNISTD_H + # include <unistd.h> + #endif + +=cut + +my $_default_includes = <<"_ACEOF"; +#include <stdio.h> +#ifdef HAVE_SYS_TYPES_H +# include <sys/types.h> +#endif +#ifdef HAVE_SYS_STAT_H +# include <sys/stat.h> +#endif +#ifdef STDC_HEADERS +# include <stdlib.h> +# include <stddef.h> +#else +# ifdef HAVE_STDLIB_H +# include <stdlib.h> +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include <memory.h> +# endif +# include <string.h> +#endif +#ifdef HAVE_STRINGS_H +# include <strings.h> +#endif +#ifdef HAVE_INTTYPES_H +# include <inttypes.h> +#endif +#ifdef HAVE_STDINT_H +# include <stdint.h> +#endif +#ifdef HAVE_UNISTD_H +# include <unistd.h> +#endif +_ACEOF + +sub _default_includes { $_default_includes } + +sub _default_main { $_[0]->_build_main("") } + +my $_main_tpl = <<"_ACEOF"; + int + main () + { + %s; + return 0; + } +_ACEOF + +sub _build_main +{ + my $self = shift->_get_instance(); + my $body = shift || ""; + sprintf( $_main_tpl, $body ); +} + +=head2 _default_includes_with_perl + +returns a string containing default includes for program prologue containing +I<_default_includes> plus + + #include <EXTERN.h> + #include <perl.h> + +=cut + +my $_include_perl = <<"_ACEOF"; +#include <EXTERN.h> +#include <perl.h> +#include <XSUB.h> /* for perl context in threaded perls */ +_ACEOF + +sub _default_includes_with_perl +{ + join( "\n", $_[0]->_default_includes, $_include_perl ); +} + +sub _cache_prefix { "ac" } + +sub _cache_name +{ + my ( $self, @names ) = @_; + my $cache_name = join( "_", $self->_cache_prefix(), "cv", @names ); + $cache_name =~ tr/_A-Za-z0-9/_/c; + $cache_name; +} + +sub _get_log_fh +{ + my $self = $_[0]->_get_instance(); + unless ( defined( $self->{logfh} ) ) + { + my $open_mode = defined $self->{logfile_mode} ? $self->{logfile_mode} : ">"; + open( my $fh, $open_mode, $self->{logfile} ) or croak "Could not open file $self->{logfile}: $!"; + $self->{logfh} = [$fh]; + } + + $self->{logfh}; +} + +sub _add_log_entry +{ + my ( $self, @logentries ) = @_; + ref($self) or $self = $self->_get_instance(); + $self->_get_log_fh(); + foreach my $logentry (@logentries) + { + foreach my $fh ( @{ $self->{logfh} } ) + { + print {$fh} "$logentry"; + } + } + + return; +} + +sub _add_log_lines +{ + my ( $self, @logentries ) = @_; + ref($self) or $self = $self->_get_instance(); + $self->_get_log_fh(); + my $logmsg = join( "\n", @logentries ) . "\n"; + foreach my $fh ( @{ $self->{logfh} } ) + { + print {$fh} $logmsg; + } + + return; +} + +=head2 add_log_fh + +Push new file handles at end of log-handles to allow tee-ing log-output + +=cut + +sub add_log_fh +{ + my ( $self, @newh ) = @_; + $self->_get_log_fh(); + SKIP_DUP: + foreach my $fh (@newh) + { + foreach my $eh ( @{ $self->{logfh} } ) + { + $fh == $eh and next SKIP_DUP; + } + push @{ $self->{logfh} }, $fh; + } + return; +} + +=head2 delete_log_fh + +Removes specified log file handles. This method allows you to shoot +yourself in the foot - it doesn't prove whether the primary nor the last handle +is removed. Use with caution. + +=cut + +sub delete_log_fh +{ + my ( $self, @xh ) = @_; + $self->_get_log_fh(); + SKIP_DUP: + foreach my $fh (@xh) + { + foreach my $ih ( 0 .. $#{ $self->{logfh} } ) + { + $fh == $self->{logfh}->[$ih] or next; + splice @{ $self->{logfh} }, $ih, 1; + last; + } + } + return; +} + +sub _cache_type_name +{ + my ( $self, @names ) = @_; + $self->_cache_name( map { $_ =~ tr/*/p/; $_ } @names ); +} + +sub _get_extra_compiler_flags +{ + my $self = shift->_get_instance(); + my @ppflags = @{ $self->{extra_preprocess_flags} }; + my @cflags = @{ $self->{extra_compile_flags}->{ $self->{lang} } }; + join( " ", @ppflags, @cflags ); +} + +sub _get_extra_linker_flags +{ + my $self = shift->_get_instance(); + my @libs = @{ $self->{extra_libs} }; + my @ldflags = @{ $self->{extra_link_flags} }; + join( " ", @ldflags, map { "-l$_" } @libs ); +} + +=head1 AUTHOR + +Alberto Simões, C<< <ambs@cpan.org> >> + +Jens Rehsack, C<< <rehsack@cpan.org> >> + +=head1 NEXT STEPS + +Although a lot of work needs to be done, these are the next steps I +intend to take. + + - detect flex/lex + - detect yacc/bison/byacc + - detect ranlib (not sure about its importance) + +These are the ones I think not too much important, and will be +addressed later, or by request. + + - detect an 'install' command + - detect a 'ln -s' command -- there should be a module doing + this kind of task. + +=head1 BUGS + +A lot. Portability is a pain. B<<Patches welcome!>>. + +Please report any bugs or feature requests to +C<bug-Config-AutoConf@rt.cpan.org>, or through the web interface at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Config-AutoConf>. We will +be notified, and then you'll automatically be notified of progress +on your bug as we make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Config::AutoConf + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/Config-AutoConf> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/l/Config-AutoConf> + +=item * MetaCPAN + +L<https://metacpan.org/release/Config-AutoConf> + +=item * Git Repository + +L<https://github.com/ambs/Config-AutoConf> + +=back + +=head1 ACKNOWLEDGEMENTS + +Michael Schwern for kind MacOS X help. + +Ken Williams for ExtUtils::CBuilder + +Peter Rabbitson for help on refactoring and making the API more Perl'ish + +=head1 COPYRIGHT & LICENSE + +Copyright 2004-2015 by the Authors + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +ExtUtils::CBuilder(3) + +=cut + +1; # End of Config::AutoConf diff --git a/inc/latest.pm b/inc/latest.pm new file mode 100644 index 0000000..56e8a3b --- /dev/null +++ b/inc/latest.pm @@ -0,0 +1,8 @@ +# This stub created by inc::latest 0.500 +package inc::latest; +use strict; +use vars '@ISA'; +require inc::latest::private; +@ISA = qw/inc::latest::private/; + +1; diff --git a/inc/latest/private.pm b/inc/latest/private.pm new file mode 100644 index 0000000..65a366b --- /dev/null +++ b/inc/latest/private.pm @@ -0,0 +1,147 @@ +use strict; +use warnings; + +package inc::latest::private; +# ABSTRACT: private implementation for inc::latest + +our $VERSION = '0.500'; + +use File::Spec; +use IO::File; + +# must ultimately "goto" the import routine of the module to be loaded +# so that the calling package is correct when $mod->import() runs. +sub import { + my ( $package, $mod, @args ) = @_; + my $file = $package->_mod2path($mod); + + if ( $INC{$file} ) { + # Already loaded, but let _load_module handle import args + goto \&_load_module; + } + + # A bundled copy must be present + my ( $bundled, $bundled_dir ) = $package->_search_bundled($file) + or die "No bundled copy of $mod found"; + + my $from_inc = $package->_search_INC($file); + unless ($from_inc) { + # Only bundled is available + unshift( @INC, $bundled_dir ); + goto \&_load_module; + } + + if ( _version($from_inc) >= _version($bundled) ) { + # Ignore the bundled copy + goto \&_load_module; + } + + # Load the bundled copy + unshift( @INC, $bundled_dir ); + goto \&_load_module; +} + +sub _version { + require ExtUtils::MakeMaker; + return ExtUtils::MM->parse_version(shift); +} + +# use "goto" for import to preserve caller +sub _load_module { + my $package = shift; # remaining @_ is ready for goto + my ( $mod, @args ) = @_; + eval "require $mod; 1" or die $@; + if ( my $import = $mod->can('import') ) { + goto $import; + } + return 1; +} + +sub _search_bundled { + my ( $self, $file ) = @_; + + my $mypath = 'inc'; + + local *DH; # Maintain 5.005 compatibility + opendir DH, $mypath or die "Can't open directory $mypath: $!"; + + while ( defined( my $e = readdir DH ) ) { + next unless $e =~ /^inc_/; + my $try = File::Spec->catfile( $mypath, $e, $file ); + + return ( $try, File::Spec->catdir( $mypath, $e ) ) if -e $try; + } + return; +} + +# Look for the given path in @INC. +sub _search_INC { + # TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but + # it probably should + my ( $self, $file ) = @_; + + foreach my $dir (@INC) { + next if ref $dir; + my $try = File::Spec->catfile( $dir, $file ); + return $try if -e $try; + } + + return; +} + +# Translate a module name into a directory/file.pm to search for in @INC +sub _mod2path { + my ( $self, $mod ) = @_; + my @parts = split /::/, $mod; + $parts[-1] .= '.pm'; + return $parts[0] if @parts == 1; + return File::Spec->catfile(@parts); +} + +1; + + +# vim: ts=4 sts=4 sw=4 tw=75 et: + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +inc::latest::private - private implementation for inc::latest + +=head1 VERSION + +version 0.500 + +=head1 DESCRIPTION + +This module has the private methods used to find and load bundled modules. +It should not be used directly. + +=head1 AUTHORS + +=over 4 + +=item * + +David Golden <dagolden@cpan.org> + +=item * + +Eric Wilhelm <ewilhelm@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2009 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + +=cut diff --git a/lib/List/MoreUtils.pm b/lib/List/MoreUtils.pm new file mode 100644 index 0000000..266eca1 --- /dev/null +++ b/lib/List/MoreUtils.pm @@ -0,0 +1,960 @@ +package List::MoreUtils; + +use 5.006; +use strict; +use warnings; + +BEGIN +{ + our $VERSION = '0.413'; +} + +use Exporter::Tiny qw(); +use List::MoreUtils::XS qw(); # try loading XS + +my @junctions = qw(any all none notall); +my @v0_22 = qw( + true false + firstidx lastidx + insert_after insert_after_string + apply indexes + after after_incl before before_incl + firstval lastval + each_array each_arrayref + pairwise natatime + mesh uniq + minmax part +); +my @v0_24 = qw(bsearch); +my @v0_33 = qw(sort_by nsort_by); +my @v0_400 = qw(one any_u all_u none_u notall_u one_u + firstres onlyidx onlyval onlyres lastres + singleton bsearchidx +); + +my @all_functions = ( @junctions, @v0_22, @v0_24, @v0_33, @v0_400 ); + +my %alias_list = ( + v0_22 => { + first_index => "firstidx", + last_index => "lastidx", + first_value => "firstval", + last_value => "lastval", + zip => "mesh", + }, + v0_33 => { + distinct => "uniq", + }, + v0_400 => { + first_result => "firstres", + only_index => "onlyidx", + only_value => "onlyval", + only_result => "onlyres", + last_result => "lastres", + bsearch_index => "bsearchidx", + }, +); + +our @ISA = qw(Exporter::Tiny); +our @EXPORT_OK = ( @all_functions, map { keys %$_ } values %alias_list ); +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, + 'like_0.22' => [ + any_u => { -as => 'any' }, + all_u => { -as => 'all' }, + none_u => { -as => 'none' }, + notall_u => { -as => 'notall' }, + @v0_22, + keys %{ $alias_list{v0_22} }, + ], + 'like_0.24' => [ + any_u => { -as => 'any' }, + all_u => { -as => 'all' }, + notall_u => { -as => 'notall' }, + 'none', + @v0_22, + @v0_24, + keys %{ $alias_list{v0_22} }, + ], + 'like_0.33' => [ + @junctions, + @v0_22, + # v0_24 functions were omitted + @v0_33, + keys %{ $alias_list{v0_22} }, + keys %{ $alias_list{v0_33} }, + ], +); + +for my $set ( values %alias_list ) +{ + for my $alias ( keys %$set ) + { + no strict qw(refs); + *$alias = __PACKAGE__->can( $set->{$alias} ); + } +} + +=pod + +=head1 NAME + +List::MoreUtils - Provide the stuff missing in List::Util + +=head1 SYNOPSIS + + # import specific functions + + use List::MoreUtils qw(any uniq); + + if ( any { /foo/ } uniq @has_duplicates ) { + # do stuff + } + + # import everything + + use List::MoreUtils ':all'; + + # import by API + + # has "original" any/all/none/notall behavior + use List::MoreUtils ':like_0.22'; + # 0.22 + bsearch + use List::MoreUtils ':like_0.24'; + # has "simplified" any/all/none/notall behavior + (n)sort_by + use List::MoreUtils ':like_0.33'; + +=head1 DESCRIPTION + +B<List::MoreUtils> provides some trivial but commonly needed functionality on +lists which is not going to go into L<List::Util>. + +All of the below functions are implementable in only a couple of lines of Perl +code. Using the functions from this module however should give slightly better +performance as everything is implemented in C. The pure-Perl implementation of +these functions only serves as a fallback in case the C portions of this module +couldn't be compiled on this machine. + +=head1 EXPORTS + +=head2 Default behavior + +Nothing by default. To import all of this module's symbols use the C<:all> tag. +Otherwise functions can be imported by name as usual: + + use List::MoreUtils ':all'; + + use List::MoreUtils qw{ any firstidx }; + +Because historical changes to the API might make upgrading List::MoreUtils +difficult for some projects, the legacy API is available via special import +tags. + +=head2 Like version 0.22 (last release with original API) + +This API was available from 2006 to 2009, returning undef for empty lists on +C<all>/C<any>/C<none>/C<notall>: + + use List::MoreUtils ':like_0.22'; + +This import tag will import all functions available as of version 0.22. +However, it will import C<any_u> as C<any>, C<all_u> as C<all>, C<none_u> as +C<none>, and C<notall_u> as C<notall>. + +=head2 Like version 0.24 (first incompatible change) + +This API was available from 2010 to 2011. It changed the return value of C<none> +and added the C<bsearch> function. + + use List::MoreUtils ':like_0.24'; + +This import tag will import all functions available as of version 0.24. +However it will import C<any_u> as C<any>, C<all_u> as C<all>, and +C<notall_u> as C<notall>. It will import C<none> as described in +the documentation below (true for empty list). + +=head2 Like version 0.33 (second incompatible change) + +This API was available from 2011 to 2014. It is widely used in several CPAN +modules and thus it's closest to the current API. It changed the return values +of C<any>, C<all>, and C<notall>. It added the C<sort_by> and C<nsort_by> functions +and the C<distinct> alias for C<uniq>. It omitted C<bsearch>. + + use List::MoreUtils ':like_0.33'; + +This import tag will import all functions available as of version 0.33. Note: +it will not import C<bsearch> for consistency with the 0.33 API. + +=head1 FUNCTIONS + +=head2 Junctions + +=head3 I<Treatment of an empty list> + +There are two schools of thought for how to evaluate a junction on an +empty list: + +=over + +=item * + +Reduction to an identity (boolean) + +=item * + +Result is undefined (three-valued) + +=back + +In the first case, the result of the junction applied to the empty list is +determined by a mathematical reduction to an identity depending on whether +the underlying comparison is "or" or "and". Conceptually: + + "any are true" "all are true" + -------------- -------------- + 2 elements: A || B || 0 A && B && 1 + 1 element: A || 0 A && 1 + 0 elements: 0 1 + +In the second case, three-value logic is desired, in which a junction +applied to an empty list returns C<undef> rather than true or false + +Junctions with a C<_u> suffix implement three-valued logic. Those +without are boolean. + +=head3 all BLOCK LIST + +=head3 all_u BLOCK LIST + +Returns a true value if all items in LIST meet the criterion given through +BLOCK. Sets C<$_> for each item in LIST in turn: + + print "All values are non-negative" + if all { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C<all> returns true (i.e. no values failed the condition) +and C<all_u> returns C<undef>. + +Thus, C<< all_u(@list) >> is equivalent to C<< @list ? all(@list) : undef >>. + +B<Note>: because Perl treats C<undef> as false, you must check the return value +of C<all_u> with C<defined> or you will get the opposite result of what you +expect. + +=head3 any BLOCK LIST + +=head3 any_u BLOCK LIST + +Returns a true value if any item in LIST meets the criterion given through +BLOCK. Sets C<$_> for each item in LIST in turn: + + print "At least one non-negative value" + if any { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C<any> returns false and C<any_u> returns C<undef>. + +Thus, C<< any_u(@list) >> is equivalent to C<< @list ? any(@list) : undef >>. + +=head3 none BLOCK LIST + +=head3 none_u BLOCK LIST + +Logically the negation of C<any>. Returns a true value if no item in LIST meets +the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn: + + print "No non-negative values" + if none { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C<none> returns true (i.e. no values failed the condition) +and C<none_u> returns C<undef>. + +Thus, C<< none_u(@list) >> is equivalent to C<< @list ? none(@list) : undef >>. + +B<Note>: because Perl treats C<undef> as false, you must check the return value +of C<none_u> with C<defined> or you will get the opposite result of what you +expect. + +=head3 notall BLOCK LIST + +=head3 notall_u BLOCK LIST + +Logically the negation of C<all>. Returns a true value if not all items in LIST +meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in +turn: + + print "Not all values are non-negative" + if notall { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C<notall> returns false and C<notall_u> returns C<undef>. + +Thus, C<< notall_u(@list) >> is equivalent to C<< @list ? notall(@list) : undef >>. + +=head3 one BLOCK LIST + +=head3 one_u BLOCK LIST + +Returns a true value if precisely one item in LIST meets the criterion +given through BLOCK. Sets C<$_> for each item in LIST in turn: + + print "Precisely one value defined" + if one { defined($_) } @list; + +Returns false otherwise. + +For an empty LIST, C<one> returns false and C<one_u> returns C<undef>. + +The expression C<one BLOCK LIST> is almost equivalent to +C<1 == true BLOCK LIST>, except for short-cutting. +Evaluation of BLOCK will immediately stop at the second true value. + +=head2 Transformation + +=head3 apply BLOCK LIST + +Applies BLOCK to each item in LIST and returns a list of the values after BLOCK +has been applied. In scalar context, the last element is returned. This +function is similar to C<map> but will not modify the elements of the input +list: + + my @list = (1 .. 4); + my @mult = apply { $_ *= 2 } @list; + print "\@list = @list\n"; + print "\@mult = @mult\n"; + __END__ + @list = 1 2 3 4 + @mult = 2 4 6 8 + +Think of it as syntactic sugar for + + for (my @mult = @list) { $_ *= 2 } + +=head3 insert_after BLOCK VALUE LIST + +Inserts VALUE after the first item in LIST for which the criterion in BLOCK is +true. Sets C<$_> for each item in LIST in turn. + + my @list = qw/This is a list/; + insert_after { $_ eq "a" } "longer" => @list; + print "@list"; + __END__ + This is a longer list + +=head3 insert_after_string STRING VALUE LIST + +Inserts VALUE after the first item in LIST which is equal to STRING. + + my @list = qw/This is a list/; + insert_after_string "a", "longer" => @list; + print "@list"; + __END__ + This is a longer list + +=head3 pairwise BLOCK ARRAY1 ARRAY2 + +Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a +new list consisting of BLOCK's return values. The two elements are set to C<$a> +and C<$b>. Note that those two are aliases to the original value so changing +them will modify the input arrays. + + @a = (1 .. 5); + @b = (11 .. 15); + @x = pairwise { $a + $b } @a, @b; # returns 12, 14, 16, 18, 20 + + # mesh with pairwise + @a = qw/a b c/; + @b = qw/1 2 3/; + @x = pairwise { ($a, $b) } @a, @b; # returns a, 1, b, 2, c, 3 + +=head3 mesh ARRAY1 ARRAY2 [ ARRAY3 ... ] + +=head3 zip ARRAY1 ARRAY2 [ ARRAY3 ... ] + +Returns a list consisting of the first elements of each array, then +the second, then the third, etc, until all arrays are exhausted. + +Examples: + + @x = qw/a b c d/; + @y = qw/1 2 3 4/; + @z = mesh @x, @y; # returns a, 1, b, 2, c, 3, d, 4 + + @a = ('x'); + @b = ('1', '2'); + @c = qw/zip zap zot/; + @d = mesh @a, @b, @c; # x, 1, zip, undef, 2, zap, undef, undef, zot + +C<zip> is an alias for C<mesh>. + +=head3 uniq LIST + +=head3 distinct LIST + +Returns a new list by stripping duplicate values in LIST by comparing +the values as hash keys, except that undef is considered separate from ''. +The order of elements in the returned list is the same as in LIST. In +scalar context, returns the number of unique elements in LIST. + + my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4 + my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5 + # returns "Mike", "Michael", "Richard", "Rick" + my @n = distinct "Mike", "Michael", "Richard", "Rick", "Michael", "Rick" + # returns '', 'S1', A5' and complains about "Use of uninitialized value" + my @s = distinct '', undef, 'S1', 'A5' + # returns undef, 'S1', A5' and complains about "Use of uninitialized value" + my @w = uniq undef, '', 'S1', 'A5' + +C<distinct> is an alias for C<uniq>. + +B<RT#49800> can be used to give feedback about this behavior. + +=head3 singleton + +Returns a new list by stripping values in LIST occurring more than once by +comparing the values as hash keys, except that undef is considered separate +from ''. The order of elements in the returned list is the same as in LIST. +In scalar context, returns the number of elements occurring only once in LIST. + + my @x = singleton 1,1,2,2,3,4,5 # returns 3 4 5 + +=head2 Partitioning + +=head3 after BLOCK LIST + +Returns a list of the values of LIST after (and not including) the point +where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn. + + @x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9 + +=head3 after_incl BLOCK LIST + +Same as C<after> but also includes the element for which BLOCK is true. + +=head3 before BLOCK LIST + +Returns a list of values of LIST up to (and not including) the point where BLOCK +returns a true value. Sets C<$_> for each element in LIST in turn. + +=head3 before_incl BLOCK LIST + +Same as C<before> but also includes the element for which BLOCK is true. + +=head3 part BLOCK LIST + +Partitions LIST based on the return value of BLOCK which denotes into which +partition the current value is put. + +Returns a list of the partitions thusly created. Each partition created is a +reference to an array. + + my $i = 0; + my @part = part { $i++ % 2 } 1 .. 8; # returns [1, 3, 5, 7], [2, 4, 6, 8] + +You can have a sparse list of partitions as well where non-set partitions will +be undef: + + my @part = part { 2 } 1 .. 10; # returns undef, undef, [ 1 .. 10 ] + +Be careful with negative values, though: + + my @part = part { -1 } 1 .. 10; + __END__ + Modification of non-creatable array value attempted, subscript -1 ... + +Negative values are only ok when they refer to a partition previously created: + + my @idx = ( 0, 1, -1 ); + my $i = 0; + my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] + +=head2 Iteration + +=head3 each_array ARRAY1 ARRAY2 ... + +Creates an array iterator to return the elements of the list of arrays ARRAY1, +ARRAY2 throughout ARRAYn in turn. That is, the first time it is called, it +returns the first element of each array. The next time, it returns the second +elements. And so on, until all elements are exhausted. + +This is useful for looping over more than one array at once: + + my $ea = each_array(@a, @b, @c); + while ( my ($a, $b, $c) = $ea->() ) { .... } + +The iterator returns the empty list when it reached the end of all arrays. + +If the iterator is passed an argument of 'C<index>', then it returns +the index of the last fetched set of values, as a scalar. + +=head3 each_arrayref LIST + +Like each_array, but the arguments are references to arrays, not the +plain arrays. + +=head3 natatime EXPR, LIST + +Creates an array iterator, for looping over an array in chunks of +C<$n> items at a time. (n at a time, get it?). An example is +probably a better explanation than I could give in words. + +Example: + + my @x = ('a' .. 'g'); + my $it = natatime 3, @x; + while (my @vals = $it->()) + { + print "@vals\n"; + } + +This prints + + a b c + d e f + g + +=head2 Searching + +=head3 bsearch BLOCK LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in C<$_>) is smaller, +a positive value if it is bigger and zero if it matches. + +Returns a boolean value in scalar context. In list context, it returns the element +if it was found, otherwise the empty list. + +=head3 bsearchidx BLOCK LIST + +=head3 bsearch_index BLOCK LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in C<$_>) is smaller, +a positive value if it is bigger and zero if it matches. + +Returns the index of found element, otherwise C<-1>. + +C<bsearch_index> is an alias for C<bsearchidx>. + +=head3 firstval BLOCK LIST + +=head3 first_value BLOCK LIST + +Returns the first element in LIST for which BLOCK evaluates to true. Each +element of LIST is set to C<$_> in turn. Returns C<undef> if no such element +has been found. + +C<first_value> is an alias for C<firstval>. + +=head3 onlyval BLOCK LIST + +=head3 only_value BLOCK LIST + +Returns the only element in LIST for which BLOCK evaluates to true. Sets +C<$_> for each item in LIST in turn. Returns C<undef> if no such element +has been found. + +C<only_value> is an alias for C<onlyval>. + +=head3 lastval BLOCK LIST + +=head3 last_value BLOCK LIST + +Returns the last value in LIST for which BLOCK evaluates to true. Each element +of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been +found. + +C<last_value> is an alias for C<lastval>. + +=head3 firstres BLOCK LIST + +=head3 first_result BLOCK LIST + +Returns the result of BLOCK for the first element in LIST for which BLOCK +evaluates to true. Each element of LIST is set to C<$_> in turn. Returns +C<undef> if no such element has been found. + +C<first_result> is an alias for C<firstres>. + +=head3 onlyres BLOCK LIST + +=head3 only_result BLOCK LIST + +Returns the result of BLOCK for the first element in LIST for which BLOCK +evaluates to true. Sets C<$_> for each item in LIST in turn. Returns +C<undef> if no such element has been found. + +C<only_result> is an alias for C<onlyres>. + +=head3 lastres BLOCK LIST + +=head3 last_result BLOCK LIST + +Returns the result of BLOCK for the last element in LIST for which BLOCK +evaluates to true. Each element of LIST is set to C<$_> in turn. Returns +C<undef> if no such element has been found. + +C<last_result> is an alias for C<lastres>. + +=head3 indexes BLOCK LIST + +Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list +of the indices of those elements for which BLOCK returned a true value. This is +just like C<grep> only that it returns indices instead of values: + + @x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9 + +=head3 firstidx BLOCK LIST + +=head3 first_index BLOCK LIST + +Returns the index of the first element in LIST for which the criterion in BLOCK +is true. Sets C<$_> for each item in LIST in turn: + + my @list = (1, 4, 3, 2, 4, 6); + printf "item with index %i in list is 4", firstidx { $_ == 4 } @list; + __END__ + item with index 1 in list is 4 + +Returns C<-1> if no such item could be found. + +C<first_index> is an alias for C<firstidx>. + +=head3 onlyidx BLOCK LIST + +=head3 only_index BLOCK LIST + +Returns the index of the only element in LIST for which the criterion +in BLOCK is true. Sets C<$_> for each item in LIST in turn: + + my @list = (1, 3, 4, 3, 2, 4); + printf "uniqe index of item 2 in list is %i", onlyidx { $_ == 2 } @list; + __END__ + unique index of item 2 in list is 4 + +Returns C<-1> if either no such item or more than one of these +has been found. + +C<only_index> is an alias for C<onlyidx>. + +=head3 lastidx BLOCK LIST + +=head3 last_index BLOCK LIST + +Returns the index of the last element in LIST for which the criterion in BLOCK +is true. Sets C<$_> for each item in LIST in turn: + + my @list = (1, 4, 3, 2, 4, 6); + printf "item with index %i in list is 4", lastidx { $_ == 4 } @list; + __END__ + item with index 4 in list is 4 + +Returns C<-1> if no such item could be found. + +C<last_index> is an alias for C<lastidx>. + +=head2 Sorting + +=head3 sort_by BLOCK LIST + +Returns the list of values sorted according to the string values returned by the +KEYFUNC block or function. A typical use of this may be to sort objects according +to the string value of some accessor, such as + + sort_by { $_->name } @people + +The key function is called in scalar context, being passed each value in turn as +both $_ and the only argument in the parameters, @_. The values are then sorted +according to string comparisons on the values returned. +This is equivalent to + + sort { $a->name cmp $b->name } @people + +except that it guarantees the name accessor will be executed only once per value. +One interesting use-case is to sort strings which may have numbers embedded in them +"naturally", rather than lexically. + + sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings + +This sorts strings by generating sort keys which zero-pad the embedded numbers to +some level (9 digits in this case), helping to ensure the lexical sort puts them +in the correct order. + +=head3 nsort_by BLOCK LIST + +Similar to sort_by but compares its key values numerically. + +=head2 Counting and calculation + +=head3 true BLOCK LIST + +Counts the number of elements in LIST for which the criterion in BLOCK is true. +Sets C<$_> for each item in LIST in turn: + + printf "%i item(s) are defined", true { defined($_) } @list; + +=head3 false BLOCK LIST + +Counts the number of elements in LIST for which the criterion in BLOCK is false. +Sets C<$_> for each item in LIST in turn: + + printf "%i item(s) are not defined", false { defined($_) } @list; + +=head3 minmax LIST + +Calculates the minimum and maximum of LIST and returns a two element list with +the first element being the minimum and the second the maximum. Returns the +empty list if LIST was empty. + +The C<minmax> algorithm differs from a naive iteration over the list where each +element is compared to two values being the so far calculated min and max value +in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient +possible algorithm. + +However, the Perl implementation of it has some overhead simply due to the fact +that there are more lines of Perl code involved. Therefore, LIST needs to be +fairly big in order for C<minmax> to win over a naive implementation. This +limitation does not apply to the XS version. + +=head1 ENVIRONMENT + +When C<LIST_MOREUTILS_PP> is set, the module will always use the pure-Perl +implementation and not the XS one. This environment variable is really just +there for the test-suite to force testing the Perl implementation, and possibly +for reporting of bugs. I don't see any reason to use it in a production +environment. + +=head1 MAINTENANCE + +The maintenance goal is to preserve the documented semantics of the API; +bug fixes that bring actual behavior in line with semantics are allowed. +New API functions may be added over time. If a backwards incompatible +change is unavoidable, we will attempt to provide support for the legacy +API using the same export tag mechanism currently in place. + +This module attempts to use few non-core dependencies. Non-core +configuration and testing modules will be bundled when reasonable; +run-time dependencies will be added only if they deliver substantial +benefit. + +=head1 CONTRIBUTING + +While contributions are appreciated, a contribution should not cause more +effort for the maintainer than the contribution itself saves (see +L<Open Source Contribution Etiquette|http://tirania.org/blog/archive/2010/Dec-31.html>). + +To get more familiar where help could be needed - see L<List::MoreUtils::Contributing>. + +=head1 BUGS + +There is a problem with a bug in 5.6.x perls. It is a syntax error to write +things like: + + my @x = apply { s/foo/bar/ } qw{ foo bar baz }; + +It has to be written as either + + my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz'; + +or + + my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/; + +Perl 5.5.x and Perl 5.8.x don't suffer from this limitation. + +If you have a functionality that you could imagine being in this module, please +drop me a line. This module's policy will be less strict than L<List::Util>'s +when it comes to additions as it isn't a core module. + +When you report bugs, it would be nice if you could additionally give me the +output of your program with the environment variable C<LIST_MOREUTILS_PP> set +to a true value. That way I know where to look for the problem (in XS, +pure-Perl or possibly both). + +=head1 SUPPORT + +Bugs should always be submitted via the CPAN bug tracker. + +You can find documentation for this module with the perldoc command. + + perldoc List::MoreUtils + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=List-MoreUtils> + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/List-MoreUtils> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/l/List-MoreUtils> + +=item * CPAN Search + +L<http://search.cpan.org/dist/List-MoreUtils/> + +=item * Git Repository + +L<https://github.com/perl5-utils/List-MoreUtils> + +=back + +=head2 Where can I go for help? + +If you have a bug report, a patch or a suggestion, please open a new +report ticket at CPAN (but please check previous reports first in case +your issue has already been addressed) or open an issue on GitHub. + +Report tickets should contain a detailed description of the bug or +enhancement request and at least an easily verifiable way of +reproducing the issue or fix. Patches are always welcome, too - and +it's cheap to send pull-requests on GitHub. Please keep in mind that +code changes are more likely accepted when they're bundled with an +approving test. + +If you think you've found a bug then please read +"How to Report Bugs Effectively" by Simon Tatham: +L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>. + +=head2 Where can I go for help with a concrete version? + +Bugs and feature requests are accepted against the latest version +only. To get patches for earlier versions, you need to get an +agreement with a developer of your choice - who may or not report the +issue and a suggested fix upstream (depends on the license you have +chosen). + +=head2 Business support and maintenance + +Generally, in volunteered projects, there is no right for support. +While every maintainer is happy to improve the provided software, +spare time is limited. + +For those who have a use case which requires guaranteed support, one of +the maintainers should be hired or contracted. For business support you +can contact Jens via his CPAN email address rehsackATcpan.org. Please +keep in mind that business support is neither available for free nor +are you eligible to receive any support based on the license distributed +with this package. + +=head1 THANKS + +=head2 Tassilo von Parseval + +Credits go to a number of people: Steve Purkis for giving me namespace advice +and James Keenan and Terrence Branno for their effort of keeping the CPAN +tidier by making L<List::Utils> obsolete. + +Brian McCauley suggested the inclusion of apply() and provided the pure-Perl +implementation for it. + +Eric J. Roode asked me to add all functions from his module C<List::MoreUtil> +into this one. With minor modifications, the pure-Perl implementations of those +are by him. + +The bunch of people who almost immediately pointed out the many problems with +the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers). + +A particularly nasty memory leak was spotted by Thomas A. Lowery. + +Lars Thegler made me aware of problems with older Perl versions. + +Anno Siegel de-orphaned each_arrayref(). + +David Filmer made me aware of a problem in each_arrayref that could ultimately +lead to a segfault. + +Ricardo Signes suggested the inclusion of part() and provided the +Perl-implementation. + +Robin Huston kindly fixed a bug in perl's MULTICALL API to make the +XS-implementation of part() work. + +=head2 Jens Rehsack + +Credits goes to all people contributing feedback during the v0.400 +development releases. + +Special thanks goes to David Golden who spent a lot of effort to develop +a design to support current state of CPAN as well as ancient software +somewhere in the dark. He also contributed a lot of patches to refactor +the API frontend to welcome any user of List::MoreUtils - from ancient +past to recently last used. + +Toby Inkster provided a lot of useful feedback for sane importer code +and was a nice sounding board for API discussions. + +Peter Rabbitson provided a sane git repository setup containing entire +package history. + +=head1 TODO + +A pile of requests from other people is still pending further processing in +my mailbox. This includes: + +=over 4 + +=item * List::Util export pass-through + +Allow B<List::MoreUtils> to pass-through the regular L<List::Util> +functions to end users only need to C<use> the one module. + +=item * uniq_by(&@) + +Use code-reference to extract a key based on which the uniqueness is +determined. Suggested by Aaron Crane. + +=item * delete_index + +=item * random_item + +=item * random_item_delete_index + +=item * list_diff_hash + +=item * list_diff_inboth + +=item * list_diff_infirst + +=item * list_diff_insecond + +These were all suggested by Dan Muey. + +=item * listify + +Always return a flat list when either a simple scalar value was passed or an +array-reference. Suggested by Mark Summersault. + +=back + +=head1 SEE ALSO + +L<List::Util>, L<List::AllUtils>, L<List::UtilsBy> + +=head1 AUTHOR + +Jens Rehsack E<lt>rehsack AT cpan.orgE<gt> + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt> + +=head1 COPYRIGHT AND LICENSE + +Some parts copyright 2011 Aaron Crane. + +Copyright 2004 - 2010 by Tassilo von Parseval + +Copyright 2013 - 2015 by Jens Rehsack + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.4 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +1; diff --git a/lib/List/MoreUtils/Contributing.pod b/lib/List/MoreUtils/Contributing.pod new file mode 100644 index 0000000..510cf29 --- /dev/null +++ b/lib/List/MoreUtils/Contributing.pod @@ -0,0 +1,88 @@ +=head1 NAME + +List::MoreUtils::Contributing - Gives rough introduction into contributing to List::MoreUtils + +=head1 DESCRIPTION + +List::Moreutils has a turbulent history and a strong approach. Before +going further, please step to +L<Open Source Contribution Etiquette|http://tirania.org/blog/archive/2010/Dec-31.html> +and then come back. + +The current distribution is a balance between finishing the history and +claiming for future requirements. Therefore some components will receive +a rewrite on purpose - others wont. + +For the moment - it's not the primary goal to clean up the configuration +stage, until the primary goals and prerequisites are done. + +To contribute to List::MoreUtils, one has to arrange with the current +situation, dig into details and ask for clarifying when parts are +incomprehensible. + +=head2 Primary Goals + +The very first primary goal is to clear the backlog. These are primarily +the open issues, feature requests and missing infrastructure elements. + +As example see RT#93207 or RT#75672 for missing configure time checks, +while RT#93207 radiates until test - but doesn't affect runtime nor +installation (beside test failures). + +=head2 Secondary Goals + +Secondary goals are harmonizing the function names and calling convention +(see RT#102673), tidying the infrastructure of the distribution and remove +unnecessary complexity (while protecting the necessary). + +One example of removing unnessesary infrastructure could be to move +L<Data::Tumbler> and L<Test::WriteVariants> into authoring mode, when +imrpoved test for RT#93207 could be reasonably done by a module which +is recommended for test. The recommendation of +L<Graham Knop's Makefile.PL#L82|https://github.com/haarg/List-MoreUtils/blob/dd877f963deead742fc90005636c72c6be9060fc/Makefile.PL#L82> +in L<PR#9|https://github.com/perl5-utils/List-MoreUtils/pull/9> a desirable +one. + +=head2 Orientation Guide + +List::MoreUtils configuration stage heavily depends on L<Config::AutoConf> +and L<Data::Tumbler>. A few prerequisites of both modules aren't available +for Perl 5.6 - which leads to a tiny emulation layer t the begin of +C<Makefile.PL>. + +The reason for L<Config::AutoConf> is quite simple - the opportunities +for checking the environment cover a much wider range than a simple test +whether there is a working compiler. It requires a lot of improvements +since it's fundament L<ExtUtils::CBuilder> was never designed to support +that kind of solutions - but there is I<Work In Progress>. To finally +solve issues as RT#75672 even in cross-compile environments - there is +no way around such a checking tool. + +The reason for L<Data::Tumbler> in combination with L<Test::WriteVariants> +are extensible tests with reasonable effort and easy figuring out which +extra condition causes failures. Also - missing pre-conditions should +result in failing tests i some cases - what is fully supported by the +logic behind L<Data::Tumbler> in combination with L<Test::WriteVariants>. + +Finally - L<inc::latest> glues the stuff in a bundle together to allow +people with older toolchains to use List::MoreUtils out of the box (maybe +with reduced quantity but full quality). + +=head1 SEE ALSO + +L<Config::AutoConf>, L<Data::Tumbler>, L<Test::WriteVariants>, +L<ExtUtils::MakeMaker::Extensions> + +=head1 AUTHOR + +Jens Rehsack E<lt>rehsack AT cpan.orgE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2015 by Jens Rehsack + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.4 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/List/MoreUtils/PP.pm b/lib/List/MoreUtils/PP.pm new file mode 100644 index 0000000..e1bcf24 --- /dev/null +++ b/lib/List/MoreUtils/PP.pm @@ -0,0 +1,587 @@ +package List::MoreUtils::PP; + +use 5.006; +use strict; +use warnings; + +our $VERSION = '0.413'; + +=pod + +=head1 NAME + +List::MoreUtils::PP - Provide List::MoreUtils pure Perl implementation + +=head1 SYNOPSIS + + BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } + use List::MoreUtils qw(:all); + +=cut + +sub any (&@) +{ + my $f = shift; + foreach (@_) + { + return 1 if $f->(); + } + return 0; +} + +sub all (&@) +{ + my $f = shift; + foreach (@_) + { + return 0 unless $f->(); + } + return 1; +} + +sub none (&@) +{ + my $f = shift; + foreach (@_) + { + return 0 if $f->(); + } + return 1; +} + +sub notall (&@) +{ + my $f = shift; + foreach (@_) + { + return 1 unless $f->(); + } + return 0; +} + +sub one (&@) +{ + my $f = shift; + my $found = 0; + foreach (@_) + { + $f->() and $found++ and return 0; + } + $found; +} + +sub any_u (&@) +{ + my $f = shift; + return if !@_; + $f->() and return 1 foreach (@_); + return 0; +} + +sub all_u (&@) +{ + my $f = shift; + return if !@_; + $f->() or return 0 foreach (@_); + return 1; +} + +sub none_u (&@) +{ + my $f = shift; + return if !@_; + $f->() and return 0 foreach (@_); + return 1; +} + +sub notall_u (&@) +{ + my $f = shift; + return if !@_; + $f->() or return 1 foreach (@_); + return 0; +} + +sub one_u (&@) +{ + my $f = shift; + return if !@_; + my $found = 0; + foreach (@_) + { + $f->() and $found++ and return 0; + } + $found; +} + +sub true (&@) +{ + my $f = shift; + my $count = 0; + $f->() and ++$count foreach (@_); + return $count; +} + +sub false (&@) +{ + my $f = shift; + my $count = 0; + $f->() or ++$count foreach (@_); + return $count; +} + +sub firstidx (&@) +{ + my $f = shift; + foreach my $i ( 0 .. $#_ ) + { + local *_ = \$_[$i]; + return $i if $f->(); + } + return -1; +} + +sub firstval (&@) +{ + my $test = shift; + foreach (@_) + { + return $_ if $test->(); + } + return undef; +} + +sub firstres (&@) +{ + my $test = shift; + foreach (@_) + { + my $testval = $test->(); + $testval and return $testval; + } + return undef; +} + +sub onlyidx (&@) +{ + my $f = shift; + my $found; + foreach my $i ( 0 .. $#_ ) + { + local *_ = \$_[$i]; + $f->() or next; + defined $found and return -1; + $found = $i; + } + return defined $found ? $found : -1; +} + +sub onlyval (&@) +{ + my $test = shift; + my $result = undef; + my $found = 0; + foreach (@_) + { + $test->() or next; + $result = $_; + $found++ and return undef; + } + return $result; +} + +sub onlyres (&@) +{ + my $test = shift; + my $result = undef; + my $found = 0; + foreach (@_) + { + my $rv = $test->() or next; + $result = $rv; + $found++ and return undef; + } + return $found ? $result : undef; +} + +sub lastidx (&@) +{ + my $f = shift; + foreach my $i ( reverse 0 .. $#_ ) + { + local *_ = \$_[$i]; + return $i if $f->(); + } + return -1; +} + +sub lastval (&@) +{ + my $test = shift; + my $ix; + for ( $ix = $#_; $ix >= 0; $ix-- ) + { + local *_ = \$_[$ix]; + my $testval = $test->(); + + # Simulate $_ as alias + $_[$ix] = $_; + return $_ if $testval; + } + return undef; +} + +sub lastres (&@) +{ + my $test = shift; + my $ix; + for ( $ix = $#_; $ix >= 0; $ix-- ) + { + local *_ = \$_[$ix]; + my $testval = $test->(); + + # Simulate $_ as alias + $_[$ix] = $_; + return $testval if $testval; + } + return undef; +} + +sub insert_after (&$\@) +{ + my ( $f, $val, $list ) = @_; + my $c = &firstidx( $f, @$list ); + @$list = ( @{$list}[ 0 .. $c ], $val, @{$list}[ $c + 1 .. $#$list ], ) and return 1 if $c != -1; + return 0; +} + +sub insert_after_string ($$\@) +{ + my ( $string, $val, $list ) = @_; + my $c = firstidx { defined $_ and $string eq $_ } @$list; + @$list = ( @{$list}[ 0 .. $c ], $val, @{$list}[ $c + 1 .. $#$list ], ) and return 1 if $c != -1; + return 0; +} + +sub apply (&@) +{ + my $action = shift; + &$action foreach my @values = @_; + wantarray ? @values : $values[-1]; +} + +sub after (&@) +{ + my $test = shift; + my $started; + my $lag; + grep $started ||= do + { + my $x = $lag; + $lag = $test->(); + $x; + }, @_; +} + +sub after_incl (&@) +{ + my $test = shift; + my $started; + grep $started ||= $test->(), @_; +} + +sub before (&@) +{ + my $test = shift; + my $more = 1; + grep $more &&= !$test->(), @_; +} + +sub before_incl (&@) +{ + my $test = shift; + my $more = 1; + my $lag = 1; + grep $more &&= do + { + my $x = $lag; + $lag = !$test->(); + $x; + }, @_; +} + +sub indexes (&@) +{ + my $test = shift; + grep { + local *_ = \$_[$_]; + $test->() + } 0 .. $#_; +} + +sub pairwise (&\@\@) +{ + my $op = shift; + + # Symbols for caller's input arrays + use vars qw{ @A @B }; + local ( *A, *B ) = @_; + + # Localise $a, $b + my ( $caller_a, $caller_b ) = do + { + my $pkg = caller(); + no strict 'refs'; + \*{ $pkg . '::a' }, \*{ $pkg . '::b' }; + }; + + # Loop iteration limit + my $limit = $#A > $#B ? $#A : $#B; + + # This map expression is also the return value + local ( *$caller_a, *$caller_b ); + map { + # Assign to $a, $b as refs to caller's array elements + ( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] ); + + # Perform the transformation + $op->(); + } 0 .. $limit; +} + +sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) +{ + return each_arrayref(@_); +} + +sub each_arrayref +{ + my @list = @_; # The list of references to the arrays + my $index = 0; # Which one the caller will get next + my $max = 0; # Number of elements in longest array + + # Get the length of the longest input array + foreach (@list) + { + unless ( ref $_ eq 'ARRAY' ) + { + require Carp; + Carp::croak("each_arrayref: argument is not an array reference\n"); + } + $max = @$_ if @$_ > $max; + } + + # Return the iterator as a closure wrt the above variables. + return sub { + if (@_) + { + my $method = shift; + unless ( $method eq 'index' ) + { + require Carp; + Carp::croak("each_array: unknown argument '$method' passed to iterator."); + } + + # Return current (last fetched) index + return undef if $index == 0 || $index > $max; + return $index - 1; + } + + # No more elements to return + return if $index >= $max; + my $i = $index++; + + # Return ith elements + return map $_->[$i], @list; + } +} + +sub natatime ($@) +{ + my $n = shift; + my @list = @_; + return sub { + return splice @list, 0, $n; + } +} + +sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) +{ + my $max = -1; + $max < $#$_ && ( $max = $#$_ ) foreach @_; + map { + my $ix = $_; + map $_->[$ix], @_; + } 0 .. $max; +} + +sub uniq (@) +{ + my %seen = (); + my $k; + my $seen_undef; + grep { defined $_ ? not $seen{ $k = $_ }++ : not $seen_undef++ } @_; +} + +sub singleton (@) +{ + my %seen = (); + my $k; + my $seen_undef; + grep { 1 == ( defined $_ ? $seen{ $k = $_ } : $seen_undef ) } + grep { defined $_ ? not $seen{ $k = $_ }++ : not $seen_undef++ } @_; +} + +sub minmax (@) +{ + return unless @_; + my $min = my $max = $_[0]; + + for ( my $i = 1; $i < @_; $i += 2 ) + { + if ( $_[ $i - 1 ] <= $_[$i] ) + { + $min = $_[ $i - 1 ] if $min > $_[ $i - 1 ]; + $max = $_[$i] if $max < $_[$i]; + } + else + { + $min = $_[$i] if $min > $_[$i]; + $max = $_[ $i - 1 ] if $max < $_[ $i - 1 ]; + } + } + + if ( @_ & 1 ) + { + my $i = $#_; + if ( $_[ $i - 1 ] <= $_[$i] ) + { + $min = $_[ $i - 1 ] if $min > $_[ $i - 1 ]; + $max = $_[$i] if $max < $_[$i]; + } + else + { + $min = $_[$i] if $min > $_[$i]; + $max = $_[ $i - 1 ] if $max < $_[ $i - 1 ]; + } + } + + return ( $min, $max ); +} + +sub part (&@) +{ + my ( $code, @list ) = @_; + my @parts; + push @{ $parts[ $code->($_) ] }, $_ foreach @list; + return @parts; +} + +sub bsearch(&@) +{ + my $code = shift; + + my $rc; + my $i = 0; + my $j = @_; + do + { + my $k = int( ( $i + $j ) / 2 ); + + $k >= @_ and return; + + local *_ = \$_[$k]; + $rc = $code->(); + + $rc == 0 + and return wantarray ? $_ : 1; + + if ( $rc < 0 ) + { + $i = $k + 1; + } + else + { + $j = $k - 1; + } + } until $i > $j; + + return; +} + +sub bsearchidx(&@) +{ + my $code = shift; + + my $rc; + my $i = 0; + my $j = @_; + do + { + my $k = int( ( $i + $j ) / 2 ); + + $k >= @_ and return -1; + + local *_ = \$_[$k]; + $rc = $code->(); + + $rc == 0 and return $k; + + if ( $rc < 0 ) + { + $i = $k + 1; + } + else + { + $j = $k - 1; + } + } until $i > $j; + + return -1; +} + +sub sort_by(&@) +{ + my ( $code, @list ) = @_; + return map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [ $_, scalar( $code->() ) ] } @list; +} + +sub nsort_by(&@) +{ + my ( $code, @list ) = @_; + return map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, scalar( $code->() ) ] } @list; +} + +sub _XScompiled { 0 } + +=head1 SEE ALSO + +L<List::Util> + +=head1 AUTHOR + +Jens Rehsack E<lt>rehsack AT cpan.orgE<gt> + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt> + +=head1 COPYRIGHT AND LICENSE + +Some parts copyright 2011 Aaron Crane. + +Copyright 2004 - 2010 by Tassilo von Parseval + +Copyright 2013 - 2015 by Jens Rehsack + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.4 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +1; diff --git a/lib/List/MoreUtils/XS.pm b/lib/List/MoreUtils/XS.pm new file mode 100644 index 0000000..2beeded --- /dev/null +++ b/lib/List/MoreUtils/XS.pm @@ -0,0 +1,81 @@ +package List::MoreUtils::XS; + +use 5.006; +use strict; +use warnings; + +use vars qw{$VERSION @ISA}; + +BEGIN +{ + $VERSION = '0.413'; + + # Load the XS at compile-time so that redefinition warnings will be + # thrown correctly if the XS versions of part or indexes loaded + my $ldr = <<EOLDR; + package List::MoreUtils; + + # PERL_DL_NONLAZY must be false, or any errors in loading will just + # cause the perl code to be tested + local \$ENV{PERL_DL_NONLAZY} = 0 if \$ENV{PERL_DL_NONLAZY}; + + use XSLoader (); + XSLoader::load("List::MoreUtils", "$VERSION"); + + 1; +EOLDR + + eval $ldr unless $ENV{LIST_MOREUTILS_PP}; + + # ensure to catch even PP only subs + my @pp_imp = map { "List::MoreUtils->can(\"$_\") or *$_ = \\&List::MoreUtils::PP::$_;" } + qw(any all none notall one any_u all_u none_u notall_u one_u true false + firstidx firstval firstres lastidx lastval lastres onlyidx onlyval onlyres + insert_after insert_after_string + apply after after_incl before before_incl + each_array each_arrayref pairwise + natatime mesh uniq singleton minmax part indexes bsearch bsearchidx + sort_by nsort_by _XScompiled); + my $pp_stuff = join( "\n", "use List::MoreUtils::PP;", "package List::MoreUtils;", @pp_imp ); + eval $pp_stuff; + die $@ if $@; +} + +=pod + +=head1 NAME + +List::MoreUtils::XS - Provide compiled List::MoreUtils functions + +=head1 SYNOPSIS + + BEGIN { delete $ENV{LIST_MOREUTILS_PP}; } + use List::MoreUtils ...; + +=head1 SEE ALSO + +L<List::Util>, L<List::AllUtils> + +=head1 AUTHOR + +Jens Rehsack E<lt>rehsack AT cpan.orgE<gt> + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt> + +=head1 COPYRIGHT AND LICENSE + +Some parts copyright 2011 Aaron Crane. + +Copyright 2004 - 2010 by Tassilo von Parseval + +Copyright 2013 - 2015 by Jens Rehsack + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.4 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +1; diff --git a/multicall.h b/multicall.h new file mode 100644 index 0000000..fb40fa7 --- /dev/null +++ b/multicall.h @@ -0,0 +1,165 @@ +/* multicall.h (version 1.0) + * + * Implements a poor-man's MULTICALL interface for old versions + * of perl that don't offer a proper one. Intended to be compatible + * with 5.6.0 and later. + * + */ + +#ifdef dMULTICALL +#define REAL_MULTICALL +#else +#undef REAL_MULTICALL + +/* In versions of perl where MULTICALL is not defined (i.e. prior + * to 5.9.4), Perl_pad_push is not exported either. It also has + * an extra argument in older versions; certainly in the 5.8 series. + * So we redefine it here. + */ + +#ifndef AVf_REIFY +# ifdef SVpav_REIFY +# define AVf_REIFY SVpav_REIFY +# else +# error Neither AVf_REIFY nor SVpav_REIFY is defined +# endif +#endif + +#ifndef AvFLAGS +# define AvFLAGS SvFLAGS +#endif + +static void +multicall_pad_push(pTHX_ AV *padlist, int depth) +{ + if (depth <= AvFILLp(padlist)) + return; + + { + SV** const svp = AvARRAY(padlist); + AV* const newpad = newAV(); + SV** const oldpad = AvARRAY(svp[depth-1]); + I32 ix = AvFILLp((AV*)svp[1]); + const I32 names_fill = AvFILLp((AV*)svp[0]); + SV** const names = AvARRAY(svp[0]); + AV *av; + + for ( ;ix > 0; ix--) { + if (names_fill >= ix && names[ix] != &PL_sv_undef) { + const char sigil = SvPVX(names[ix])[0]; + if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') { + /* outer lexical or anon code */ + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { /* our own lexical */ + SV *sv; + if (sigil == '@') + sv = (SV*)newAV(); + else if (sigil == '%') + sv = (SV*)newHV(); + else + sv = NEWSV(0, 0); + av_store(newpad, ix, sv); + SvPADMY_on(sv); + } + } + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { + /* save temporaries on recursion? */ + SV * const sv = NEWSV(0, 0); + av_store(newpad, ix, sv); + SvPADTMP_on(sv); + } + } + av = newAV(); + av_extend(av, 0); + av_store(newpad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + + av_store(padlist, depth, (SV*)newpad); + AvFILLp(padlist) = depth; + } +} + +#define dMULTICALL \ + SV **newsp; /* set by POPBLOCK */ \ + PERL_CONTEXT *cx; \ + CV *multicall_cv; \ + OP *multicall_cop; \ + bool multicall_oldcatch; \ + U8 hasargs = 0 + +/* Between 5.9.1 and 5.9.2 the retstack was removed, and the + return op is now stored on the cxstack. */ +#define HAS_RETSTACK (\ + PERL_REVISION < 5 || \ + (PERL_REVISION == 5 && PERL_VERSION < 9) || \ + (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \ +) + + +/* PUSHSUB is defined so differently on different versions of perl + * that it's easier to define our own version than code for all the + * different possibilities. + */ +#if HAS_RETSTACK +# define PUSHSUB_RETSTACK(cx) +#else +# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop; +#endif +#define MULTICALL_PUSHSUB(cx, the_cv) \ + cx->blk_sub.cv = the_cv; \ + cx->blk_sub.olddepth = CvDEPTH(the_cv); \ + cx->blk_sub.hasargs = hasargs; \ + cx->blk_sub.lval = PL_op->op_private & \ + (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ + PUSHSUB_RETSTACK(cx) \ + if (!CvDEPTH(the_cv)) { \ + (void)SvREFCNT_inc(the_cv); \ + (void)SvREFCNT_inc(the_cv); \ + SAVEFREESV(the_cv); \ + } + +#define PUSH_MULTICALL(the_cv) \ + STMT_START { \ + CV *_nOnclAshIngNamE_ = the_cv; \ + AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \ + multicall_cv = _nOnclAshIngNamE_; \ + ENTER; \ + multicall_oldcatch = CATCH_GET; \ + SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \ + CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ + SAVETMPS; SAVEVPTR(PL_op); \ + CATCH_SET(TRUE); \ + PUSHSTACKi(PERLSI_SORT); \ + PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ + MULTICALL_PUSHSUB(cx, multicall_cv); \ + if (++CvDEPTH(multicall_cv) >= 2) { \ + PERL_STACK_OVERFLOW_CHECK(); \ + multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \ + } \ + SAVECOMPPAD(); \ + PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \ + PL_curpad = AvARRAY(PL_comppad); \ + multicall_cop = CvSTART(multicall_cv); \ + } STMT_END + +#define MULTICALL \ + STMT_START { \ + PL_op = multicall_cop; \ + CALLRUNOPS(aTHX); \ + } STMT_END + +#define POP_MULTICALL \ + STMT_START { \ + CvDEPTH(multicall_cv)--; \ + LEAVESUB(multicall_cv); \ + POPBLOCK(cx,PL_curpm); \ + POPSTACK; \ + CATCH_SET(multicall_oldcatch); \ + LEAVE; \ + SPAGAIN; \ + } STMT_END +#endif diff --git a/ppport.h b/ppport.h new file mode 100644 index 0000000..1be43ef --- /dev/null +++ b/ppport.h @@ -0,0 +1,7748 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.31 + + Automatically created by Devel::PPPort running under perl 5.020002. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.31 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.20. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F<ppport.h>. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagically add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions or variables will be marked C<explicit> in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C<static> or global +variants. + +For a C<static> function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C<DPPP_NAMESPACE> +macro. Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report here: L<https://github.com/mhx/Devel-PPPort/issues/> + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.31; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +ASCII_TO_NEED||5.007001|n +AvFILLp|5.004050||p +AvFILL||| +BhkDISABLE||5.021008| +BhkENABLE||5.021008| +BhkENTRY_set||5.021008| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002|5.004050|p +Copy||| +CvPADLIST||5.008001| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvAV||| +GvCV||| +GvHV||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY|5.003070||p +HeHASH||5.003070| +HeKEY||5.003070| +HeKLEN||5.003070| +HePV||5.004000| +HeSVKEY_force||5.003070| +HeSVKEY_set||5.004000| +HeSVKEY||5.003070| +HeUTF8|5.010001|5.008000|p +HeVAL||5.003070| +HvENAMELEN||5.015004| +HvENAMEUTF8||5.015004| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAMELEN||5.015004| +HvNAMEUTF8||5.015004| +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.021008| +MUTABLE_PTR|5.010001||p +MUTABLE_SV|5.010001||p +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002|5.004050|p +Move||| +NATIVE_TO_NEED||5.007001|n +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +OP_TYPE_IS_OR_WAS||5.019010| +OP_TYPE_IS||5.019007| +ORIGMARK||| +OpHAS_SIBLING||5.021007| +OpSIBLING_set||5.021007| +OpSIBLING||5.021007| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.021008||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.003070||p +PERL_INT_MAX|5.003070||p +PERL_INT_MIN|5.003070||p +PERL_LONG_MAX|5.003070||p +PERL_LONG_MIN|5.003070||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.021008||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.021008||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.021008||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.021008||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.003070||p +PERL_QUAD_MIN|5.003070||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.003070||p +PERL_SHORT_MIN|5.003070||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.021008| +PERL_UCHAR_MAX|5.003070||p +PERL_UCHAR_MIN|5.003070||p +PERL_UINT_MAX|5.003070||p +PERL_UINT_MIN|5.003070||p +PERL_ULONG_MAX|5.003070||p +PERL_ULONG_MIN|5.003070||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.003070||p +PERL_UQUAD_MIN|5.003070||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.003070||p +PERL_USHORT_MIN|5.003070||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.021008||p +PL_bufptr|5.021008||p +PL_check||5.006000| +PL_compiling|5.004050||p +PL_comppad_name||5.017004| +PL_comppad||5.008001| +PL_copline|5.021008||p +PL_curcop|5.004050||p +PL_curpad||5.005000| +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.021008||p +PL_expect|5.021008||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.021008||p +PL_in_my|5.021008||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.021008||p +PL_lex_stuff|5.021008||p +PL_linestr|5.021008||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005||p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.021008||p +PL_rsfp|5.021008||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.021008||p +POP_MULTICALL||5.021008| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.021008| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PadARRAY||5.021008| +PadMAX||5.021008| +PadlistARRAY||5.021008| +PadlistMAX||5.021008| +PadlistNAMESARRAY||5.021008| +PadlistNAMESMAX||5.021008| +PadlistNAMES||5.021008| +PadlistREFCNT||5.017004| +PadnameIsOUR||| +PadnameIsSTATE||| +PadnameLEN||5.021008| +PadnameOURSTASH||| +PadnameOUTER||| +PadnamePV||5.021008| +PadnameREFCNT_dec||5.021008| +PadnameREFCNT||5.021008| +PadnameSV||5.021008| +PadnameTYPE||| +PadnameUTF8||5.021007| +PadnamelistARRAY||5.021008| +PadnamelistMAX||5.021008| +PadnamelistREFCNT_dec||5.021008| +PadnamelistREFCNT||5.021008| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_restore_errno||| +PerlIO_save_errno||| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +READ_XDIGIT||5.017006| +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_INVLIST||5.019002| +SVt_IV||| +SVt_NULL||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVFM||| +SVt_PVGV||| +SVt_PVHV||| +SVt_PVIO||| +SVt_PVIV||| +SVt_PVLV||| +SVt_PVMG||| +SVt_PVNV||| +SVt_PV||| +SVt_REGEXP||5.011000| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_ro||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen|5.013007||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec_NN||5.017007| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTHINKFIRST||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.021008||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +WIDEST_UTYPE|5.015004||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.021008| +XS_EXTERNAL||5.021008| +XS_INTERNAL||5.021008| +XS_VERSION_BOOTCHECK||5.021008| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.021008| +XopENABLE||5.021008| +XopENTRYCUSTOM||5.021008| +XopENTRY_set||5.021008| +XopENTRY||5.021008| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_add_range_to_invlist||| +_append_range_to_invlist||| +_core_swash_init||| +_get_encoding||| +_get_regclass_nonbitmap_data||| +_get_swash_invlist||| +_invlist_array_init|||n +_invlist_contains_cp|||n +_invlist_contents||| +_invlist_dump||| +_invlist_intersection_maybe_complement_2nd||| +_invlist_intersection||| +_invlist_invert||| +_invlist_len|||n +_invlist_populate_swatch|||n +_invlist_search|||n +_invlist_subtract||| +_invlist_union_maybe_complement_2nd||| +_invlist_union||| +_is_cur_LC_category_utf8||| +_is_in_locale_category||5.021001| +_is_uni_FOO||5.017008| +_is_uni_perl_idcont||5.017008| +_is_uni_perl_idstart||5.017007| +_is_utf8_FOO||5.017008| +_is_utf8_char_slow||5.021001|n +_is_utf8_idcont||5.021001| +_is_utf8_idstart||5.021001| +_is_utf8_mark||5.017008| +_is_utf8_perl_idcont||5.017008| +_is_utf8_perl_idstart||5.017007| +_is_utf8_xidcont||5.021001| +_is_utf8_xidstart||5.021001| +_load_PL_utf8_foldclosures||| +_make_exactf_invlist||| +_new_invlist_C_array||| +_new_invlist||| +_pMY_CXT|5.007003||p +_setup_canned_invlist||| +_swash_inversion_hash||| +_swash_to_invlist||| +_to_fold_latin1||| +_to_uni_fold_flags||5.014000| +_to_upper_title_latin1||| +_to_utf8_fold_flags||5.019009| +_to_utf8_lower_flags||5.019009| +_to_utf8_title_flags||5.019009| +_to_utf8_upper_flags||5.019009| +_warn_problematic_locale|||n +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.021008||p +aTHXR|5.021008||p +aTHX_|5.006000||p +aTHX|5.006000||p +aassign_common_vars||| +add_above_Latin1_folds||| +add_cp_to_invlist||| +add_data|||n +add_multi_match||| +add_utf16_textfilter||| +adjust_size_and_find_bucket|||n +advance_one_SB||| +advance_one_WB||| +alloc_maybe_populate_EXACT||| +alloccopstash||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_is_enabled||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_utf8_from_native_byte||5.019004|n +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +assignment_type||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend_guts||| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_tindex||5.017009| +av_top_index||5.017009| +av_undef||| +av_unshift||| +ax|||n +backup_one_SB||| +backup_one_WB||| +bad_type_gv||| +bad_type_pv||| +bind_match||| +block_end||5.004000| +block_gimme||5.004000| +block_start||5.004000| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx|5.013005|5.006000|p +calloc||5.007002|n +cando||| +cast_i32||5.006000|n +cast_iv||5.006000|n +cast_ulong||5.006000|n +cast_uv||5.006000|n +check_locale_boundary_crossing||| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +ckWARN|5.006000||p +ck_entersub_args_core||| +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +clear_placeholders||| +clear_special_blocks||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +cntrl_to_mnemonic|||n +compute_EXACTish|||n +construct_ahocorasick_from_trie||| +cop_fetch_label||5.015001| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cop_store_label||5.015001| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.021008| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +core_prototype||| +coresub_op||| +could_it_be_a_POSIX_class|||n +cr_textfilter||| +create_eval_scope||| +croak_memory_wrap||5.019003|n +croak_no_mem|||n +croak_no_modify||5.013003|n +croak_nocontext|||vn +croak_popstack|||n +croak_sv||5.013001| +croak_xs_usage||5.010001|n +croak|||v +csighandler||5.009003|n +current_re_engine||| +curse||| +custom_op_desc||5.007003| +custom_op_get_field||| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len_flags||| +cv_clone_into||| +cv_clone||| +cv_const_sv_or_av|||n +cv_const_sv||5.003070|n +cv_dump||| +cv_forget_slab||| +cv_get_call_checker||5.013006| +cv_name||5.021005| +cv_set_call_checker_flags||5.021004| +cv_set_call_checker||5.013006| +cv_undef_flags||| +cv_undef||| +cvgv_from_hek||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.021008||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +defelem_target||| +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_ncmp||| +do_oddball||| +do_op_dump||5.006000| +do_open6||| +do_open9||5.006000| +do_open_raw||| +do_openn||5.007001| +do_open||5.003070| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +drand48_init_r|||n +drand48_r|||n +dump_all_perl||| +dump_all||5.006000| +dump_c_backtrace||| +dump_eval||5.006000| +dump_exec_pos||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +finalize_optree||| +finalize_op||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_default_stash||| +find_hash_subscript||| +find_in_my_stash||| +find_lexical_cv||| +find_runcv_where||| +find_runcv||5.008001| +find_rundefsv2||| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +fixup_errno_string||| +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident_maybe_lex||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form_short_octal_warning||| +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_c_backtrace||| +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_ANYOF_cp_list_for_ssc||| +get_and_check_backslash_N_name||| +get_aux_mg||| +get_av|5.006000||p +get_c_backtrace_dump||| +get_c_backtrace||| +get_context||5.006000|n +get_cvn_flags|5.009005||p +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_invlist_iter_addr|||n +get_invlist_offset_addr|||n +get_invlist_previous_index_addr|||n +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +gp_dup||| +gp_free||| +gp_ref||| +grok_atoUV|||n +grok_bin|5.007003||p +grok_bslash_N||| +grok_bslash_c||| +grok_bslash_o||| +grok_bslash_x||| +grok_hex|5.007003||p +grok_infnan||5.021004| +grok_number_flags||5.021002| +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_autoload_pvn||5.015004| +gv_autoload_pv||5.015004| +gv_autoload_sv||5.015004| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.003070| +gv_efullname4||5.006001| +gv_efullname||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmeth_internal||| +gv_fetchmeth_pv_autoload||5.015004| +gv_fetchmeth_pvn_autoload||5.015004| +gv_fetchmeth_pvn||5.015004| +gv_fetchmeth_pv||5.015004| +gv_fetchmeth_sv_autoload||5.015004| +gv_fetchmeth_sv||5.015004| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_pv_flags||5.015004| +gv_fetchmethod_pvn_flags||5.015004| +gv_fetchmethod_sv_flags||5.015004| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.003070| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_pvn||5.015004| +gv_init_pv||5.015004| +gv_init_svtype||| +gv_init_sv||5.015004| +gv_init||| +gv_is_in_main||| +gv_magicalize_isa||| +gv_magicalize||| +gv_name_set||5.009004| +gv_override||| +gv_setref||| +gv_stashpvn_internal||| +gv_stashpvn|5.003070||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsvpvn_cached||| +gv_stashsv||| +gv_try_downgrade||| +handle_regex_sets||| +he_dup||| +hek_dup||| +hfree_next_entry||| +hfreeentries||| +hsplit||| +hv_assert||| +hv_auxinit_internal|||n +hv_auxinit||| +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.003070| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.003070| +hv_exists||| +hv_fetch_ent||5.003070| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent_ret||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.003070| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.003070| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||| +hv_placeholders_set||5.009003| +hv_rand_set||5.018000| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.003070| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_constants||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +inplace_aassign||| +instr|||n +intro_my||5.004000| +intuit_method||| +intuit_more||| +invert||| +invlist_array|||n +invlist_clone||| +invlist_extend||| +invlist_highest|||n +invlist_is_iterating|||n +invlist_iterfinish|||n +invlist_iterinit|||n +invlist_iternext|||n +invlist_max|||n +invlist_previous_index|||n +invlist_set_len||| +invlist_set_previous_index|||n +invlist_trim|||n +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALNUM_lazy||5.021001| +isALPHANUMERIC||5.017008| +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +isFOO_lc||| +isFOO_utf8_lc||| +isGCB|||n +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isIDCONT||5.017008| +isIDFIRST_lazy||5.021001| +isIDFIRST||| +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSB||| +isSPACE||| +isUPPER||| +isUTF8_CHAR||5.021001| +isWB||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000| +is_handle_constructor|||n +is_invariant_string||5.021007|n +is_lvalue_sub||5.007001| +is_safe_syscall||5.019004| +is_ssc_worth_it|||n +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.017007| +is_uni_alnumc||5.017007| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_blank_lc||5.017002| +is_uni_blank||5.017002| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.017007| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_blank||5.017002| +is_utf8_char_buf||5.015008|n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +isinfnansv||| +isinfnan||5.021004|n +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_common||| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_cleararylen_p||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_copycallchecker||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdebugvar||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdebugvar||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setlvref||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||5.021001| +matcher_matches_sv||| +maybe_multimagic_gv||| +mayberelocate||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess_sv||5.013001| +mess||5.006000|v +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find_mglob||| +mg_findext|5.013008||pn +mg_find|||n +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical|||n +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002|n +minus_v||| +missingterm||| +mode_from_discipline||| +modkids||| +more_bodies||| +more_sv||| +moreswitches||| +move_proto_attr||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +multideref_stringify||| +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_bytes_to_utf8|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005|n +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_kid||| +my_lstat_flags||| +my_lstat||5.021008| +my_memcmp|||n +my_memset|||n +my_pclose||5.003070| +my_popen_list||5.007001| +my_popen||5.003070| +my_setenv||| +my_setlocale||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.021008| +my_strerror||5.021001| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB_x||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB_flags||5.015006| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||5.021006| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen_flags||5.015004| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMETHOP_internal||| +newMETHOP_named||5.021005| +newMETHOP||5.021005| +newMYSUB||5.017004| +newNULLLIST||| +newOP||| +newPADNAMELIST||5.021007|n +newPADNAMEouter||5.021007|n +newPADNAMEpvn||5.021007|n +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSTUB||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVavdefelem||| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpadname||5.017004| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP_AUX||5.021007| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_deffile||| +newXS_flags||5.009004| +newXS_len_flags||| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +noperl_die|||vn +not_a_number||| +not_incrementable||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_contextualize||5.013006| +op_convert_list||5.021006| +op_dump||5.006000| +op_free||| +op_integerize||| +op_linklist||5.013006| +op_lvalue_flags||| +op_lvalue||5.013007| +op_null||5.007002| +op_parent||5.021002|n +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_relocate_sv||| +op_scope||5.013007| +op_sibling_splice||5.021002|n +op_std_init||| +op_unscope||| +open_script||| +openn_cleanup||| +openn_setup||| +opmethod_stash||| +opslab_force_free||| +opslab_free_nopad||| +opslab_free||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||5.008001| +pad_add_name_pvn||5.015001| +pad_add_name_pvs||5.015001| +pad_add_name_pv||5.015001| +pad_add_name_sv||5.015001| +pad_add_weakref||| +pad_alloc_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||5.009003| +pad_findlex||| +pad_findmy_pvn||5.015001| +pad_findmy_pvs||5.015001| +pad_findmy_pv||5.015001| +pad_findmy_sv||5.015001| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||5.008001| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||5.008001| +padlist_dup||| +padlist_store||| +padname_dup||| +padname_free||| +padnamelist_dup||| +padnamelist_fetch||5.021007|n +padnamelist_free||| +padnamelist_store||5.021007| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_gv_stash_name||| +parse_ident||| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_lparen_question_flags||| +parse_stmtseq||5.013006| +parse_subsignature||| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free_nexttoke_ops||| +parser_free||| +path_is_searchable|||n +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +populate_ANYOF_from_invlist||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_hash|||n +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_charclass_bitmap_innards||| +put_code_point||| +put_range||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +quadmath_format_needed|||n +quadmath_format_single|||n +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.019001| +re_intuit_string||5.006000| +re_op_compile||| +realloc||5.007002|n +reentrant_free||5.021008| +reentrant_init||5.021008| +reentrant_retry||5.021008|vn +reentrant_size||5.021008| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.021008| +reg2Lanode||| +reg_check_named_buff_matched|||n +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment|||n +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly|||n +regdump_extflags||| +regdump_intflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regnode_guts||| +regpatws|||n +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reg||| +repeatcpy|||n +report_evil_fh||| +report_redefined_cv||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem_flags||5.011000| +save_aelem||5.004050| +save_aliased_sv||| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic_flags||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_strlen||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +search_const||| +seed||5.008001| +sequence_num||| +set_ANYOF_arg||| +set_caret_X||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +set_padlist|||n +setdefout||| +share_hek_flags||| +share_hek||5.004000| +should_warn_nl|||n +si_dup||| +sighandler|||n +simplify_sort||| +skipspace_flags||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +ssc_add_range||| +ssc_and||| +ssc_anything||| +ssc_clear_locale|||n +ssc_cp_and||| +ssc_finalize||| +ssc_init||| +ssc_intersection||| +ssc_is_anything|||n +ssc_is_cp_posixl_init|||n +ssc_or||| +ssc_union||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff|||n +sv_bless||| +sv_buf_to_ro||| +sv_buf_to_rw||| +sv_cat_decode||5.008001| +sv_catpv_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_copypv_flags||5.017002| +sv_copypv_nomg||5.017002| +sv_copypv||| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from_pvn||5.015004| +sv_derived_from_pv||5.015004| +sv_derived_from_sv||5.015004| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_display||| +sv_does_pvn||5.015004| +sv_does_pv||5.015004| +sv_does_sv||5.015004| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_get_backrefs||5.021008|n +sv_gets||5.003070| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8_nomg||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.021008|5.004000|p +sv_magicext_mglob||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy_flags||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_only_taint_gmagic|||n +sv_or_pv_pos_u2b||| +sv_peek||5.005000| +sv_pos_b2u_flags||5.019003| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_ref||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_resetpvn||| +sv_reset||| +sv_rvweaken||5.006000| +sv_sethek||| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.021008| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext|5.013008||p +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn_flags||5.017002| +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +swash_scan_list_line||| +swatch_get||| +sync_locale||5.021004| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow_p||| +toFOLD_uni||5.007003| +toFOLD_utf8||5.019001| +toFOLD||5.019001| +toLOWER_L1||5.019001| +toLOWER_LC||5.004000| +toLOWER_uni||5.007003| +toLOWER_utf8||5.015007| +toLOWER||| +toTITLE_uni||5.007003| +toTITLE_utf8||5.015007| +toTITLE||5.019001| +toUPPER_uni||5.007003| +toUPPER_utf8||5.015007| +toUPPER||| +to_byte_substr||| +to_lower_latin1|||n +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.015007| +to_utf8_lower||5.015007| +to_utf8_substr||| +to_utf8_title||5.015007| +to_utf8_upper||5.015007| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments_pv||| +too_many_arguments_pv||| +translate_substr_offsets|||n +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.003070| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000|n +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr_buf||5.015009| +utf8_to_uvchr||5.007001| +utf8_to_uvuni_buf||5.015009| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvoffuni_to_utf8_flags||5.019004| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +valid_utf8_to_uvchr||5.015009| +valid_utf8_to_uvuni||5.015009| +validate_proto||| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warn_sv||5.013001| +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +was_lvalue_sub||| +watch||| +whichsig_pvn||5.015004| +whichsig_pv||5.015004| +whichsig_sv||5.015004| +whichsig||| +win32_croak_not_implemented|||n +with_queued_errors||| +wrap_op_checker||5.015008| +write_to_stderr||| +xs_boot_epilog||| +xs_handshake|||vn +xs_version_bootcheck||| +yyerror_pvn||| +yyerror_pv||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while (<DATA>) { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef LONGSIZE +# define LONGSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef LONGSIZE +# define LONGSIZE 4 +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include <note.h> +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif + +#ifdef HAS_QUAD +# ifdef U64TYPE +# define WIDEST_UTYPE U64TYPE +# else +# define WIDEST_UTYPE Quad_t +# endif +#else +# define WIDEST_UTYPE U32 +#endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +/* Until we figure out how to support this in older perls... */ +#if (PERL_BCDVERSION >= 0x5008000) +#ifndef HeUTF8 +# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#elif (PERL_BCDVERSION > 0x5003000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# elif IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# else +# error "cannot define IV/UV formats" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif + +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif + +/* Some random bits for sv_unmagicext. These should probably be pulled in for + real and organized at some point */ +#ifndef HEf_SVKEY +# define HEf_SVKEY -2 +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +#else +# define MUTABLE_PTR(p) ((void *) (p)) +#endif + +#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) + +/* end of random bits */ +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#if !defined(mg_findext) +#if defined(NEED_mg_findext) +static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +static +#else +extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +#endif + +#define mg_findext DPPP_(my_mg_findext) +#define Perl_mg_findext DPPP_(my_mg_findext) + +#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) + +MAGIC * +DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { + if (sv) { + MAGIC *mg; + +#ifdef AvPAD_NAMELIST + assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); +#endif + + for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && mg->mg_virtual == vtbl) + return mg; + } + } + + return NULL; +} + +#endif +#endif + +#if !defined(sv_unmagicext) +#if defined(NEED_sv_unmagicext) +static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +static +#else +extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +#endif + +#ifdef sv_unmagicext +# undef sv_unmagicext +#endif +#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) +#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) + +#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) + +int +DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) +{ + MAGIC* mg; + MAGIC** mgp; + + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) + return 0; + mgp = &(SvMAGIC(sv)); + for (mg = *mgp; mg; mg = *mgp) { + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && virt == vtbl) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; + } + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } + return 0; +} + +#endif +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ + +#if (PERL_BCDVERSION >= 0x5006000) +#ifndef caller_cx + +# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) +static I32 +DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) +{ + I32 i; + + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT * const cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: + case CXt_FORMAT: + return i; + } + } + return i; +} +# endif + +# if defined(NEED_caller_cx) +static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +static +#else +extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +#endif + +#ifdef caller_cx +# undef caller_cx +#endif +#define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) +#define Perl_caller_cx DPPP_(my_caller_cx) + +#if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) + +const PERL_CONTEXT * +DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) +{ + register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); + register const PERL_CONTEXT *cx; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + + for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) + return NULL; + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + } + + cx = &ccstack[cxix]; + if (dbcxp) *dbcxp = cx; + + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the + field below is defined for any cx. */ + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; + } + + return cx; +} + +# endif +#endif /* caller_cx */ +#endif /* 5.6.0 */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%" UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%" UVxf "}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/t/lib/LMU/Test/Functions.pm b/t/lib/LMU/Test/Functions.pm new file mode 100644 index 0000000..3ef3606 --- /dev/null +++ b/t/lib/LMU/Test/Functions.pm @@ -0,0 +1,1545 @@ +package LMU::Test::Functions; + +use strict; +use warnings; + +use Test::More; +use Test::LMU; +use Tie::Array (); +use List::MoreUtils ':all'; + +use Config; + +my $have_scalar_util; +eval "use Scalar::Util qw(); \$have_scalar_util = 1;"; + +eval "use Storable qw();"; +$@ or Storable->import(qw(freeze)); +__PACKAGE__->can("freeze") or eval <<'EOFR'; +use inc::latest 'JSON::PP'; +use JSON::PP qw(); +sub freeze { + my $json = JSON::PP->new(); + $json->encode($_[0]); +} +EOFR + +# Run all tests +sub run_tests +{ + test_any(); + test_all(); + test_none(); + test_notall(); + test_one(); + test_any_u(); + test_all_u(); + test_none_u(); + test_notall_u(); + test_one_u(); + test_true(); + test_false(); + test_firstidx(); + test_lastidx(); + test_onlyidx(); + test_insert_after(); + test_insert_after_string(); + test_apply(); + test_indexes(); + test_before(); + test_before_incl(); + test_after(); + test_after_incl(); + test_firstval(); + test_lastval(); + test_onlyval(); + test_firstres(); + test_lastres(); + test_onlyres(); + test_each_array(); + test_pairwise(); + test_natatime(); + test_zip(); + test_mesh(); + test_uniq(); + test_singleton(); + test_part(); + test_minmax(); + test_bsearch(); + test_bsearchidx(); + + done_testing(); +} + +###################################################################### +# Test code intentionally ignorant of implementation (Pure Perl or XS) + +# The any function should behave identically to +# !! grep CODE LIST +sub test_any_u +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( any_u { $_ == 5000 } @list ); + is_true( any_u { $_ == 5000 } 1 .. 10000 ); + is_true( any_u { defined } @list ); + is_false( any_u { not defined } @list ); + is_true( any_u { not defined } undef ); + is_undef( any_u {} ); + + leak_free_ok( + any_u => sub { + my $ok = any_u { $_ == 5000 } @list; + my $ok2 = any_u { $_ == 5000 } 1 .. 10000; + } + ); + leak_free_ok( + 'any_u with a coderef that dies' => sub { + # This test is from Kevin Ryde; see RT#48669 + eval { + my $ok = any_u { die } 1; + }; + } + ); + is_dying( sub { &any_u( 42, 4711 ); } ); +} + +sub test_all_u +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( all_u { defined } @list ); + is_true( all_u { $_ > 0 } @list ); + is_false( all_u { $_ < 5000 } @list ); + is_undef( all_u {} ); + + leak_free_ok( + all_u => sub { + my $ok = all_u { $_ == 5000 } @list; + my $ok2 = all_u { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { &all_u( 42, 4711 ); } ); +} + +sub test_none_u +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( none_u { not defined } @list ); + is_true( none_u { $_ > 10000 } @list ); + is_false( none_u { defined } @list ); + is_undef( none_u {} ); + + leak_free_ok( + none_u => sub { + my $ok = none_u { $_ == 5000 } @list; + my $ok2 = none_u { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { &none_u( 42, 4711 ); } ); +} + +sub test_notall_u +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( notall_u { !defined } @list ); + is_true( notall_u { $_ < 10000 } @list ); + is_false( notall_u { $_ <= 10000 } @list ); + is_undef( notall_u {} ); + + leak_free_ok( + notall_u => sub { + my $ok = notall_u { $_ == 5000 } @list; + my $ok2 = notall_u { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { ¬all_u( 42, 4711 ); } ); +} + +sub test_one_u +{ + # Normal cases + my @list = ( 1 .. 300 ); + is_true( one_u { 1 == $_ } @list ); + is_true( one_u { 150 == $_ } @list ); + is_true( one_u { 300 == $_ } @list ); + is_false( one_u { 0 == $_ } @list ); + is_false( one_u { 1 <= $_ } @list ); + is_false( one_u { !( 127 & $_ ) } @list ); + is_undef( one_u {} ); + + leak_free_ok( + one => sub { + my $ok = one_u { 150 <= $_ } @list; + my $ok2 = one_u { 150 <= $_ } 1 .. 300; + } + ); + is_dying( sub { &one_u( 42, 4711 ); } ); +} + +sub test_true +{ + # The null set should return zero + my $null_scalar = true {}; + my @null_list = true {}; + is( $null_scalar, 0, 'true(null) returns undef' ); + is_deeply( \@null_list, [0], 'true(null) returns undef' ); + + # Normal cases + my @list = ( 1 .. 10000 ); + is( 10000, true { defined } @list ); + is( 0, true { not defined } @list ); + is( 1, true { $_ == 5000 } @list ); + + leak_free_ok( + true => sub { + my $n = true { $_ == 5000 } @list; + my $n2 = true { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { &true( 42, 4711 ); } ); +} + +sub test_false +{ + # The null set should return zero + my $null_scalar = false {}; + my @null_list = false {}; + is( $null_scalar, 0, 'false(null) returns undef' ); + is_deeply( \@null_list, [0], 'false(null) returns undef' ); + + # Normal cases + my @list = ( 1 .. 10000 ); + is( 10000, false { not defined } @list ); + is( 0, false { defined } @list ); + is( 1, false { $_ > 1 } @list ); + + leak_free_ok( + false => sub { + my $n = false { $_ == 5000 } @list; + my $n2 = false { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { &false( 42, 4711 ); } ); +} + +sub test_firstidx +{ + my @list = ( 1 .. 10000 ); + is( 4999, ( firstidx { $_ >= 5000 } @list ), "firstidx" ); + is( -1, ( firstidx { not defined } @list ), "invalid firstidx" ); + is( 0, ( firstidx { defined } @list ), "real firstidx" ); + is( -1, ( firstidx {} ), "empty firstidx" ); + + # Test the alias + is( 4999, first_index { $_ >= 5000 } @list ); + is( -1, first_index { not defined } @list ); + is( 0, first_index { defined } @list ); + is( -1, first_index {} ); + + leak_free_ok( + firstidx => sub { + my $i = firstidx { $_ >= 5000 } @list; + my $i2 = firstidx { $_ >= 5000 } 1 .. 10000; + } + ); + is_dying( sub { &firstidx( 42, 4711 ); } ); +} + +sub test_lastidx +{ + my @list = ( 1 .. 10000 ); + is( 9999, lastidx { $_ >= 5000 } @list ); + is( -1, lastidx { not defined } @list ); + is( 9999, lastidx { defined } @list ); + is( -1, lastidx {} ); + + # Test aliases + is( 9999, last_index { $_ >= 5000 } @list ); + is( -1, last_index { not defined } @list ); + is( 9999, last_index { defined } @list ); + is( -1, last_index {} ); + + leak_free_ok( + lastidx => sub { + my $i = lastidx { $_ >= 5000 } @list; + my $i2 = lastidx { $_ >= 5000 } 1 .. 10000; + } + ); + is_dying( sub { &lastidx( 42, 4711 ); } ); +} + +sub test_onlyidx +{ + my @list = ( 1 .. 300 ); + is( 0, onlyidx { 1 == $_ } @list ); + is( 149, onlyidx { 150 == $_ } @list ); + is( 299, onlyidx { 300 == $_ } @list ); + is( -1, onlyidx { 0 == $_ } @list ); + is( -1, onlyidx { 1 <= $_ } @list ); + is( -1, onlyidx { !( 127 & $_ ) } @list ); + + # Test aliases + is( 0, only_index { 1 == $_ } @list ); + is( 149, only_index { 150 == $_ } @list ); + is( 299, only_index { 300 == $_ } @list ); + is( -1, only_index { 0 == $_ } @list ); + is( -1, only_index { 1 <= $_ } @list ); + is( -1, only_index { !( 127 & $_ ) } @list ); + + leak_free_ok( + onlyidx => sub { + my $ok = onlyidx { 150 <= $_ } @list; + my $ok2 = onlyidx { 150 <= $_ } 1 .. 300; + } + ); + is_dying( sub { &onlyidx( 42, 4711 ); } ); +} + +sub test_insert_after +{ + my @list = qw{This is a list}; + insert_after { $_ eq "a" } "longer" => @list; + is( join( ' ', @list ), "This is a longer list" ); + insert_after { 0 } "bla" => @list; + is( join( ' ', @list ), "This is a longer list" ); + insert_after { $_ eq "list" } "!" => @list; + is( join( ' ', @list ), "This is a longer list !" ); + @list = ( qw{This is}, undef, qw{list} ); + insert_after { not defined($_) } "longer" => @list; + $list[2] = "a"; + is( join( ' ', @list ), "This is a longer list" ); + + leak_free_ok( + insert_after => sub { + @list = qw{This is a list}; + insert_after { $_ eq 'a' } "longer" => @list; + } + ); + is_dying( sub { &insert_after( 42, 4711, [qw(die bart die)] ); } ); + is_dying( sub { &insert_after( 42, 4711, "13" ); } ); + is_dying( + sub { + &insert_after( sub { }, 4711, "13" ); + } + ); +} + +sub test_insert_after_string +{ + my @list = qw{This is a list}; + insert_after_string "a", "longer" => @list; + is( join( ' ', @list ), "This is a longer list" ); + @list = ( undef, qw{This is a list} ); + insert_after_string "a", "longer", @list; + shift @list; + is( join( ' ', @list ), "This is a longer list" ); + @list = ( "This\0", "is\0", "a\0", "list\0" ); + insert_after_string "a\0", "longer\0", @list; + is( join( ' ', @list ), "This\0 is\0 a\0 longer\0 list\0" ); + + leak_free_ok( + insert_after_string => sub { + @list = qw{This is a list}; + insert_after_string "a", "longer", @list; + } + ); + is_dying( sub { &insert_after_string( 42, 4711, "13" ); } ); +} + +sub test_apply +{ + # Test the null case + my $null_scalar = apply {}; + is( $null_scalar, undef, 'apply(null) returns undef' ); + + my @null_list = apply {}; + is_deeply( \@null_list, [], 'apply(null) returns null list' ); + + # Normal cases + my @list = ( 0 .. 9 ); + my @list1 = apply { $_++ } @list; + ok( is_deeply( \@list, [ 0 .. 9 ] ) ); + ok( is_deeply( \@list1, [ 1 .. 10 ] ) ); + @list = ( " foo ", " bar ", " ", "foobar" ); + @list1 = apply { s/^\s+|\s+$//g } @list; + ok( is_deeply( \@list, [ " foo ", " bar ", " ", "foobar" ] ) ); + ok( is_deeply( \@list1, [ "foo", "bar", "", "foobar" ] ) ); + my $item = apply { s/^\s+|\s+$//g } @list; + is( $item, "foobar" ); + + # RT 38630 + SCOPE: + { + # wrong results from apply() [XS] + @list = ( 1 .. 4 ); + @list1 = apply + { + grow_stack(); + $_ = 5; + } + @list; + ok( is_deeply( \@list, [ 1 .. 4 ] ) ); + ok( is_deeply( \@list1, [ (5) x 4 ] ) ); + } + + leak_free_ok( + apply => sub { + @list = ( 1 .. 4 ); + @list1 = apply + { + grow_stack(); + $_ = 5; + } + @list; + } + ); + is_dying( sub { &apply( 42, 4711 ); } ); +} + +sub test_indexes +{ + my @x = indexes { $_ > 5 } ( 4 .. 9 ); + ok( is_deeply( \@x, [ 2 .. 5 ] ) ); + @x = indexes { $_ > 5 } ( 1 .. 4 ); + is_deeply( \@x, [], 'Got the null list' ); + + my ( $lr, @s, @n, @o, @e ); + leak_free_ok( + indexes => sub { + $lr = 1; + @s = indexes { $_ > 5 } ( 4 .. 9 ); + @n = indexes { $_ > 5 } ( 1 .. 5 ); + @o = indexes { $_ & 1 } ( 10 .. 15 ); + @e = indexes { !( $_ & 1 ) } ( 10 .. 15 ); + } + ); + $lr and is_deeply( \@s, [ 2 .. 5 ], "indexes/leak: some" ); + $lr and is_deeply( \@n, [], "indexes/leak: none" ); + $lr and is_deeply( \@o, [ 1, 3, 5 ], "indexes/leak: odd" ); + $lr and is_deeply( \@e, [ 0, 2, 4 ], "indexes/leak: even" ); + + leak_free_ok( + indexes => sub { + @s = indexes { grow_stack; $_ > 5 } ( 4 .. 9 ); + @n = indexes { grow_stack; $_ > 5 } ( 1 .. 4 ); + @o = indexes { grow_stack; $_ & 1 } ( 10 .. 15 ); + @e = indexes { grow_stack; !( $_ & 1 ) } ( 10 .. 15 ); + } + ); + + $lr and is_deeply( \@s, [ 2 .. 5 ], "indexes/leak: some" ); + $lr and is_deeply( \@n, [], "indexes/leak: none" ); + $lr and is_deeply( \@o, [ 1, 3, 5 ], "indexes/leak: odd" ); + $lr and is_deeply( \@e, [ 0, 2, 4 ], "indexes/leak: even" ); + + if ($have_scalar_util) + { + my $ref = \( indexes( sub { 1 }, 123 ) ); + Scalar::Util::weaken($ref); + is( $ref, undef, "weakened away" ); + } + is_dying( sub { &indexes( 42, 4711 ); } ); +} + +# In the following, the @dummy variable is needed to circumvent +# a parser glitch in the 5.6.x series. +sub test_before +{ + my @x = before { $_ % 5 == 0 } 1 .. 9; + ok( is_deeply( \@x, [ 1, 2, 3, 4 ] ) ); + @x = before { /b/ } my @dummy = qw{ bar baz }; + is_deeply( \@x, [], 'Got the null list' ); + @x = before { /f/ } @dummy = qw{ bar baz foo }; + ok( is_deeply( \@x, [qw{ bar baz }] ) ); + + leak_free_ok( + before => sub { + @x = before { /f/ } @dummy = qw{ bar baz foo }; + } + ); + is_dying( sub { &before( 42, 4711 ); } ); +} + +# In the following, the @dummy variable is needed to circumvent +# a parser glitch in the 5.6.x series. +sub test_before_incl +{ + my @x = before_incl { $_ % 5 == 0 } 1 .. 9; + ok( is_deeply( \@x, [ 1, 2, 3, 4, 5 ] ) ); + @x = before_incl { /foo/ } my @dummy = qw{ bar baz }; + ok( is_deeply( \@x, [qw{ bar baz }] ) ); + @x = before_incl { /f/ } @dummy = qw{ bar baz foo }; + ok( is_deeply( \@x, [qw{ bar baz foo }] ) ); + + leak_free_ok( + before_incl => sub { + @x = before_incl { /z/ } @dummy = qw{ bar baz foo }; + } + ); + is_dying( sub { &before_incl( 42, 4711 ); } ); +} + +# In the following, the @dummy variable is needed to circumvent +# a parser glitch in the 5.6.x series. +sub test_after +{ + my @x = after { $_ % 5 == 0 } 1 .. 9; + ok( is_deeply( \@x, [ 6, 7, 8, 9 ] ) ); + @x = after { /foo/ } my @dummy = qw{ bar baz }; + is_deeply( \@x, [], 'Got the null list' ); + @x = after { /b/ } @dummy = qw{ bar baz foo }; + ok( is_deeply( \@x, [qw{ baz foo }] ) ); + + leak_free_ok( + after => sub { + @x = after { /z/ } @dummy = qw{ bar baz foo }; + } + ); + is_dying( sub { &after( 42, 4711 ); } ); +} + +# In the following, the @dummy variable is needed to circumvent +# a parser glitch in the 5.6.x series. +sub test_after_incl +{ + my @x = after_incl { $_ % 5 == 0 } 1 .. 9; + ok( is_deeply( \@x, [ 5, 6, 7, 8, 9 ] ) ); + @x = after_incl { /foo/ } my @dummy = qw{ bar baz }; + is_deeply( \@x, [], 'Got the null list' ); + @x = after_incl { /b/ } @dummy = qw{ bar baz foo }; + ok( is_deeply( \@x, [qw{ bar baz foo }] ) ); + + leak_free_ok( + after_incl => sub { + @x = after_incl { /z/ } @dummy = qw{ bar baz foo }; + } + ); + is_dying( sub { &after_incl( 42, 4711 ); } ); +} + +sub test_firstval +{ + my $x = firstval { $_ > 5 } 4 .. 9; + is( $x, 6 ); + $x = firstval { $_ > 5 } 1 .. 4; + is( $x, undef ); + is_undef( firstval { $_ > 5 } ); + + # Test aliases + $x = first_value { $_ > 5 } 4 .. 9; + is( $x, 6 ); + $x = first_value { $_ > 5 } 1 .. 4; + is( $x, undef ); + + leak_free_ok( + firstval => sub { + $x = firstval { $_ > 5 } 4 .. 9; + } + ); + is_dying( sub { &firstval( 42, 4711 ); } ); +} + +sub test_onlyval +{ + my @list = ( 1 .. 300 ); + is( 1, onlyval { 1 == $_ } @list ); + is( 150, onlyval { 150 == $_ } @list ); + is( 300, onlyval { 300 == $_ } @list ); + is( undef, onlyval { 0 == $_ } @list ); + is( undef, onlyval { 1 <= $_ } @list ); + is( undef, onlyval { !( 127 & $_ ) } @list ); + + # Test aliases + is( 1, only_value { 1 == $_ } @list ); + is( 150, only_value { 150 == $_ } @list ); + is( 300, only_value { 300 == $_ } @list ); + is( undef, only_value { 0 == $_ } @list ); + is( undef, only_value { 1 <= $_ } @list ); + is( undef, only_value { !( 127 & $_ ) } @list ); + + leak_free_ok( + onlyval => sub { + my $ok = onlyval { 150 <= $_ } @list; + my $ok2 = onlyval { 150 <= $_ } 1 .. 300; + } + ); + is_dying( sub { &onlyval( 42, 4711 ); } ); +} + +sub test_lastval +{ + my $x = lastval { $_ > 5 } 4 .. 9; + is( $x, 9 ); + $x = lastval { $_ > 5 } 1 .. 4; + is( $x, undef ); + is_undef( lastval { $_ > 5 } ); + + # Test aliases + $x = last_value { $_ > 5 } 4 .. 9; + is( $x, 9 ); + $x = last_value { $_ > 5 } 1 .. 4; + is( $x, undef ); + + leak_free_ok( + lastval => sub { + $x = lastval { $_ > 5 } 4 .. 9; + } + ); + is_dying( sub { &lastval( 42, 4711 ); } ); +} + +sub test_firstres +{ + my $x = firstres { 2 * ( $_ > 5 ) } 4 .. 9; + is( $x, 2 ); + $x = firstres { $_ > 5 } 1 .. 4; + is( $x, undef ); + + # Test aliases + $x = first_result { $_ > 5 } 4 .. 9; + is( $x, 1 ); + $x = first_result { $_ > 5 } 1 .. 4; + is( $x, undef ); + + leak_free_ok( + firstres => sub { + $x = firstres { $_ > 5 } 4 .. 9; + } + ); + is_dying( sub { &firstres( 42, 4711 ); } ); +} + +sub test_lastres +{ + my $x = lastres { 2 * ( $_ > 5 ) } 4 .. 9; + is( $x, 2 ); + $x = lastres { $_ > 5 } 1 .. 4; + is( $x, undef ); + + # Test aliases + $x = last_result { $_ > 5 } 4 .. 9; + is( $x, 1 ); + $x = last_result { $_ > 5 } 1 .. 4; + is( $x, undef ); + + leak_free_ok( + lastres => sub { + $x = lastres { $_ > 5 } 4 .. 9; + } + ); + is_dying( sub { &lastres( 42, 4711 ); } ); +} + +sub test_onlyres +{ + my @list = ( 1 .. 300 ); + is( "Hallelujah", onlyres { 150 == $_ and "Hallelujah" } @list ); + is( 1, onlyres { 300 == $_ } @list ); + is( undef, onlyres { 0 == $_ } @list ); + is( undef, onlyres { 1 <= $_ } @list ); + is( undef, onlyres { !( 127 & $_ ) } @list ); + + # Test aliases + is( 1, only_result { 150 == $_ } @list ); + is( "Hallelujah", only_result { 300 == $_ and "Hallelujah" } @list ); + is( undef, only_result { 0 == $_ } @list ); + is( undef, only_result { 1 <= $_ } @list ); + is( undef, only_result { !( 127 & $_ ) } @list ); + + leak_free_ok( + onlyres => sub { + my $ok = onlyres { 150 <= $_ } @list; + my $ok2 = onlyres { 150 <= $_ } 1 .. 300; + } + ); + is_dying( sub { &onlyres( 42, 4711 ); } ); +} + +sub test_each_array +{ + SCOPE: + { + my @a = ( 7, 3, 'a', undef, 'r' ); + my @b = qw{ a 2 -1 x }; + my $it = each_array @a, @b; + my ( @r, @idx ); + while ( my ( $a, $b ) = $it->() ) + { + push @r, $a, $b; + push @idx, $it->('index'); + } + + # Do I segfault? I shouldn't. + $it->(); + + ok( is_deeply( \@r, [ 7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef ] ) ); + ok( is_deeply( \@idx, [ 0 .. 4 ] ) ); + + # Testing two iterators on the same arrays in parallel + @a = ( 1, 3, 5 ); + @b = ( 2, 4, 6 ); + my $i1 = each_array @a, @b; + my $i2 = each_array @a, @b; + @r = (); + while ( my ( $a, $b ) = $i1->() and my ( $c, $d ) = $i2->() ) + { + push @r, $a, $b, $c, $d; + } + ok( is_deeply( \@r, [ 1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6 ] ) ); + + # Input arrays must not be modified + ok( is_deeply( \@a, [ 1, 3, 5 ] ) ); + ok( is_deeply( \@b, [ 2, 4, 6 ] ) ); + + # This used to give "semi-panic: attempt to dup freed string" + # See: <news:1140827861.481475.111380@z34g2000cwc.googlegroups.com> + my $ea = each_arrayref( [ 1 .. 26 ], [ 'A' .. 'Z' ] ); + ( @a, @b ) = (); + while ( my ( $a, $b ) = $ea->() ) + { + push @a, $a; + push @b, $b; + } + ok( is_deeply( \@a, [ 1 .. 26 ] ) ); + ok( is_deeply( \@b, [ 'A' .. 'Z' ] ) ); + + # And this even used to dump core + my @nums = 1 .. 26; + $ea = each_arrayref( \@nums, [ 'A' .. 'Z' ] ); + ( @a, @b ) = (); + while ( my ( $a, $b ) = $ea->() ) + { + push @a, $a; + push @b, $b; + } + ok( is_deeply( \@a, [ 1 .. 26 ] ) ); + ok( is_deeply( \@a, \@nums ) ); + ok( is_deeply( \@b, [ 'A' .. 'Z' ] ) ); + } + + SCOPE: + { + my @a = ( 7, 3, 'a', undef, 'r' ); + my @b = qw/a 2 -1 x/; + + my $it = each_arrayref \@a, \@b; + my ( @r, @idx ); + while ( my ( $a, $b ) = $it->() ) + { + push @r, $a, $b; + push @idx, $it->('index'); + } + + # Do I segfault? I shouldn't. + $it->(); + + ok( is_deeply( \@r, [ 7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef ] ) ); + ok( is_deeply( \@idx, [ 0 .. 4 ] ) ); + + # Testing two iterators on the same arrays in parallel + @a = ( 1, 3, 5 ); + @b = ( 2, 4, 6 ); + my $i1 = each_array @a, @b; + my $i2 = each_array @a, @b; + @r = (); + while ( my ( $a, $b ) = $i1->() and my ( $c, $d ) = $i2->() ) + { + push @r, $a, $b, $c, $d; + } + ok( is_deeply( \@r, [ 1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6 ] ) ); + + # Input arrays must not be modified + ok( is_deeply( \@a, [ 1, 3, 5 ] ) ); + ok( is_deeply( \@b, [ 2, 4, 6 ] ) ); + } + + # Note that the leak_free_ok tests for each_array and each_arrayref + # should not be run until either of them has been called at least once + # in the current perl. That's because calling them the first time + # causes the runtime to allocate some memory used for the OO structures + # that their implementation uses internally. + leak_free_ok( + each_array => sub { + my @a = (1); + my $it = each_array @a; + while ( my ($a) = $it->() ) + { + } + } + ); + leak_free_ok( + each_arrayref => sub { + my @a = (1); + my $it = each_arrayref \@a; + while ( my ($a) = $it->() ) + { + } + } + ); + is_dying( sub { &each_array( 42, 4711 ); } ); + is_dying( sub { &each_arrayref( 42, 4711 ); } ); +} + +sub test_pairwise +{ + my @a = ( 1, 2, 3, 4, 5 ); + my @b = ( 2, 4, 6, 8, 10 ); + my @c = pairwise { $a + $b } @a, @b; + is( is_deeply( \@c, [ 3, 6, 9, 12, 15 ] ), 1, "pw1" ); + + @c = pairwise { $a * $b } @a, @b; # returns (2, 8, 18) + is( is_deeply( \@c, [ 2, 8, 18, 32, 50 ] ), 1, "pw2" ); + + # Did we modify the input arrays? + is( is_deeply( \@a, [ 1, 2, 3, 4, 5 ] ), 1, "pw3" ); + is( is_deeply( \@b, [ 2, 4, 6, 8, 10 ] ), 1, "pw4" ); + + # $a and $b should be aliases: test + @b = @a = ( 1, 2, 3 ); + @c = pairwise { $a++; $b *= 2 } @a, @b; + is( is_deeply( \@a, [ 2, 3, 4 ] ), 1, "pw5" ); + is( is_deeply( \@b, [ 2, 4, 6 ] ), 1, "pw6" ); + is( is_deeply( \@c, [ 2, 4, 6 ] ), 1, "pw7" ); + + # Test this one more thoroughly: the XS code looks flakey + # correctness of pairwise_perl proved by human auditing. :-) + sub pairwise_perl (&\@\@) + { + no strict; + my $op = shift; + local ( *A, *B ) = @_; # syms for caller's input arrays + + # Localise $a, $b + my ( $caller_a, $caller_b ) = do + { + my $pkg = caller(); + \*{ $pkg . '::a' }, \*{ $pkg . '::b' }; + }; + + # Loop iteration limit + my $limit = $#A > $#B ? $#A : $#B; + + # This map expression is also the return value. + local ( *$caller_a, *$caller_b ); + map { + # Assign to $a, $b as refs to caller's array elements + ( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] ); + $op->(); # perform the transformation + } 0 .. $limit; + } + + ( @a, @b ) = (); + push @a, int rand(1000) for 0 .. rand(1000); + push @b, int rand(1000) for 0 .. rand(1000); + SCOPE: + { + local $SIG{__WARN__} = sub { }; # XXX + my @res1 = pairwise { $a + $b } @a, @b; + my @res2 = pairwise_perl { $a + $b } @a, @b; + ok( is_deeply( \@res1, \@res2 ) ); + } + + @a = qw/a b c/; + @b = qw/1 2 3/; + @c = pairwise { ( $a, $b ) } @a, @b; + ok( is_deeply( \@c, [qw/a 1 b 2 c 3/] ) ); # 88 + + SKIP: + { + $ENV{PERL5OPT} and skip 'A defined PERL5OPT may inject extra deps crashing this test', 1; + # Test that a die inside the code-reference will not be trapped + eval { + pairwise { die "I died\n" } @a, @b; + }; + is( $@, "I died\n" ); + } + + leak_free_ok( + pairwise => sub { + @a = (1); + @b = (2); + @c = pairwise { $a + $b } @a, @b; + } + ); + @a = qw/a b c/; + @b = qw/1 2 3/; + + SKIP: + { + List::MoreUtils::_XScompiled or skip "PurePerl will warn here ...", 1; + my ( $a, $b, @t ); + eval { + my @l1 = ( 1 .. 10 ); + @t = pairwise { $a + $b } @l1, @l1; + }; + my $err = $@; + like( $err, qr/Can't use lexical \$a or \$b in pairwise code block/, "pairwise die's on broken caller" ); + } + + SKIP: + { + List::MoreUtils::_XScompiled and skip "XS will die on purpose here ...", 1; + my @warns = (); + local $SIG{__WARN__} = sub { push @warns, @_ }; + my ( $a, $b, @t ); + my @l1 = ( 1 .. 10 ); + @t = pairwise { $a + $b } @l1, @l1; + like( join( "", @warns[ 0, 1 ] ), qr/Use of uninitialized value.*? in addition/, "warning on broken caller" ); + } + + is_dying( sub { &pairwise( 42, \@a, \@b ); } ); + SKIP: + { + List::MoreUtils::_XScompiled or skip "PurePerl will not core here ...", 2; + is_dying( + sub { + @c = &pairwise( sub { }, 1, \@b ); + } + ); + is_dying( + sub { + @c = &pairwise( sub { }, \@a, 2 ); + } + ); + } +} + +sub test_natatime +{ + my @x = ( 'a' .. 'g' ); + my $it = natatime 3, @x; + my @r; + local $" = " "; + while ( my @vals = $it->() ) + { + push @r, "@vals"; + } + is( is_deeply( \@r, [ 'a b c', 'd e f', 'g' ] ), 1, "natatime1" ); + + my @a = ( 1 .. 1000 ); + $it = natatime 1, @a; + @r = (); + while ( my @vals = &$it ) + { + push @r, @vals; + } + is( is_deeply( \@r, \@a ), 1, "natatime2" ); + + leak_free_ok( + natatime => sub { + my @y = 1; + my $it = natatime 2, @y; + while ( my @vals = $it->() ) + { + # do nothing + } + } + ); +} + +sub test_zip +{ + SCOPE: + { + my @x = qw/a b c d/; + my @y = qw/1 2 3 4/; + my @z = zip @x, @y; + ok( is_deeply( \@z, [ 'a', 1, 'b', 2, 'c', 3, 'd', 4 ] ) ); + } + + SCOPE: + { + my @a = ('x'); + my @b = ( '1', '2' ); + my @c = qw/zip zap zot/; + my @z = zip @a, @b, @c; + ok( is_deeply( \@z, [ 'x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot' ] ) ); + } + + SCOPE: + { + # Make array with holes + my @a = ( 1 .. 10 ); + my @d; + $#d = 9; + my @z = zip @a, @d; + ok( + is_deeply( + \@z, [ 1, undef, 2, undef, 3, undef, 4, undef, 5, undef, 6, undef, 7, undef, 8, undef, 9, undef, 10, undef, ] + ) + ); + } + + leak_free_ok( + zip => sub { + my @x = qw/a b c d/; + my @y = qw/1 2 3 4/; + my @z = zip @x, @y; + } + ); + is_dying( sub { &zip( 1, 2 ); } ); +} + +sub test_mesh +{ + SCOPE: + { + my @x = qw/a b c d/; + my @y = qw/1 2 3 4/; + my @z = mesh @x, @y; + ok( is_deeply( \@z, [ 'a', 1, 'b', 2, 'c', 3, 'd', 4 ] ) ); + } + + SCOPE: + { + my @a = ('x'); + my @b = ( '1', '2' ); + my @c = qw/zip zap zot/; + my @z = mesh @a, @b, @c; + ok( is_deeply( \@z, [ 'x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot' ] ) ); + } + + # Make array with holes + SCOPE: + { + my @a = ( 1 .. 10 ); + my @d; + $#d = 9; + my @z = mesh @a, @d; + ok( + is_deeply( + \@z, [ 1, undef, 2, undef, 3, undef, 4, undef, 5, undef, 6, undef, 7, undef, 8, undef, 9, undef, 10, undef, ] + ) + ); + } + + leak_free_ok( + mesh => sub { + my @x = qw/a b c d/; + my @y = qw/1 2 3 4/; + my @z = mesh @x, @y; + } + ); + is_dying( sub { &mesh( 1, 2 ); } ); +} + +sub test_uniq +{ + SCOPE: + { + my @a = map { ( 1 .. 10 ) } 0 .. 1; + my @u = uniq @a; + is_deeply( \@u, [ 1 .. 10 ] ); + my $u = uniq @a; + is( 10, $u ); + } + + # Test aliases + SCOPE: + { + my @a = map { ( 1 .. 10 ) } 0 .. 1; + my @u = distinct @a; + is_deeply( \@u, [ 1 .. 10 ] ); + my $u = distinct @a; + is( 10, $u ); + } + + # Test strings + SCOPE: + { + my @a = map { ( "a" .. "z" ) } 0 .. 1; + my @u = uniq @a; + is_deeply( \@u, [ "a" .. "z" ] ); + my $u = uniq @a; + is( 26, $u ); + } + + # Test mixing strings and numbers + SCOPE: + { + my @a = ( ( map { ( 1 .. 10 ) } 0 .. 1 ), ( map { ( "a" .. "z" ) } 0 .. 1 ) ); + my $fa = freeze( \@a ); + my @u = uniq map { $_ } @a; + my $fu = freeze( \@u ); + is_deeply( \@u, [ 1 .. 10, "a" .. "z" ] ); + is( $fa, freeze( \@a ) ); + is( $fu, freeze( [ 1 .. 10, "a" .. "z" ] ) ); + my $u = uniq @a; + is( 10 + 26, $u ); + } + + SCOPE: + { + my @a; + tie @a, "Tie::StdArray"; + @a = ( ( map { ( 1 .. 10 ) } 0 .. 1 ), ( map { ( "a" .. "z" ) } 0 .. 1 ) ); + my @u = uniq @a; + is_deeply( \@u, [ 1 .. 10, "a" .. "z" ] ); + @a = ( ( map { ( 1 .. 10 ) } 0 .. 1 ), ( map { ( "a" .. "z" ) } 0 .. 1 ) ); + my $u = uniq @a; + is( 10 + 26, $u ); + } + + SCOPE: + { + my @foo = ( 'a', 'b', '', undef, 'b', 'c', '' ); + my @ufoo = ( 'a', 'b', '', undef, 'c' ); + is_deeply( [ uniq @foo ], \@ufoo, 'undef is supported correctly' ); + } + + leak_free_ok( + uniq => sub { + my @a = map { ( 1 .. 1000 ) } 0 .. 1; + my @u = uniq @a; + uniq @a[ 1 .. 100 ]; + } + ); + + # This test (and the associated fix) are from Kevin Ryde; see RT#49796 + leak_free_ok( + 'uniq with exception in overloading stringify', + sub { + eval { + my $obj = DieOnStringify->new; + my @u = uniq $obj, $obj; + }; + eval { + my $obj = DieOnStringify->new; + my $u = uniq $obj, $obj; + }; + } + ); +} + +sub test_singleton +{ + SCOPE: + { + my @s = ( 1001 .. 1200 ); + my @d = map { ( 1 .. 1000 ) } 0 .. 1; + my @a = ( @d, @s ); + my @u = singleton @a; + is_deeply( \@u, [@s] ); + my $u = singleton @a; + is( 200, $u ); + } + + # Test strings + SCOPE: + { + my @s = ( "AA" .. "ZZ" ); + my @d = map { ( "aa" .. "zz" ) } 0 .. 1; + my @a = ( @d, @s ); + my @u = singleton @a; + is_deeply( \@u, [@s] ); + my $u = singleton @a; + is( scalar @s, $u ); + } + + # Test mixing strings and numbers + SCOPE: + { + my @s = ( 1001 .. 1200, "AA" .. "ZZ" ); + my $fs = freeze( \@s ); + my @d = map { ( 1 .. 1000, "aa" .. "zz" ) } 0 .. 1; + my @a = ( @d, @s ); + my $fa = freeze( \@a ); + my @u = singleton map { $_ } @a; + my $fu = freeze( \@u ); + is_deeply( \@u, [@s] ); + is( $fs, freeze( \@s ) ); + is( $fa, freeze( \@a ) ); + is( $fu, $fs ); + my $u = singleton @a; + is( scalar @s, $u ); + } + + SCOPE: + { + my @a; + tie @a, "Tie::StdArray"; + my @s = ( 1001 .. 1200, "AA" .. "ZZ" ); + my @d = map { ( 1 .. 1000, "aa" .. "zz" ) } 0 .. 1; + @a = ( @d, @s ); + my @u = singleton map { $_ } @a; + is_deeply( \@u, [@s] ); + @a = ( @d, @s ); + my $u = singleton @a; + is( scalar @s, $u ); + } + + SCOPE: + { + my @foo = ( 'a', 'b', '', undef, 'b', 'c', '' ); + my @sfoo = ( 'a', undef, 'c' ); + is_deeply( [ singleton @foo ], \@sfoo, 'one undef is supported correctly by singleton' ); + @foo = ( 'a', 'b', '', undef, 'b', 'c', undef ); + @sfoo = ( 'a', '', 'c' ); + is_deeply( [ singleton @foo ], \@sfoo, 'twice undef is supported correctly by singleton' ); + is( ( scalar singleton @foo ), scalar @sfoo, 'scalar twice undef is supported correctly by singleton' ); + } + + leak_free_ok( + uniq => sub { + my @s = ( 1001 .. 1200, "AA" .. "ZZ" ); + my @d = map { ( 1 .. 1000, "aa" .. "zz" ) } 0 .. 1; + my @a = ( @d, @s ); + my @u = singleton @a; + scalar singleton @a; + } + ); + + # This test (and the associated fix) are from Kevin Ryde; see RT#49796 + leak_free_ok( + 'singleton with exception in overloading stringify', + sub { + eval { + my $obj = DieOnStringify->new; + my @u = singleton $obj, $obj; + }; + eval { + my $obj = DieOnStringify->new; + my $u = singleton $obj, $obj; + }; + } + ); +} + +sub test_part +{ + my @list = 1 .. 12; + my $i = 0; + my @part = part { $i++ % 3 } @list; + ok( is_deeply( $part[0], [ 1, 4, 7, 10 ] ) ); + ok( is_deeply( $part[1], [ 2, 5, 8, 11 ] ) ); + ok( is_deeply( $part[2], [ 3, 6, 9, 12 ] ) ); + + @part = part { 3 } @list; + is( $part[0], undef ); + is( $part[1], undef ); + is( $part[2], undef ); + ok( is_deeply( $part[3], [ 1 .. 12 ] ) ); + + eval { + @part = part { -1 } @list; + }; + ok( $@ =~ /^Modification of non-creatable array value attempted, subscript -1/ ); + + $i = 0; + @part = part { $i++ == 0 ? 0 : -1 } @list; + is_deeply( $part[0], [ 1 .. 12 ], "part with negative indices" ); + + SKIP: + { + List::MoreUtils::_XScompiled and skip "Only PurePerl will warn here ...", 1; + my @warns = (); + local $SIG{__WARN__} = sub { push @warns, [@_] }; + @part = part { undef } @list; + is_deeply( $part[0], [ 1 .. 12 ], "part with undef" ); + like( join( "\n", @{ $warns[0] } ), qr/Use of uninitialized value in array element.*line\s+\d+\.$/, "warning of undef" ); + is_deeply( \@warns, [ ( $warns[0] ) x 12 ], "amount of similar undef warnings" ); + } + + @part = part { 10000 } @list; + ok( is_deeply( $part[10000], [@list] ) ); + is( $part[0], undef ); + is( $part[ @part / 2 ], undef ); + is( $part[9999], undef ); + + # Changing the list in place used to destroy + # its elements due to a wrong refcnt + @list = 1 .. 10; + @list = part { $_ } @list; + foreach ( 1 .. 10 ) + { + ok( is_deeply( $list[$_], [$_] ) ); + } + + leak_free_ok( + part => sub { + my @list = 1 .. 12; + my $i = 0; + my @part = part { $i++ % 3 } @list; + } + ); + + leak_free_ok( + 'part with stack-growing' => sub { + # This test is from Kevin Ryde; see RT#38699 + my @part = part { grow_stack(); 1024 } 'one', 'two'; + } + ); +} + +sub test_minmax +{ + my @list = reverse 0 .. 10000; + my ( $min, $max ) = minmax @list; + is( $min, 0 ); + is( $max, 10000 ); + + # Even number of elements + push @list, 10001; + ( $min, $max ) = minmax @list; + is( $min, 0 ); + is( $max, 10001 ); + + # Some floats + @list = ( 0, -1.1, 3.14, 1 / 7, 10000, -10 / 3 ); + ( $min, $max ) = minmax @list; + + # Floating-point comparison cunningly avoided + is( sprintf( "%.2f", $min ), "-3.33" ); + is( $max, 10000 ); + + # Test with a single negative list value + my $input = -1; + ( $min, $max ) = minmax $input; + is( $min, -1 ); + is( $max, -1 ); + + # Confirm output are independant copies of input + $input = 1; + is( $min, -1 ); + is( $max, -1 ); + $min = 2; + is( $max, -1 ); + + # prove overrun + my $uvmax = ~0; + my $ivmax = $uvmax >> 1; + my $ivmin = ( 0 - $ivmax ) - 1; + my @low_ints = map { $ivmin + $_ } ( 0 .. 10 ); + ( $min, $max ) = minmax @low_ints; + is( $min, $ivmin, "minmax finds ivmin" ); + is( $max, $ivmin + 10, "minmax finds ivmin + 10" ); + + my @high_ints = map { $ivmax - $_ } ( 0 .. 10 ); + ( $min, $max ) = minmax @high_ints; + is( $min, $ivmax - 10, "minmax finds ivmax-10" ); + is( $max, $ivmax, "minmax finds ivmax" ); + + my @mixed_ints = map { ( $ivmin + $_, $ivmax - $_ ) } ( 0 .. 10 ); + ( $min, $max ) = minmax @mixed_ints; + is( $min, $ivmin, "minmax finds ivmin" ); + is( $max, $ivmax, "minmax finds ivmax" ); + + my @high_uints = map { $uvmax - $_ } ( 0 .. 10 ); + ( $min, $max ) = minmax @high_uints; + is( $min, $uvmax - 10, "minmax finds uvmax-10" ); + is( $max, $uvmax, "minmax finds uvmax" ); + + my @mixed_nums = map { ( $ivmin + $_, $uvmax - $_ ) } ( 0 .. 10 ); + ( $min, $max ) = minmax @mixed_nums; + is( $min, $ivmin, "minmax finds ivmin" ); + is( $max, $uvmax, "minmax finds uvmax" ); + + leak_free_ok( + minmax => sub { + @list = ( 0, -1.1, 3.14, 1 / 7, 10000, -10 / 3 ); + ( $min, $max ) = minmax @list; + } + ); +} + +sub test_bsearch +{ + my @list = my @in = 1 .. 1000; + for my $elem (@in) + { + ok( scalar bsearch { $_ - $elem } @list ); + } + for my $elem (@in) + { + my ($e) = bsearch { $_ - $elem } @list; + ok( $e == $elem ); + } + my @out = ( -10 .. 0, 1001 .. 1011 ); + for my $elem (@out) + { + my $r = bsearch { $_ - $elem } @list; + ok( !defined $r ); + } + + leak_free_ok( + bsearch => sub { + my $elem = int( rand(1000) ) + 1; + scalar bsearch { $_ - $elem } @list; + } + ); + + leak_free_ok( + 'bsearch with stack-growing' => sub { + my $elem = int( rand(1000) ); + scalar bsearch { grow_stack(); $_ - $elem } @list; + } + ); + + leak_free_ok( + 'bsearch with stack-growing and exception' => sub { + my $elem = int( rand(1000) ); + eval { + scalar bsearch { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; + }; + } + ); + is_dying( sub { &bsearch( 42, ( 1 .. 100 ) ); } ); +} + +sub test_bsearchidx +{ + my @list = my @in = 1 .. 1000; + for my $i ( 0 .. $#in ) + { + is( $i, bsearchidx { $_ - $in[$i] } @list ); + } + my @out = ( -10 .. 0, 1001 .. 1011 ); + for my $elem (@out) + { + my $r = bsearchidx { $_ - $elem } @list; + is( -1, $r ); + } + + leak_free_ok( + bsearch => sub { + my $elem = int( rand(1000) ) + 1; + bsearchidx { $_ - $elem } @list; + } + ); + + leak_free_ok( + 'bsearch with stack-growing' => sub { + my $elem = int( rand(1000) ); + bsearchidx { grow_stack(); $_ - $elem } @list; + } + ); + + leak_free_ok( + 'bsearch with stack-growing and exception' => sub { + my $elem = int( rand(1000) ); + eval { + bsearchidx { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; + }; + } + ); + is_dying( sub { &bsearchidx( 42, ( 1 .. 100 ) ); } ); +} + +sub test_any +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( any { $_ == 5000 } @list ); + is_true( any { $_ == 5000 } 1 .. 10000 ); + is_true( any { defined } @list ); + is_false( any { not defined } @list ); + is_true( any { not defined } undef ); + is_false( any {} ); + + leak_free_ok( + any => sub { + my $ok = any { $_ == 5000 } @list; + my $ok2 = any { $_ == 5000 } 1 .. 10000; + } + ); + leak_free_ok( + 'any with a coderef that dies' => sub { + # This test is from Kevin Ryde; see RT#48669 + eval { + my $ok = any { die } 1; + }; + } + ); + is_dying( sub { &any( 42, 4711 ); } ); +} + +sub test_all +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( all { defined } @list ); + is_true( all { $_ > 0 } @list ); + is_false( all { $_ < 5000 } @list ); + is_true( all {} ); + + leak_free_ok( + all => sub { + my $ok = all { $_ == 5000 } @list; + my $ok2 = all { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { &all( 42, 4711 ); } ); +} + +sub test_none +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( none { not defined } @list ); + is_true( none { $_ > 10000 } @list ); + is_false( none { defined } @list ); + is_true( none {} ); + + leak_free_ok( + none => sub { + my $ok = none { $_ == 5000 } @list; + my $ok2 = none { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { &none( 42, 4711 ); } ); +} + +sub test_notall +{ + # Normal cases + my @list = ( 1 .. 10000 ); + is_true( notall { !defined } @list ); + is_true( notall { $_ < 10000 } @list ); + is_false( notall { $_ <= 10000 } @list ); + is_false( notall {} ); + + leak_free_ok( + notall => sub { + my $ok = notall { $_ == 5000 } @list; + my $ok2 = notall { $_ == 5000 } 1 .. 10000; + } + ); + is_dying( sub { ¬all( 42, 4711 ); } ); +} + +sub test_one +{ + # Normal cases + my @list = ( 1 .. 300 ); + is_true( one { 1 == $_ } @list ); + is_true( one { 150 == $_ } @list ); + is_true( one { 300 == $_ } @list ); + is_false( one { 0 == $_ } @list ); + is_false( one { 1 <= $_ } @list ); + is_false( one { !( 127 & $_ ) } @list ); + + leak_free_ok( + one => sub { + my $ok = one { 150 <= $_ } @list; + my $ok2 = one { 150 <= $_ } 1 .. 300; + } + ); + is_dying( sub { &one( 42, 4711 ); } ); +} + +sub test_sort_by +{ + my @list = map { [$_] } 1 .. 100; + is_deeply( [ sort_by { $_->[0] } @list ], [ map { [$_] } sort { $a cmp $b } 1 .. 100 ] ); +} + +sub test_nsort_by +{ + my @list = map { [$_] } 1 .. 100; + is_deeply( [ nsort_by { $_->[0] } @list ], [ map { [$_] } sort { $a <=> $b } 1 .. 100 ] ); +} + +1; diff --git a/t/lib/LMU/Test/Import.pm b/t/lib/LMU/Test/Import.pm new file mode 100644 index 0000000..a890023 --- /dev/null +++ b/t/lib/LMU/Test/Import.pm @@ -0,0 +1,34 @@ +package LMU::Test::Import; + +use strict; + +BEGIN +{ + $| = 1; +} + +use Test::More; + +sub run_tests +{ + use_ok( + "List::MoreUtils", qw(any all none notall + any_u all_u none_u notall_u + true false firstidx lastidx + insert_after insert_after_string + apply indexes + after after_incl before before_incl + firstval lastval + each_array each_arrayref + pairwise natatime + mesh uniq + minmax part + bsearch + sort_by nsort_by + first_index last_index first_value last_value zip distinct) + ); + done_testing(); +} + +1; + diff --git a/t/lib/LMU/Test/XS.pm b/t/lib/LMU/Test/XS.pm new file mode 100644 index 0000000..4a76a3e --- /dev/null +++ b/t/lib/LMU/Test/XS.pm @@ -0,0 +1,26 @@ +package LMU::Test::XS; + +use strict; + +BEGIN +{ + $| = 1; +} + +use Test::More; +use List::MoreUtils; + +sub run_tests +{ + test_xs(); + done_testing(); +} + +sub test_xs +{ + defined $ENV{LIST_MOREUTILS_PP} + or plan skip_all => "No dedicated test for XS/PP - but can't detect configure time settings at tets runtime"; + is( List::MoreUtils::_XScompiled, 0 + !$ENV{LIST_MOREUTILS_PP}, "_XScompiled" ); +} + +1; diff --git a/t/lib/LMU/Test/ab.pm b/t/lib/LMU/Test/ab.pm new file mode 100644 index 0000000..c10808b --- /dev/null +++ b/t/lib/LMU/Test/ab.pm @@ -0,0 +1,27 @@ +package LMU::Test::ab; + +use strict; + +BEGIN +{ + $| = 1; +} + +use Test::More; +use List::MoreUtils 'pairwise'; + +sub run_tests +{ + test_ab(); + done_testing(); +} + +sub test_ab +{ + my @A = ( 1, 2, 3, 4, 5 ); + my @B = ( 2, 4, 6, 8, 10 ); + my @C = pairwise { $a + $b } @A, @B; + is_deeply( \@C, [ 3, 6, 9, 12, 15 ], "pw1" ); +} + +1; diff --git a/t/lib/Test/LMU.pm b/t/lib/Test/LMU.pm new file mode 100644 index 0000000..4fb14cf --- /dev/null +++ b/t/lib/Test/LMU.pm @@ -0,0 +1,86 @@ +package Test::LMU; + +use strict; + +require Exporter; +use Test::More import => ['!pass']; +use Carp qw/croak/; + +use base qw(Test::Builder::Module Exporter); + +our @EXPORT = qw(is_true is_false is_defined is_undef is_dying grow_stack leak_free_ok); +our @EXPORT_OK = qw(is_true is_false is_defined is_undef is_dying grow_stack leak_free_ok); + +my $CLASS = __PACKAGE__; + +###################################################################### +# Support Functions + +sub is_true +{ + @_ == 1 or croak "Expected 1 param"; + my $tb = $CLASS->builder(); + $tb->ok( $_[0], "is_true ()" ); +} + +sub is_false +{ + @_ == 1 or croak "Expected 1 param"; + my $tb = $CLASS->builder(); + $tb->ok( !$_[0], "is_false()" ); +} + +sub is_defined +{ + @_ < 1 or croak "Expected 0..1 param"; + my $tb = $CLASS->builder(); + $tb->ok( defined( $_[0] ), "is_defined ()" ); +} + +sub is_undef +{ + @_ <= 1 or croak "Expected 0..1 param"; + my $tb = $CLASS->builder(); + $tb->ok( !defined( $_[0] ), "is_undef()" ); +} + +sub is_dying +{ + @_ == 1 or croak "Expected 1 param"; + my $tb = $CLASS->builder(); + eval { $_[0]->(); }; + $tb->ok( $@, "is_dying()" ); +} + +my @bigary = (1) x 500; + +sub func { } + +sub grow_stack +{ + func(@bigary); +} + +my $have_test_leak_trace = eval { require Test::LeakTrace; 1 }; + +sub leak_free_ok +{ + my $name = shift; + my $code = shift; + SKIP: + { + skip 'Test::LeakTrace not installed', 1 unless $have_test_leak_trace; + local $Test::Builder::Level = $Test::Builder::Level + 1; + &Test::LeakTrace::no_leaks_ok( $code, "No memory leaks in $name" ); + } +} + +{ + + package DieOnStringify; + use overload '""' => \&stringify; + sub new { bless {}, shift } + sub stringify { die 'DieOnStringify exception' } +} + +1; diff --git a/t/pureperl/Functions.t b/t/pureperl/Functions.t new file mode 100644 index 0000000..41e00df --- /dev/null +++ b/t/pureperl/Functions.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 1; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::Functions; + +LMU::Test::Functions->run_tests; + diff --git a/t/pureperl/Import.t b/t/pureperl/Import.t new file mode 100644 index 0000000..1753a51 --- /dev/null +++ b/t/pureperl/Import.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 1; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::Import; + +LMU::Test::Import->run_tests; + diff --git a/t/pureperl/XS.t b/t/pureperl/XS.t new file mode 100644 index 0000000..9a97f86 --- /dev/null +++ b/t/pureperl/XS.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 1; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::XS; + +LMU::Test::XS->run_tests; + diff --git a/t/pureperl/ab.t b/t/pureperl/ab.t new file mode 100644 index 0000000..09fd1ce --- /dev/null +++ b/t/pureperl/ab.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 1; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::ab; + +LMU::Test::ab->run_tests; + diff --git a/t/xs/Functions.t b/t/xs/Functions.t new file mode 100644 index 0000000..6746f59 --- /dev/null +++ b/t/xs/Functions.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 0; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::Functions; + +LMU::Test::Functions->run_tests; + diff --git a/t/xs/Import.t b/t/xs/Import.t new file mode 100644 index 0000000..51ff04c --- /dev/null +++ b/t/xs/Import.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 0; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::Import; + +LMU::Test::Import->run_tests; + diff --git a/t/xs/XS.t b/t/xs/XS.t new file mode 100644 index 0000000..75942d7 --- /dev/null +++ b/t/xs/XS.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 0; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::XS; + +LMU::Test::XS->run_tests; + diff --git a/t/xs/ab.t b/t/xs/ab.t new file mode 100644 index 0000000..f98b933 --- /dev/null +++ b/t/xs/ab.t @@ -0,0 +1,10 @@ +#!perl + +use lib ("t/lib"); +$ENV{LIST_MOREUTILS_PP} = 0; +END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS + +require LMU::Test::ab; + +LMU::Test::ab->run_tests; + |