[perl/f12/master] Update thread to 1.79 and threads::shared 1.34.
Marcela Mašláňová
mmaslano at fedoraproject.org
Tue Oct 12 16:01:39 UTC 2010
commit 541c0011f10ef6096347330e533b24d06aed61b5
Author: Marcela Mašláňová <mmaslano at redhat.com>
Date: Tue Oct 12 17:16:31 2010 +0200
Update thread to 1.79 and threads::shared 1.34.
free2.t can't load test.pl correctly, which makes it fails in koji,
but it works correctly as local test. Update to threads::shared
was necessary, because previous version (in previous update) wasn't
compatible with this perl release.
manifest.patch | 40 +
perl-update-thread.patch |10020 +++++++++++++++++++++++++++++++++++
perl-update-threadsshared.patch |11158 ++++++++++++++++++++++++++++++++++-----
perl.spec | 30 +-
4 files changed, 19879 insertions(+), 1369 deletions(-)
---
diff --git a/manifest.patch b/manifest.patch
new file mode 100644
index 0000000..f11642a
--- /dev/null
+++ b/manifest.patch
@@ -0,0 +1,40 @@
+diff -up perl-5.10.0/MANIFEST.newmanifest perl-5.10.0/MANIFEST
+--- perl-5.10.0/MANIFEST.newmanifest 2010-10-12 11:21:25.346237001 +0200
++++ perl-5.10.0/MANIFEST 2010-10-12 11:23:55.260237012 +0200
+@@ -1170,16 +1170,15 @@ ext/threads/shared/t/av_refs.t Tests for
+ ext/threads/shared/t/av_simple.t Tests for basic shared array functionality.
+ ext/threads/shared/t/blessed.t Test blessed shared variables
+ ext/threads/shared/t/cond.t Test condition variables
++ext/threads/shared/t/clone.t Test
+ ext/threads/shared/t/disabled.t Test threads::shared when threads are disabled.
+ ext/threads/shared/t/hv_refs.t Test shared hashes containing references
+-ext/threads/shared/t/hv_simple.t Tests for basic shared hash functionality.
+ ext/threads/shared/t/no_share.t Tests for disabled share on variables.
++ext/threads/shared/t/object.t Test
+ ext/threads/shared/t/shared_attr.t Test :shared attribute
+ ext/threads/shared/t/stress.t Stress test
+ ext/threads/shared/t/sv_refs.t thread shared variables
+ ext/threads/shared/t/sv_simple.t thread shared variables
+-ext/threads/shared/t/waithires.t Test sub-second cond_timedwait
+-ext/threads/shared/t/wait.t Test cond_wait and cond_timedwait
+ ext/threads/t/basic.t ithreads
+ ext/threads/t/blocks.t Test threads in special blocks
+ ext/threads/t/context.t Explicit thread context
+@@ -2816,10 +2815,16 @@ lib/Text/TabsWrap/t/wrap.t See if Text::
+ lib/Text/Wrap.pm Paragraph formatter
+ lib/Thread.pm Thread extensions frontend
+ lib/Thread/Queue.pm Threadsafe queue
+-lib/Thread/Queue.t See if threadsafe queue works
+ lib/Thread/Semaphore.pm Threadsafe semaphore
+ lib/Thread/Semaphore.t See if threadsafe semaphore works
+ lib/Thread.t Thread extensions frontend tests
++lib/Thread/Queue/t/01_basic.t Test
++lib/Thread/Queue/t/03_peek.t Test
++lib/Thread/Queue/t/04_errs.t Test
++lib/Thread/Queue/t/05_extract.t Test
++lib/Thread/Queue/t/06_insert.t Test
++lib/Thread/Queue/t/07_lock.t Test
++lib/Thread/Queue/t/08_nothreads.t Test
+ lib/Tie/Array.pm Base class for tied arrays
+ lib/Tie/Array/push.t Test for Tie::Array
+ lib/Tie/Array/splice.t Test for Tie::Array::SPLICE
diff --git a/perl-update-thread.patch b/perl-update-thread.patch
new file mode 100644
index 0000000..d05f317
--- /dev/null
+++ b/perl-update-thread.patch
@@ -0,0 +1,10020 @@
+diff -up perl-5.10.0/ext/threads/ppport.h.tr perl-5.10.0/ext/threads/ppport.h
+--- perl-5.10.0/ext/threads/ppport.h.tr 2010-10-12 11:41:12.375237001 +0200
++++ perl-5.10.0/ext/threads/ppport.h 2010-10-12 11:41:12.375237001 +0200
+@@ -0,0 +1,7063 @@
++#if 0
++<<'SKIP';
++#endif
++/*
++----------------------------------------------------------------------
++
++ ppport.h -- Perl/Pollution/Portability Version 3.19
++
++ Automatically created by Devel::PPPort running under perl 5.010000.
++
++ 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.19
++
++=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.10.0.
++
++=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
++automagially 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
++ 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
++ 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
++ 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 using the CPAN Request Tracker at L<http://rt.cpan.org/>.
++
++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-2009, 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.19;
++
++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(
++AvFILLp|5.004050||p
++AvFILL|||
++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||p
++Copy|||
++CvPADLIST|||
++CvSTASH|||
++CvWEAKOUTSIDE|||
++DEFSV_set|5.011000||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|||
++GvSVn|5.009003||p
++GvSV|||
++Gv_AMupdate|||
++HEf_SVKEY||5.004000|
++HeHASH||5.004000|
++HeKEY||5.004000|
++HeKLEN||5.004000|
++HePV||5.004000|
++HeSVKEY_force||5.004000|
++HeSVKEY_set||5.004000|
++HeSVKEY||5.004000|
++HeUTF8||5.011000|
++HeVAL||5.004000|
++HvNAMELEN_get|5.009003||p
++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|||
++LVRET|||
++MARK|||
++MULTICALL||5.011000|
++MY_CXT_CLONE|5.009002||p
++MY_CXT_INIT|5.007003||p
++MY_CXT|5.007003||p
++MoveD|5.009002||p
++Move|||
++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|||
++ORIGMARK|||
++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_DUP|||
++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.011000||p
++PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
++PERL_HASH|5.004000||p
++PERL_INT_MAX|5.004000||p
++PERL_INT_MIN|5.004000||p
++PERL_LONG_MAX|5.004000||p
++PERL_LONG_MIN|5.004000||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.011000||p
++PERL_MAGIC_isaelem|5.007002||p
++PERL_MAGIC_isa|5.007002||p
++PERL_MAGIC_mutex|5.011000||p
++PERL_MAGIC_nkeys|5.007002||p
++PERL_MAGIC_overload_elem|5.007002||p
++PERL_MAGIC_overload_table|5.007002||p
++PERL_MAGIC_overload|5.007002||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.004000||p
++PERL_QUAD_MIN|5.004000||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.004000||p
++PERL_SHORT_MIN|5.004000||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.011000|
++PERL_UCHAR_MAX|5.004000||p
++PERL_UCHAR_MIN|5.004000||p
++PERL_UINT_MAX|5.004000||p
++PERL_UINT_MIN|5.004000||p
++PERL_ULONG_MAX|5.004000||p
++PERL_ULONG_MIN|5.004000||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.004000||p
++PERL_UQUAD_MIN|5.004000||p
++PERL_USE_GCC_BRACE_GROUPS|5.009004||p
++PERL_USHORT_MAX|5.004000||p
++PERL_USHORT_MIN|5.004000||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.011000||p
++PL_bufptr|5.011000||p
++PL_compiling|5.004050||p
++PL_copline|5.011000||p
++PL_curcop|5.004050||p
++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.011000||p
++PL_expect|5.011000||p
++PL_hexdigit|5.005000||p
++PL_hints|5.005000||p
++PL_in_my_stash|5.011000||p
++PL_in_my|5.011000||p
++PL_last_in_gv|||n
++PL_laststatval|5.005000||p
++PL_lex_state|5.011000||p
++PL_lex_stuff|5.011000||p
++PL_linestr|5.011000||p
++PL_modglobal||5.005000|n
++PL_na|5.004050||pn
++PL_no_modify|5.006000||p
++PL_ofsgv|||n
++PL_parser|5.009005||p
++PL_perl_destruct_level|5.004050||p
++PL_perldb|5.004050||p
++PL_ppaddr|5.006000||p
++PL_rsfp_filters|5.004050||p
++PL_rsfp|5.004050||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.011000||p
++POP_MULTICALL||5.011000|
++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.011000|
++PUSHi|||
++PUSHmortal|5.009002||p
++PUSHn|||
++PUSHp|||
++PUSHs|||
++PUSHu|5.004000||p
++PUTBACK|||
++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_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
++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_IV|||
++SVt_NV|||
++SVt_PVAV|||
++SVt_PVCV|||
++SVt_PVHV|||
++SVt_PVMG|||
++SVt_PV|||
++Safefree|||
++Slab_Alloc|||
++Slab_Free|||
++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_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|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|||
++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|||
++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.011000||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
++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_VERSION_BOOTCHECK|||
++XS_VERSION|||
++XSprePUSH|5.006000||p
++XS|||
++ZeroD|5.009002||p
++Zero|||
++_aMY_CXT|5.007003||p
++_pMY_CXT|5.007003||p
++aMY_CXT_|5.007003||p
++aMY_CXT|5.007003||p
++aTHXR_|5.011000||p
++aTHXR|5.011000||p
++aTHX_|5.006000||p
++aTHX|5.006000||p
++add_data|||n
++addmad|||
++allocmy|||
++amagic_call|||
++amagic_cmp_locale|||
++amagic_cmp|||
++amagic_i_ncmp|||
++amagic_ncmp|||
++any_dup|||
++ao|||
++append_elem|||
++append_list|||
++append_madprops|||
++apply_attrs_my|||
++apply_attrs_string||5.006001|
++apply_attrs|||
++apply|||
++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|||
++av_fetch|||
++av_fill|||
++av_iter_p||5.011000|
++av_len|||
++av_make|||
++av_pop|||
++av_push|||
++av_reify|||
++av_shift|||
++av_store|||
++av_undef|||
++av_unshift|||
++ax|||n
++bad_type|||
++bind_match|||
++block_end|||
++block_gimme||5.004000|
++block_start|||
++boolSV|5.004000||p
++boot_core_PerlIO|||
++boot_core_UNIVERSAL|||
++boot_core_mro|||
++bytes_from_utf8||5.007001|
++bytes_to_uni|||n
++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
++calloc||5.007002|n
++cando|||
++cast_i32||5.006000|
++cast_iv||5.006000|
++cast_ulong||5.006000|
++cast_uv||5.006000|
++check_type_and_open|||
++check_uni|||
++checkcomma|||
++checkposixcc|||
++ckWARN|5.006000||p
++ck_anoncode|||
++ck_bitop|||
++ck_concat|||
++ck_defined|||
++ck_delete|||
++ck_die|||
++ck_each|||
++ck_eof|||
++ck_eval|||
++ck_exec|||
++ck_exists|||
++ck_exit|||
++ck_ftst|||
++ck_fun|||
++ck_glob|||
++ck_grep|||
++ck_index|||
++ck_join|||
++ck_lfun|||
++ck_listiob|||
++ck_match|||
++ck_method|||
++ck_null|||
++ck_open|||
++ck_readline|||
++ck_repeat|||
++ck_require|||
++ck_return|||
++ck_rfun|||
++ck_rvconst|||
++ck_sassign|||
++ck_select|||
++ck_shift|||
++ck_sort|||
++ck_spair|||
++ck_split|||
++ck_subr|||
++ck_substr|||
++ck_svconst|||
++ck_trunc|||
++ck_unpack|||
++ckwarn_d||5.009003|
++ckwarn||5.009003|
++cl_and|||n
++cl_anything|||n
++cl_init_zero|||n
++cl_init|||n
++cl_is_anything|||n
++cl_or|||n
++clear_placeholders|||
++closest_cop|||
++convert|||
++cop_free|||
++cr_textfilter|||
++create_eval_scope|||
++croak_nocontext|||vn
++croak_xs_usage||5.011000|
++croak|||v
++csighandler||5.009003|n
++curmad|||
++custom_op_desc||5.007003|
++custom_op_name||5.007003|
++cv_ckproto_len|||
++cv_clone|||
++cv_const_sv||5.004000|
++cv_dump|||
++cv_undef|||
++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.011000||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
++del_sv|||
++delete_eval_scope|||
++delimcpy||5.004000|
++deprecate_old|||
++deprecate|||
++despatch_signals||5.007001|
++destroy_matcher|||
++die_nocontext|||vn
++die_where|||
++die|||v
++dirp_dup|||
++div128|||
++djSP|||
++do_aexec5|||
++do_aexec|||
++do_aspawn|||
++do_binmode||5.004050|
++do_chomp|||
++do_chop|||
++do_close|||
++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_kv|||
++do_magic_dump||5.006000|
++do_msgrcv|||
++do_msgsnd|||
++do_oddball|||
++do_op_dump||5.006000|
++do_op_xmldump|||
++do_open9||5.006000|
++do_openn||5.007001|
++do_open||5.004000|
++do_pmop_dump||5.006000|
++do_pmop_xmldump|||
++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|||
++dump_all||5.006000|
++dump_eval||5.006000|
++dump_exec_pos|||
++dump_fds|||
++dump_form||5.006000|
++dump_indent||5.006000|v
++dump_mstats|||
++dump_packsubs||5.006000|
++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|||
++fetch_cop_label||5.011000|
++filter_add|||
++filter_del|||
++filter_gets|||
++filter_read|||
++find_and_forget_pmops|||
++find_array_subscript|||
++find_beginning|||
++find_byclass|||
++find_hash_subscript|||
++find_in_my_stash|||
++find_runcv||5.008001|
++find_rundefsvoffset||5.009002|
++find_script|||
++find_uninit_var|||
++first_symbol|||n
++fold_constants|||
++forbid_setid|||
++force_ident|||
++force_list|||
++force_next|||
++force_version|||
++force_word|||
++forget_pmop|||
++form_nocontext|||vn
++form||5.004000|v
++fp_dup|||
++fprintf_nocontext|||vn
++free_global_struct|||
++free_tied_hv_pool|||
++free_tmps|||
++gen_constant_list|||
++get_arena|||
++get_aux_mg|||
++get_av|5.006000||p
++get_context||5.006000|n
++get_cvn_flags||5.009005|
++get_cv|5.006000||p
++get_db_sub|||
++get_debug_opts|||
++get_hash_seed|||
++get_hv|5.006000||p
++get_isa_hash|||
++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|||
++glob_assign_ref|||
++gp_dup|||
++gp_free|||
++gp_ref|||
++grok_bin|5.007003||p
++grok_hex|5.007003||p
++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_autoload4||5.004000|
++gv_check|||
++gv_const_sv||5.009003|
++gv_dump||5.006000|
++gv_efullname3||5.004000|
++gv_efullname4||5.006001|
++gv_efullname|||
++gv_ename|||
++gv_fetchfile_flags||5.009005|
++gv_fetchfile|||
++gv_fetchmeth_autoload||5.007003|
++gv_fetchmethod_autoload||5.004000|
++gv_fetchmethod_flags||5.011000|
++gv_fetchmethod|||
++gv_fetchmeth|||
++gv_fetchpvn_flags|5.009002||p
++gv_fetchpvs|5.009004||p
++gv_fetchpv|||
++gv_fetchsv||5.009002|
++gv_fullname3||5.004000|
++gv_fullname4||5.006001|
++gv_fullname|||
++gv_get_super_pkg|||
++gv_handler||5.007001|
++gv_init_sv|||
++gv_init|||
++gv_name_set||5.009004|
++gv_stashpvn|5.004000||p
++gv_stashpvs|5.009003||p
++gv_stashpv|||
++gv_stashsv|||
++he_dup|||
++hek_dup|||
++hfreeentries|||
++hsplit|||
++hv_assert||5.011000|
++hv_auxinit|||n
++hv_backreferences_p|||
++hv_clear_placeholders||5.009001|
++hv_clear|||
++hv_common_key_len||5.010000|
++hv_common||5.010000|
++hv_copy_hints_hv|||
++hv_delayfree_ent||5.004000|
++hv_delete_common|||
++hv_delete_ent||5.004000|
++hv_delete|||
++hv_eiter_p||5.009003|
++hv_eiter_set||5.009003|
++hv_exists_ent||5.004000|
++hv_exists|||
++hv_fetch_ent||5.004000|
++hv_fetchs|5.009003||p
++hv_fetch|||
++hv_free_ent||5.004000|
++hv_iterinit|||
++hv_iterkeysv||5.004000|
++hv_iterkey|||
++hv_iternext_flags||5.008000|
++hv_iternextsv|||
++hv_iternext|||
++hv_iterval|||
++hv_kill_backrefs|||
++hv_ksplit||5.004000|
++hv_magic_check|||n
++hv_magic|||
++hv_name_set||5.009003|
++hv_notallowed|||
++hv_placeholders_get||5.009003|
++hv_placeholders_p||5.009003|
++hv_placeholders_set||5.009003|
++hv_riter_p||5.009003|
++hv_riter_set||5.009003|
++hv_scalar||5.009001|
++hv_store_ent||5.004000|
++hv_store_flags||5.008000|
++hv_stores|5.009004||p
++hv_store|||
++hv_undef|||
++ibcmp_locale||5.004000|
++ibcmp_utf8||5.007003|
++ibcmp|||
++incline|||
++incpush_if_exists|||
++incpush_use_sep|||
++incpush|||
++ingroup|||
++init_argv_symbols|||
++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|
++instr|||
++intro_my|||
++intuit_method|||
++intuit_more|||
++invert|||
++io_close|||
++isALNUMC|5.006000||p
++isALNUM|||
++isALPHA|||
++isASCII|5.006000||p
++isBLANK|5.006001||p
++isCNTRL|5.006000||p
++isDIGIT|||
++isGRAPH|5.006000||p
++isGV_with_GP|5.009004||p
++isLOWER|||
++isPRINT|5.004000||p
++isPSXSPC|5.006001||p
++isPUNCT|5.006000||p
++isSPACE|||
++isUPPER|||
++isXDIGIT|5.006000||p
++is_an_int|||
++is_gv_magical_sv|||
++is_handle_constructor|||n
++is_list_assignment|||
++is_lvalue_sub||5.007001|
++is_uni_alnum_lc||5.006000|
++is_uni_alnumc_lc||5.006000|
++is_uni_alnumc||5.006000|
++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_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.006000|
++is_utf8_alnum||5.006000|
++is_utf8_alpha||5.006000|
++is_utf8_ascii||5.006000|
++is_utf8_char_slow|||n
++is_utf8_char||5.006000|
++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_print||5.006000|
++is_utf8_punct||5.006000|
++is_utf8_space||5.006000|
++is_utf8_string_loclen||5.009003|
++is_utf8_string_loc||5.008001|
++is_utf8_string||5.006001|
++is_utf8_upper||5.006000|
++is_utf8_xdigit||5.006000|
++isa_lookup|||
++items|||n
++ix|||n
++jmaybe|||
++join_exact|||
++keyword|||
++leave_scope|||
++lex_end|||
++lex_start|||
++linklist|||
++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.011000||p
++mPUSHu|5.009002||p
++mXPUSHi|5.009002||p
++mXPUSHn|5.009002||p
++mXPUSHp|5.009002||p
++mXPUSHs|5.011000||p
++mXPUSHu|5.009002||p
++mad_free|||
++madlex|||
++madparse|||
++magic_clear_all_env|||
++magic_clearenv|||
++magic_clearhint|||
++magic_clearisa|||
++magic_clearpack|||
++magic_clearsig|||
++magic_dump||5.006000|
++magic_existspack|||
++magic_freearylen_p|||
++magic_freeovrld|||
++magic_getarylen|||
++magic_getdefelem|||
++magic_getnkeys|||
++magic_getpack|||
++magic_getpos|||
++magic_getsig|||
++magic_getsubstr|||
++magic_gettaint|||
++magic_getuvar|||
++magic_getvec|||
++magic_get|||
++magic_killbackrefs|||
++magic_len|||
++magic_methcall|||
++magic_methpack|||
++magic_nextpack|||
++magic_regdata_cnt|||
++magic_regdatum_get|||
++magic_regdatum_set|||
++magic_scalarpack|||
++magic_set_all_env|||
++magic_setamagic|||
++magic_setarylen|||
++magic_setcollxfrm|||
++magic_setdbline|||
++magic_setdefelem|||
++magic_setenv|||
++magic_sethint|||
++magic_setisa|||
++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_failtable|||
++make_trie|||
++malloc_good_size|||n
++malloced_size|||n
++malloc||5.007002|n
++markstack_grow|||
++matcher_matches_sv|||
++measure_struct|||
++memEQ|5.004000||p
++memNE|5.004000||p
++mem_collxfrm|||
++mem_log_common|||n
++mess_alloc|||
++mess_nocontext|||vn
++mess||5.006000|v
++method_common|||
++mfree||5.007002|n
++mg_clear|||
++mg_copy|||
++mg_dup|||
++mg_find|||
++mg_free|||
++mg_get|||
++mg_length||5.005000|
++mg_localize|||
++mg_magical|||
++mg_set|||
++mg_size||5.005000|
++mini_mktime||5.007002|
++missingterm|||
++mode_from_discipline|||
++modkids|||
++mod|||
++more_bodies|||
++more_sv|||
++moreswitches|||
++mro_get_from_name||5.011000|
++mro_get_linear_isa_dfs|||
++mro_get_linear_isa||5.009005|
++mro_get_private_data||5.011000|
++mro_isa_changed_in|||
++mro_meta_dup|||
++mro_meta_init|||
++mro_method_changed_in||5.009005|
++mro_register||5.011000|
++mro_set_mro||5.011000|
++mro_set_private_data||5.011000|
++mul128|||
++mulexp10|||n
++my_atof2||5.007002|
++my_atof||5.006000|
++my_attrs|||
++my_bcopy|||n
++my_betoh16|||n
++my_betoh32|||n
++my_betoh64|||n
++my_betohi|||n
++my_betohl|||n
++my_betohs|||n
++my_bzero|||n
++my_chsize|||
++my_clearenv|||
++my_cxt_index|||
++my_cxt_init|||
++my_dirfd||5.009005|
++my_exit_jump|||
++my_exit|||
++my_failure_exit||5.004000|
++my_fflush_all||5.006000|
++my_fork||5.007003|n
++my_htobe16|||n
++my_htobe32|||n
++my_htobe64|||n
++my_htobei|||n
++my_htobel|||n
++my_htobes|||n
++my_htole16|||n
++my_htole32|||n
++my_htole64|||n
++my_htolei|||n
++my_htolel|||n
++my_htoles|||n
++my_htonl|||
++my_kid|||
++my_letoh16|||n
++my_letoh32|||n
++my_letoh64|||n
++my_letohi|||n
++my_letohl|||n
++my_letohs|||n
++my_lstat|||
++my_memcmp||5.004000|n
++my_memset|||n
++my_ntohl|||
++my_pclose||5.004000|
++my_popen_list||5.007001|
++my_popen||5.004000|
++my_setenv|||
++my_snprintf|5.009004||pvn
++my_socketpair||5.007003|n
++my_sprintf|5.009003||pvn
++my_stat|||
++my_strftime||5.007002|
++my_strlcat|5.009004||pn
++my_strlcpy|5.009004||pn
++my_swabn|||n
++my_swap|||
++my_unexec|||
++my_vsnprintf||5.009004|n
++need_utf8|||n
++newANONATTRSUB||5.006000|
++newANONHASH|||
++newANONLIST|||
++newANONSUB|||
++newASSIGNOP|||
++newATTRSUB||5.006000|
++newAVREF|||
++newAV|||
++newBINOP|||
++newCONDOP|||
++newCONSTSUB|5.004050||p
++newCVREF|||
++newDEFSVOP|||
++newFORM|||
++newFOROP|||
++newGIVENOP||5.009003|
++newGIVWHENOP|||
++newGP|||
++newGVOP|||
++newGVREF|||
++newGVgen|||
++newHVREF|||
++newHVhv||5.005000|
++newHV|||
++newIO|||
++newLISTOP|||
++newLOGOP|||
++newLOOPEX|||
++newLOOPOP|||
++newMADPROP|||
++newMADsv|||
++newMYSUB|||
++newNULLLIST|||
++newOP|||
++newPADOP|||
++newPMOP|||
++newPROG|||
++newPVOP|||
++newRANGE|||
++newRV_inc|5.004000||p
++newRV_noinc|5.004000||p
++newRV|||
++newSLICEOP|||
++newSTATEOP|||
++newSUB|||
++newSVOP|||
++newSVREF|||
++newSV_type|5.009005||p
++newSVhek||5.009003|
++newSViv|||
++newSVnv|||
++newSVpvf_nocontext|||vn
++newSVpvf||5.004000|v
++newSVpvn_flags|5.011000||p
++newSVpvn_share|5.007001||p
++newSVpvn_utf8|5.011000||p
++newSVpvn|5.004050||p
++newSVpvs_flags|5.011000||p
++newSVpvs_share||5.009003|
++newSVpvs|5.009003||p
++newSVpv|||
++newSVrv|||
++newSVsv|||
++newSVuv|5.006000||p
++newSV|||
++newTOKEN|||
++newUNOP|||
++newWHENOP||5.009003|
++newWHILEOP||5.009003|
++newXS_flags||5.009004|
++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|||
++no_bareword_allowed|||
++no_fh_allowed|||
++no_op|||
++not_a_number|||
++nothreadhook||5.008000|
++nuke_stacks|||
++num_overflow|||n
++offer_nice_chunk|||
++oopsAV|||
++oopsHV|||
++op_clear|||
++op_const_sv|||
++op_dump||5.006000|
++op_free|||
++op_getmad_weak|||
++op_getmad|||
++op_null||5.007002|
++op_refcnt_dec|||
++op_refcnt_inc|||
++op_refcnt_lock||5.009002|
++op_refcnt_unlock||5.009002|
++op_xmldump|||
++open_script|||
++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|||
++packlist||5.008001|
++pad_add_anon|||
++pad_add_name|||
++pad_alloc|||
++pad_block_start|||
++pad_check_dup|||
++pad_compname_type|||
++pad_findlex|||
++pad_findmy|||
++pad_fixup_inner_anons|||
++pad_free|||
++pad_leavemy|||
++pad_new|||
++pad_peg|||n
++pad_push|||
++pad_reset|||
++pad_setsv|||
++pad_sv||5.011000|
++pad_swipe|||
++pad_tidy|||
++pad_undef|||
++parse_body|||
++parse_unicode_opts|||
++parser_dup|||
++parser_free|||
++path_is_absolute|||n
++peep|||
++pending_Slabs_to_ro|||
++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|||
++pmflag|||
++pmop_dump||5.006000|
++pmop_xmldump|||
++pmruntime|||
++pmtrans|||
++pop_scope|||
++pregcomp||5.009005|
++pregexec|||
++pregfree2||5.011000|
++pregfree|||
++prepend_elem|||
++prepend_madprops|||
++printbuf|||
++printf_nocontext|||vn
++process_special_blocks|||
++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_byte|||
++pv_display|5.006000||p
++pv_escape|5.009004||p
++pv_pretty|5.009004||p
++pv_uni_display||5.007003|
++qerror|||
++qsortsvu|||
++re_compile||5.009005|
++re_croak2|||
++re_dup_guts|||
++re_intuit_start||5.009005|
++re_intuit_string||5.006000|
++readpipe_override|||
++realloc||5.007002|n
++reentrant_free|||
++reentrant_init|||
++reentrant_retry|||vn
++reentrant_size|||
++ref_array_or_hash|||
++refcounted_he_chain_2hv|||
++refcounted_he_fetch|||
++refcounted_he_free|||
++refcounted_he_new_common|||
++refcounted_he_new|||
++refcounted_he_value|||
++refkids|||
++refto|||
++ref||5.011000|
++reg_check_named_buff_matched|||
++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_namedseq|||
++reg_node|||
++reg_numbered_buff_fetch|||
++reg_numbered_buff_length|||
++reg_numbered_buff_store|||
++reg_qr_package|||
++reg_recode|||
++reg_scan_name|||
++reg_skipcomment|||
++reg_temp_copy|||
++reganode|||
++regatom|||
++regbranch|||
++regclass_swash||5.009004|
++regclass|||
++regcppop|||
++regcppush|||
++regcurly|||n
++regdump_extflags|||
++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|
++regpiece|||
++regpposixcc|||
++regprop|||
++regrepeat|||
++regtail_study|||
++regtail|||
++regtry|||
++reguni|||
++regwhite|||n
++reg|||
++repeatcpy|||
++report_evil_fh|||
++report_uninit|||
++require_pv||5.006000|
++require_tie_mod|||
++restore_magic|||
++rninstr|||
++rsignal_restore|||
++rsignal_save|||
++rsignal_state||5.004000|
++rsignal||5.004000|
++run_body|||
++run_user_filter|||
++runops_debug||5.005000|
++runops_standard||5.005000|
++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||5.004050|
++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_hek_flags|||n
++save_helem_flags||5.011000|
++save_helem||5.004050|
++save_hints|||
++save_hptr|||
++save_int|||
++save_item|||
++save_iv||5.005000|
++save_lines|||
++save_list|||
++save_long|||
++save_magic|||
++save_mortalizesv||5.007001|
++save_nogv|||
++save_op|||
++save_padsv_and_mortalize||5.011000|
++save_pptr|||
++save_pushi32ptr|||
++save_pushptri32ptr|||
++save_pushptrptr|||
++save_pushptr||5.011000|
++save_re_context||5.006000|
++save_scalar_at|||
++save_scalar|||
++save_set_svflags||5.009000|
++save_shared_pvref||5.007003|
++save_sptr|||
++save_svref|||
++save_vptr||5.006000|
++savepvn|||
++savepvs||5.009003|
++savepv|||
++savesharedpvn||5.009005|
++savesharedpv||5.007003|
++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|||
++scope|||
++screaminstr||5.005000|
++search_const|||
++seed||5.008001|
++sequence_num|||
++sequence_tail|||
++sequence|||
++set_context||5.006000|n
++set_numeric_local||5.006000|
++set_numeric_radix||5.006000|
++set_numeric_standard||5.006000|
++setdefout|||
++share_hek_flags|||
++share_hek||5.004000|
++si_dup|||
++sighandler|||n
++simplify_sort|||
++skipspace0|||
++skipspace1|||
++skipspace2|||
++skipspace|||
++softref2xv|||
++sortcv_stacked|||
++sortcv_xsub|||
++sortcv|||
++sortsv_flags||5.009003|
++sortsv||5.007003|
++space_join_names_mortal|||
++ss_dup|||
++stack_grow|||
++start_force|||
++start_glob|||
++start_subparse||5.004000|
++stashpv_hvname_match||5.011000|
++stdize_locale|||
++store_cop_label|||
++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|||
++sv_2cv|||
++sv_2io|||
++sv_2iuv_common|||
++sv_2iuv_non_preserve|||
++sv_2iv_flags||5.009001|
++sv_2iv|||
++sv_2mortal|||
++sv_2num|||
++sv_2nv|||
++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|||
++sv_bless|||
++sv_cat_decode||5.008001|
++sv_catpv_mg|5.004050||p
++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|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_catxmlpvn|||
++sv_catxmlsv|||
++sv_chop|||
++sv_clean_all|||
++sv_clean_objs|||
++sv_clear|||
++sv_cmp_locale||5.004000|
++sv_cmp|||
++sv_collxfrm|||
++sv_compile_2op||5.008001|
++sv_copypv||5.007003|
++sv_dec|||
++sv_del_backref|||
++sv_derived_from||5.004000|
++sv_destroyable||5.010000|
++sv_does||5.009004|
++sv_dump|||
++sv_dup_inc_multiple|||
++sv_dup|||
++sv_eq|||
++sv_exp_grow|||
++sv_force_normal_flags||5.007001|
++sv_force_normal||5.006000|
++sv_free2|||
++sv_free_arenas|||
++sv_free|||
++sv_gets||5.004000|
++sv_grow|||
++sv_i_ncmp|||
++sv_inc|||
++sv_insert_flags||5.011000|
++sv_insert|||
++sv_isa|||
++sv_isobject|||
++sv_iv||5.005000|
++sv_kill_backrefs|||
++sv_len_utf8||5.006000|
++sv_len|||
++sv_magic_portable|5.011000|5.004000|p
++sv_magicext||5.007003|
++sv_magic|||
++sv_mortalcopy|||
++sv_ncmp|||
++sv_newmortal|||
++sv_newref|||
++sv_nolocking||5.007003|
++sv_nosharing||5.007003|
++sv_nounlocking|||
++sv_nv||5.005000|
++sv_peek||5.005000|
++sv_pos_b2u_midway|||
++sv_pos_b2u||5.006000|
++sv_pos_u2b_cached|||
++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_release_COW|||
++sv_replace|||
++sv_report_used|||
++sv_reset|||
++sv_rvweaken||5.006000|
++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|5.009004||p
++sv_setpv|||
++sv_setref_iv|||
++sv_setref_nv|||
++sv_setref_pvn|||
++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_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||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
++sv_xmlpeek|||
++svtype|||
++swallow_bom|||
++swap_match_buff|||
++swash_fetch||5.007002|
++swash_get|||
++swash_init||5.006000|
++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|||
++tmps_grow||5.006000|
++toLOWER|||
++toUPPER|||
++to_byte_substr|||
++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.007003|
++to_utf8_lower||5.007003|
++to_utf8_substr|||
++to_utf8_title||5.007003|
++to_utf8_upper||5.007003|
++token_free|||
++token_getmad|||
++tokenize_use|||
++tokeq|||
++tokereport|||
++too_few_arguments|||
++too_many_arguments|||
++uiv_2buf|||n
++unlnk|||
++unpack_rec|||
++unpack_str||5.007003|
++unpackstring||5.008001|
++unshare_hek_or_pvn|||
++unshare_hek|||
++unsharepvn||5.004000|
++unwind_handler_stack|||
++update_debugger_info|||
++upg_version||5.009005|
++usage|||
++utf16_to_utf8_reversed||5.006001|
++utf16_to_utf8||5.006001|
++utf8_distance||5.006000|
++utf8_hop||5.006000|
++utf8_length||5.007001|
++utf8_mg_pos_cache_update|||
++utf8_to_bytes||5.006001|
++utf8_to_uvchr||5.007001|
++utf8_to_uvuni||5.007001|
++utf8n_to_uvchr|||
++utf8n_to_uvuni||5.007001|
++utilize|||
++uvchr_to_utf8_flags||5.007003|
++uvchr_to_utf8|||
++uvuni_to_utf8_flags||5.007003|
++uvuni_to_utf8||5.007001|
++validate_suid|||
++varname|||
++vcmp||5.009000|
++vcroak||5.006000|
++vdeb||5.007003|
++vdie_common|||
++vdie_croak_common|||
++vdie|||
++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
++warner_nocontext|||vn
++warner|5.006000|5.004000|pv
++warn|||v
++watch|||
++whichsig|||
++write_no_mem|||
++write_to_stderr|||
++xmldump_all|||
++xmldump_attr|||
++xmldump_eval|||
++xmldump_form|||
++xmldump_indent|||v
++xmldump_packsubs|||
++xmldump_sub|||
++xmldump_vindent|||
++yyerror|||
++yylex|||
++yyparse|||
++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 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 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 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
++#ifndef isALNUMC
++# define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
++#endif
++
++#ifndef isASCII
++# define isASCII(c) ((c) <= 127)
++#endif
++
++#ifndef isCNTRL
++# define isCNTRL(c) ((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
++
++#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);
++#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"
++# else
++# if IVSIZE == INTSIZE
++# define IVdf "d"
++# define UVuf "u"
++# define UVof "o"
++# define UVxf "x"
++# define UVXf "X"
++# endif
++# 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_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
++
++#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 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 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_fetchpvn_flags
++# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
++#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 SvGETMAGIC
++# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
++#endif
++#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
++
++#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 */
++#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 -up perl-5.10.0/ext/threads/t/basic.t.tr perl-5.10.0/ext/threads/t/basic.t
+--- perl-5.10.0/ext/threads/t/basic.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/basic.t 2010-10-12 11:41:12.382237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -31,12 +27,12 @@ sub ok {
+
+ BEGIN {
+ $| = 1;
+- print("1..33\n"); ### Number of tests that will be run ###
++ print("1..34\n"); ### Number of tests that will be run ###
+ };
+
+ use threads;
+
+-if ($threads::VERSION && ! exists($ENV{'PERL_CORE'})) {
++if ($threads::VERSION && ! $ENV{'PERL_CORE'}) {
+ print(STDERR "# Testing threads $threads::VERSION\n");
+ }
+
+@@ -157,12 +153,17 @@ $thrx = threads->object();
+ ok(30, ! defined($thrx), 'No object');
+ $thrx = threads->object(undef);
+ ok(31, ! defined($thrx), 'No object');
+-$thrx = threads->object(0);
+-ok(32, ! defined($thrx), 'No object');
+
+ threads->import('stringify');
+ $thr1 = threads->create(sub {});
+-ok(33, "$thr1" eq $thr1->tid(), 'Stringify');
++ok(32, "$thr1" eq $thr1->tid(), 'Stringify');
+ $thr1->join();
+
++# ->object($tid) works like ->self() when $tid is thread's TID
++$thrx = threads->object(threads->tid());
++ok(33, defined($thrx), 'Main thread object');
++ok(34, 0 == $thrx->tid(), "Check so that tid for threads work for main thread");
++
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/blocks.t.tr perl-5.10.0/ext/threads/t/blocks.t
+--- perl-5.10.0/ext/threads/t/blocks.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/blocks.t 2010-10-12 11:41:12.383237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -55,7 +47,7 @@ sub ok {
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+- print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
++ print(STDERR "# FAIL: $name\n") if (! $ENV{'PERL_CORE'});
+ }
+
+ return ($ok);
+@@ -123,4 +115,6 @@ ok($bthr->join() == 42, 'BEGIN join');
+ redo if ($COUNT < $TOTAL);
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/context.t.tr perl-5.10.0/ext/threads/t/context.t
+--- perl-5.10.0/ext/threads/t/context.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/context.t 2010-10-12 11:41:12.385237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -156,4 +148,6 @@ ok(! defined($ctx), 'Explicit void conte
+ $res = $thr->join();
+ ok(! defined($res), 'Explicit void context');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/end.t.tr perl-5.10.0/ext/threads/t/end.t
+--- perl-5.10.0/ext/threads/t/end.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/end.t 2010-10-12 11:41:12.386237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -75,4 +67,6 @@ sub thread {
+ }
+ threads->create(\&thread)->join();
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/err.t.tr perl-5.10.0/ext/threads/t/err.t
+--- perl-5.10.0/ext/threads/t/err.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/err.t 2010-10-12 11:41:12.387237001 +0200
+@@ -2,12 +2,7 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+-
+- require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
++ require($ENV{PERL_CORE} ? "./test.pl" : './t/test.pl');
+
+ use Config;
+ if (! $Config{'useithreads'}) {
+@@ -67,4 +62,6 @@ $err = $thrx->error();
+ isa_ok($err, 'Foo', 'error object');
+ is($err->{error}, 'bogus', 'error field');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/exit.t.tr perl-5.10.0/ext/threads/t/exit.t
+--- perl-5.10.0/ext/threads/t/exit.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/exit.t 2010-10-12 11:41:12.388237001 +0200
+@@ -2,18 +2,14 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
++ require($ENV{PERL_CORE} ? "./test.pl" : './t/test.pl');
++
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+- exit(0);
++ skip_all(q/Perl not compiled with 'useithreads'/);
+ }
+-
+- require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
+ }
++
+ our $TODO;
+
+ use ExtUtils::testlib;
+@@ -21,13 +17,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- import threads::shared;
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
+- exit(0);
++ if (! eval 'use threads::shared; 1') {
++ skip_all('threads::shared not available');
+ }
+
+ $| = 1;
+@@ -57,7 +48,7 @@ my $rc = $thr->join();
+ ok(! defined($rc), 'Exited: threads->exit()');
+
+
+-run_perl(prog => 'use threads 1.67;' .
++run_perl(prog => 'use threads 1.79;' .
+ 'threads->exit(86);' .
+ 'exit(99);',
+ nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+@@ -107,7 +98,7 @@ $rc = $thr->join();
+ ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
+
+
+-run_perl(prog => 'use threads 1.67 qw(exit thread_only);' .
++run_perl(prog => 'use threads 1.79 qw(exit thread_only);' .
+ 'threads->create(sub { exit(99); })->join();' .
+ 'exit(86);',
+ nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+@@ -117,7 +108,7 @@ run_perl(prog => 'use threads 1.67 qw(ex
+ is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
+ }
+
+-my $out = run_perl(prog => 'use threads 1.67;' .
++my $out = run_perl(prog => 'use threads 1.79;' .
+ 'threads->create(sub {' .
+ ' exit(99);' .
+ '});' .
+@@ -133,7 +124,7 @@ my $out = run_perl(prog => 'use threads
+ like($out, '1 finished and unjoined', "exit(status) in thread");
+
+
+-$out = run_perl(prog => 'use threads 1.67 qw(exit thread_only);' .
++$out = run_perl(prog => 'use threads 1.79 qw(exit thread_only);' .
+ 'threads->create(sub {' .
+ ' threads->set_thread_exit_only(0);' .
+ ' exit(99);' .
+@@ -150,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.6
+ like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
+
+
+-run_perl(prog => 'use threads 1.67;' .
++run_perl(prog => 'use threads 1.79;' .
+ 'threads->create(sub {' .
+ ' $SIG{__WARN__} = sub { exit(99); };' .
+ ' die();' .
+@@ -172,4 +163,6 @@ ok($thr, 'Created: threads->exit() in th
+ $rc = $thr->join();
+ ok(! defined($rc), 'Exited: threads->exit() in thread warn handler');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/free.t.tr perl-5.10.0/ext/threads/t/free.t
+--- perl-5.10.0/ext/threads/t/free.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/free.t 2010-10-12 11:41:12.391237001 +0200
+@@ -2,14 +2,15 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
++ # Import test.pl into its own package
++ {
++ package Test;
++ require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ }
++
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+- exit(0);
++ Test::skip_all(q/Perl not compiled with 'useithreads'/);
+ }
+ }
+
+@@ -18,13 +19,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
+- exit(0);
++ if (! eval 'use threads::shared; 1') {
++ Test::skip_all(q/threads::shared not available/);
+ }
+
+ require Thread::Queue;
+@@ -33,6 +29,7 @@ BEGIN {
+ print("1..29\n"); ### Number of tests that will be run ###
+ }
+
++#Test::watchdog(120); # In case we get stuck
+
+ my $q = Thread::Queue->new();
+ my $TEST = 1;
+@@ -212,4 +209,6 @@ sub threading_3 {
+ }
+ ok($COUNT == 2, "Done - $COUNT threads");
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/threads.h.tr perl-5.10.0/ext/threads/threads.h
+--- perl-5.10.0/ext/threads/threads.h.tr 2010-10-12 11:41:12.376237001 +0200
++++ perl-5.10.0/ext/threads/threads.h 2010-10-12 11:41:12.376237001 +0200
+@@ -0,0 +1,17 @@
++#ifndef _THREADS_H_
++#define _THREADS_H_
++
++/* Needed for 5.8.0 */
++#ifndef CLONEf_JOIN_IN
++# define CLONEf_JOIN_IN 8
++#endif
++#ifndef SAVEBOOL
++# define SAVEBOOL(a)
++#endif
++
++/* Added in 5.11.x */
++#ifndef G_WANT
++# define G_WANT (128|1)
++#endif
++
++#endif
+diff -up perl-5.10.0/ext/threads/threads.pm.tr perl-5.10.0/ext/threads/threads.pm
+--- perl-5.10.0/ext/threads/threads.pm.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/threads.pm 2010-10-12 11:41:12.378237001 +0200
+@@ -5,7 +5,7 @@ use 5.008;
+ use strict;
+ use warnings;
+
+-our $VERSION = '1.67';
++our $VERSION = '1.79';
+ my $XS_VERSION = $VERSION;
+ $VERSION = eval $VERSION;
+
+@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
+
+ =head1 VERSION
+
+-This document describes threads version 1.67
++This document describes threads version 1.79
+
+ =head1 SYNOPSIS
+
+@@ -221,28 +221,38 @@ This document describes threads version
+
+ =head1 DESCRIPTION
+
+-Perl 5.6 introduced something called interpreter threads. Interpreter threads
+-are different from I<5005threads> (the thread model of Perl 5.005) by creating
+-a new Perl interpreter per thread, and not sharing any data or state between
+-threads by default.
+-
+-Prior to Perl 5.8, this has only been available to people embedding Perl, and
+-for emulating fork() on Windows.
+-
+-The I<threads> API is loosely based on the old Thread.pm API. It is very
+-important to note that variables are not shared between threads, all variables
+-are by default thread local. To use shared variables one must also use
+-L<threads::shared>:
++Since Perl 5.8, thread programming has been available using a model called
++I<interpreter threads> which provides a new Perl interpreter for each
++thread, and, by default, results in no data or state information being shared
++between threads.
++
++(Prior to Perl 5.8, I<5005threads> was available through the C<Thread.pm> API.
++This threading model has been deprecated, and was removed as of Perl 5.10.0.)
++
++As just mentioned, all variables are, by default, thread local. To use shared
++variables, you need to also load L<threads::shared>:
+
+ use threads;
+ use threads::shared;
+
+-It is also important to note that you must enable threads by doing C<use
+-threads> as early as possible in the script itself, and that it is not
+-possible to enable threading inside an C<eval "">, C<do>, C<require>, or
+-C<use>. In particular, if you are intending to share variables with
+-L<threads::shared>, you must C<use threads> before you C<use threads::shared>.
+-(C<threads> will emit a warning if you do it the other way around.)
++When loading L<threads::shared>, you must C<use threads> before you
++C<use threads::shared>. (C<threads> will emit a warning if you do it the
++other way around.)
++
++It is strongly recommended that you enable threads via C<use threads> as early
++as possible in your script.
++
++If needed, scripts can be written so as to run on both threaded and
++non-threaded Perls:
++
++ my $can_use_threads = eval 'use threads; 1';
++ if ($can_use_threads) {
++ # Do processing using threads
++ ...
++ } else {
++ # Do it without using threads
++ ...
++ }
+
+ =over
+
+@@ -351,9 +361,10 @@ key) will cause its ID to be used as the
+ =item threads->object($tid)
+
+ This will return the I<threads> object for the I<active> thread associated
+-with the specified thread ID. Returns C<undef> if there is no thread
+-associated with the TID, if the thread is joined or detached, if no TID is
+-specified or if the specified TID is undef.
++with the specified thread ID. If C<$tid> is the value for the current thread,
++then this call works the same as C<-E<gt>self()>. Otherwise, returns C<undef>
++if there is no thread associated with the TID, if the thread is joined or
++detached, if no TID is specified or if the specified TID is undef.
+
+ =item threads->yield()
+
+@@ -892,6 +903,18 @@ other threads are started afterwards.
+ If the above does not work, or is not adequate for your application, then file
+ a bug report on L<http://rt.cpan.org/Public/> against the problematic module.
+
++=item Memory consumption
++
++On most systems, frequent and continual creation and destruction of threads
++can lead to ever-increasing growth in the memory footprint of the Perl
++interpreter. While it is simple to just launch threads and then
++C<-E<gt>join()> or C<-E<gt>detach()> them, for long-lived applications, it is
++better to maintain a pool of threads, and to reuse them for the work needed,
++using L<queues|Thread::Queue> to notify threads of pending work. The CPAN
++distribution of this module contains a simple example
++(F<examples/pool_reuse.pl>) illustrating the creation, use and monitoring of a
++pool of I<reusable> threads.
++
+ =item Current working directory
+
+ On all platforms except MSWin32, the setting for the current working directory
+@@ -963,7 +986,30 @@ of the Perl interpreter.
+ Returning objects from threads does not work. Depending on the classes
+ involved, you may be able to work around this by returning a serialized
+ version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then
+-reconstituting it in the joining thread.
++reconstituting it in the joining thread. If you're using Perl 5.10.0 or
++later, and if the class supports L<shared objects|threads::shared/"OBJECTS">,
++you can pass them via L<shared queues|Thread::Queue>.
++
++=item END blocks in threads
++
++It is possible to add L<END blocks|perlmod/"BEGIN, UNITCHECK, CHECK, INIT and
++END"> to threads by using L<require|perlfunc/"require VERSION"> or
++L<eval|perlfunc/"eval EXPR"> with the appropriate code. These C<END> blocks
++will then be executed when the thread's interpreter is destroyed (i.e., either
++during a C<-E<gt>join()> call, or at program termination).
++
++However, calling any L<threads> methods in such an C<END> block will most
++likely I<fail> (e.g., the application may hang, or generate an error) due to
++mutexes that are needed to control functionality within the L<threads> module.
++
++For this reason, the use of C<END> blocks in threads is B<strongly>
++discouraged.
++
++=item Open directory handles
++
++Spawning threads with open directory handles (see
++L<opendir|perlfunc/"opendir DIRHANDLE,EXPR">) will crash the interpreter.
++L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154>
+
+ =item Perl Bugs and the CPAN Version of L<threads>
+
+@@ -978,6 +1024,10 @@ with threads may result in warning messa
+ unreferenced scalars. However, such warnings are harmless, and may safely be
+ ignored.
+
++You can search for L<threads> related bug reports at
++L<http://rt.cpan.org/Public/>. If needed submit any new bugs, problems,
++patches, etc. to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads>
++
+ =back
+
+ =head1 REQUIREMENTS
+@@ -990,7 +1040,7 @@ L<threads> Discussion Forum on CPAN:
+ L<http://www.cpanforum.com/dist/threads>
+
+ Annotated POD for L<threads>:
+-L<http://annocpan.org/~JDHEDDEN/threads-1.67/threads.pm>
++L<http://annocpan.org/~JDHEDDEN/threads-1.79/threads.pm>
+
+ Source repository:
+ L<http://code.google.com/p/threads-shared/>
+@@ -1010,10 +1060,12 @@ L<http://www.perlmonks.org/?node_id=5329
+
+ Artur Bergman E<lt>sky AT crucially DOT netE<gt>
+
+-threads is released under the same license as Perl.
+-
+ CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
+
++=head1 LICENSE
++
++threads is released under the same license as Perl.
++
+ =head1 ACKNOWLEDGEMENTS
+
+ Richard Soderberg E<lt>perl AT crystalflame DOT netE<gt> -
+diff -up perl-5.10.0/ext/threads/threads.xs.tr perl-5.10.0/ext/threads/threads.xs
+--- perl-5.10.0/ext/threads/threads.xs.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/threads.xs 2010-10-12 11:54:49.342237402 +0200
+@@ -1,21 +1,27 @@
+ #define PERL_NO_GET_CONTEXT
++/* Workaround for mingw 32-bit compiler by mingw-w64.sf.net - has to come before any #include.
++ * It also defines USE_NO_MINGW_SETJMP_TWO_ARGS for the mingw.org 32-bit compilers ... but
++ * that's ok as that compiler makes no use of that symbol anyway */
++#if defined(WIN32) && defined(__MINGW32__) && !defined(__MINGW64__)
++# define USE_NO_MINGW_SETJMP_TWO_ARGS 1
++#endif
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ /* Workaround for XSUB.h bug under WIN32 */
+ #ifdef WIN32
+ # undef setjmp
+-# if !defined(__BORLANDC__)
++# if defined(USE_NO_MINGW_SETJMP_TWO_ARGS) || (!defined(__BORLANDC__) && !defined(__MINGW64__))
+ # define setjmp(x) _setjmp(x)
+ # endif
+ #endif
+-#ifdef HAS_PPPORT_H
++//#ifdef HAS_PPPORT_H
+ # define NEED_PL_signals
+ # define NEED_newRV_noinc
+ # define NEED_sv_2pv_flags
+ # include "ppport.h"
+ # include "threads.h"
+-#endif
++//#endif
+
+ #ifdef USE_ITHREADS
+
+@@ -46,7 +52,7 @@ typedef perl_os_thread pthread_t;
+
+ /* Values for 'state' member */
+ #define PERL_ITHR_DETACHED 1 /* Thread has been detached */
+-#define PERL_ITHR_JOINED 2 /* Thread has been joined */
++#define PERL_ITHR_JOINED 2 /* Thread is being / has been joined */
+ #define PERL_ITHR_FINISHED 4 /* Thread has finished execution */
+ #define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */
+ #define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */
+@@ -65,7 +71,7 @@ typedef struct _ithread {
+ int state; /* Detached, joined, finished, etc. */
+ int gimme; /* Context of create */
+ SV *init_function; /* Code to run */
+- SV *params; /* Args to pass function */
++ AV *params; /* Args to pass function */
+ #ifdef WIN32
+ DWORD thr; /* OS's idea if thread id */
+ HANDLE handle; /* OS's waitable handle */
+@@ -75,6 +81,9 @@ typedef struct _ithread {
+ IV stack_size;
+ SV *err; /* Error from abnormally terminated thread */
+ char *err_class; /* Error object's classname if applicable */
++#ifndef WIN32
++ sigset_t initial_sigmask; /* Thread wakes up with signals blocked */
++#endif
+ } ithread;
+
+
+@@ -114,6 +123,45 @@ typedef struct {
+
+ #define MY_POOL (*my_poolp)
+
++#ifndef WIN32
++/* Block most signals for calling thread, setting the old signal mask to
++ * oldmask, if it is not NULL */
++STATIC int
++S_block_most_signals(sigset_t *oldmask)
++{
++ sigset_t newmask;
++
++ sigfillset(&newmask);
++ /* Don't block certain "important" signals (stolen from mg.c) */
++#ifdef SIGILL
++ sigdelset(&newmask, SIGILL);
++#endif
++#ifdef SIGBUS
++ sigdelset(&newmask, SIGBUS);
++#endif
++#ifdef SIGSEGV
++ sigdelset(&newmask, SIGSEGV);
++#endif
++
++#if defined(VMS)
++ /* no per-thread blocking available */
++ return sigprocmask(SIG_BLOCK, &newmask, oldmask);
++#else
++ return pthread_sigmask(SIG_BLOCK, &newmask, oldmask);
++#endif /* VMS */
++}
++
++/* Set the signal mask for this thread to newmask */
++STATIC int
++S_set_sigmask(sigset_t *newmask)
++{
++#if defined(VMS)
++ return sigprocmask(SIG_SETMASK, newmask, NULL);
++#else
++ return pthread_sigmask(SIG_SETMASK, newmask, NULL);
++#endif /* VMS */
++}
++#endif /* WIN32 */
+
+ /* Used by Perl interpreter for thread context switching */
+ STATIC void
+@@ -142,12 +190,23 @@ STATIC void
+ S_ithread_clear(pTHX_ ithread *thread)
+ {
+ PerlInterpreter *interp;
++#ifndef WIN32
++ sigset_t origmask;
++#endif
+
+ assert(((thread->state & PERL_ITHR_FINISHED) &&
+ (thread->state & PERL_ITHR_UNCALLABLE))
+ ||
+ (thread->state & PERL_ITHR_NONVIABLE));
+
++#ifndef WIN32
++ /* We temporarily set the interpreter context to the interpreter being
++ * destroyed. It's in no condition to handle signals while it's being
++ * taken apart.
++ */
++ S_block_most_signals(&origmask);
++#endif
++
+ interp = thread->interp;
+ if (interp) {
+ dTHXa(interp);
+@@ -156,7 +215,7 @@ S_ithread_clear(pTHX_ ithread *thread)
+ S_ithread_set(aTHX_ thread);
+
+ SvREFCNT_dec(thread->params);
+- thread->params = Nullsv;
++ thread->params = NULL;
+
+ if (thread->err) {
+ SvREFCNT_dec(thread->err);
+@@ -169,6 +228,9 @@ S_ithread_clear(pTHX_ ithread *thread)
+ }
+
+ PERL_SET_CONTEXT(aTHX);
++#ifndef WIN32
++ S_set_sigmask(&origmask);
++#endif
+ }
+
+
+@@ -356,7 +418,7 @@ S_good_stack_size(pTHX_ IV stack_size)
+ # endif
+ if ((long)MY_POOL.page_size < 0) {
+ if (errno) {
+- SV * const error = get_sv("@", FALSE);
++ SV * const error = get_sv("@", 0);
+ (void)SvUPGRADE(error, SVt_PV);
+ Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error));
+ } else {
+@@ -415,10 +477,17 @@ S_ithread_run(void * arg)
+ PERL_SET_CONTEXT(thread->interp);
+ S_ithread_set(aTHX_ thread);
+
++#ifndef WIN32
++ /* Thread starts with most signals blocked - restore the signal mask from
++ * the ithread struct.
++ */
++ S_set_sigmask(&thread->initial_sigmask);
++#endif
++
+ PL_perl_destruct_level = 2;
+
+ {
+- AV *params = (AV *)SvRV(thread->params);
++ AV *params = thread->params;
+ int len = (int)av_len(params)+1;
+ int ii;
+
+@@ -448,11 +517,19 @@ S_ithread_run(void * arg)
+ }
+ JMPENV_POP;
+
++#ifndef WIN32
++ /* The interpreter is finished, so this thread can stop receiving
++ * signals. This way, our signal handler doesn't get called in the
++ * middle of our parent thread calling perl_destruct()...
++ */
++ S_block_most_signals(NULL);
++#endif
++
+ /* Remove args from stack and put back in params array */
+ SPAGAIN;
+ for (ii=len-1; ii >= 0; ii--) {
+ SV *sv = POPs;
+- if (jmp_rc == 0 && (! (thread->gimme & G_VOID))) {
++ if (jmp_rc == 0 && (thread->gimme & G_WANT) != G_VOID) {
+ av_store(params, ii, SvREFCNT_inc(sv));
+ }
+ }
+@@ -598,13 +675,18 @@ S_ithread_create(
+ IV stack_size,
+ int gimme,
+ int exit_opt,
+- SV *params)
++ SV **params_start,
++ SV **params_end)
+ {
+ ithread *thread;
+ ithread *current_thread = S_ithread_get(aTHX);
++ AV *params;
++ SV **array;
+
++#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
+ SV **tmps_tmp = PL_tmps_stack;
+ IV tmps_ix = PL_tmps_ix;
++#endif
+ #ifndef WIN32
+ int rc_stack_size = 0;
+ int rc_thread_create = 0;
+@@ -660,6 +742,27 @@ S_ithread_create(
+ PL_srand_called = FALSE; /* Set it to false so we can detect if it gets
+ set during the clone */
+
++#ifndef WIN32
++ /* perl_clone() will leave us the new interpreter's context. This poses
++ * two problems for our signal handler. First, it sets the new context
++ * before the new interpreter struct is fully initialized, so our signal
++ * handler might find bogus data in the interpreter struct it gets.
++ * Second, even if the interpreter is initialized before a signal comes in,
++ * we would like to avoid that interpreter receiving notifications for
++ * signals (especially when they ought to be for the one running in this
++ * thread), until it is running in its own thread. Another problem is that
++ * the new thread will not have set the context until some time after it
++ * has started, so it won't be safe for our signal handler to run until
++ * that time.
++ *
++ * So we block most signals here, so the new thread will inherit the signal
++ * mask, and unblock them right after the thread creation. The original
++ * mask is saved in the thread struct so that the new thread can restore
++ * the original mask.
++ */
++ S_block_most_signals(&thread->initial_sigmask);
++#endif
++
+ #ifdef WIN32
+ thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
+ #else
+@@ -681,7 +784,7 @@ S_ithread_create(
+ * they are created
+ */
+ SvREFCNT_dec(PL_endav);
+- PL_endav = newAV();
++ PL_endav = NULL;
+
+ clone_param.flags = 0;
+ if (SvPOK(init_function)) {
+@@ -689,12 +792,18 @@ S_ithread_create(
+ sv_copypv(thread->init_function, init_function);
+ } else {
+ thread->init_function =
+- SvREFCNT_inc(sv_dup(init_function, &clone_param));
++ SvREFCNT_inc(sv_dup(init_function, &clone_param));
+ }
+
+- thread->params = sv_dup(params, &clone_param);
+- SvREFCNT_inc_void(thread->params);
++ thread->params = params = newAV();
++ av_extend(params, params_end - params_start - 1);
++ AvFILLp(params) = params_end - params_start - 1;
++ array = AvARRAY(params);
++ while (params_start < params_end) {
++ *array++ = SvREFCNT_inc(sv_dup(*params_start++, &clone_param));
++ }
+
++#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
+ /* The code below checks that anything living on the tmps stack and
+ * has been cloned (so it lives in the ptr_table) has a refcount
+ * higher than 0.
+@@ -707,7 +816,7 @@ S_ithread_create(
+ * Example of this can be found in bugreport 15837 where calls in the
+ * parameter list end up as a temp.
+ *
+- * One could argue that this fix should be in perl_clone.
++ * As of 5.8.8 this is done in perl_clone.
+ */
+ while (tmps_ix > 0) {
+ SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
+@@ -717,6 +826,7 @@ S_ithread_create(
+ SvREFCNT_dec(sv);
+ }
+ }
++#endif
+
+ SvTEMP_off(thread->init_function);
+ ptr_table_free(PL_ptr_table);
+@@ -774,6 +884,13 @@ S_ithread_create(
+ # endif
+ }
+
++#ifndef WIN32
++ /* Now it's safe to accept signals, since we're in our own interpreter's
++ * context and we have created the thread.
++ */
++ S_set_sigmask(&thread->initial_sigmask);
++#endif
++
+ # ifdef _POSIX_THREAD_ATTR_STACKSIZE
+ /* Try to get thread's actual stack size */
+ {
+@@ -799,7 +916,6 @@ S_ithread_create(
+ #endif
+ /* Must unlock mutex for destruct call */
+ MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
+- sv_2mortal(params);
+ thread->state |= PERL_ITHR_NONVIABLE;
+ S_ithread_free(aTHX_ thread); /* Releases MUTEX */
+ #ifndef WIN32
+@@ -815,7 +931,6 @@ S_ithread_create(
+ }
+
+ MY_POOL.running_threads++;
+- sv_2mortal(params);
+ return (thread);
+ }
+
+@@ -833,7 +948,6 @@ ithread_create(...)
+ char *classname;
+ ithread *thread;
+ SV *function_to_call;
+- AV *params;
+ HV *specs;
+ IV stack_size;
+ int context;
+@@ -841,7 +955,8 @@ ithread_create(...)
+ SV *thread_exit_only;
+ char *str;
+ int idx;
+- int ii;
++ SV **args_start;
++ SV **args_end;
+ dMY_POOL;
+ CODE:
+ if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
+@@ -870,7 +985,7 @@ ithread_create(...)
+ /* threads->create() */
+ classname = (char *)SvPV_nolen(ST(0));
+ stack_size = MY_POOL.default_stack_size;
+- thread_exit_only = get_sv("threads::thread_exit_only", TRUE);
++ thread_exit_only = get_sv("threads::thread_exit_only", GV_ADD);
+ exit_opt = (SvTRUE(thread_exit_only))
+ ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
+ }
+@@ -879,18 +994,19 @@ ithread_create(...)
+
+ context = -1;
+ if (specs) {
++ SV **svp;
+ /* stack_size */
+- if (hv_exists(specs, "stack", 5)) {
+- stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
+- } else if (hv_exists(specs, "stacksize", 9)) {
+- stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
+- } else if (hv_exists(specs, "stack_size", 10)) {
+- stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
++ if ((svp = hv_fetch(specs, "stack", 5, 0))) {
++ stack_size = SvIV(*svp);
++ } else if ((svp = hv_fetch(specs, "stacksize", 9, 0))) {
++ stack_size = SvIV(*svp);
++ } else if ((svp = hv_fetch(specs, "stack_size", 10, 0))) {
++ stack_size = SvIV(*svp);
+ }
+
+ /* context */
+- if (hv_exists(specs, "context", 7)) {
+- str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
++ if ((svp = hv_fetch(specs, "context", 7, 0))) {
++ str = (char *)SvPV_nolen(*svp);
+ switch (*str) {
+ case 'a':
+ case 'A':
+@@ -909,27 +1025,27 @@ ithread_create(...)
+ default:
+ Perl_croak(aTHX_ "Invalid context: %s", str);
+ }
+- } else if (hv_exists(specs, "array", 5)) {
+- if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
++ } else if ((svp = hv_fetch(specs, "array", 5, 0))) {
++ if (SvTRUE(*svp)) {
+ context = G_ARRAY;
+ }
+- } else if (hv_exists(specs, "list", 4)) {
+- if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) {
++ } else if ((svp = hv_fetch(specs, "list", 4, 0))) {
++ if (SvTRUE(*svp)) {
+ context = G_ARRAY;
+ }
+- } else if (hv_exists(specs, "scalar", 6)) {
+- if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
++ } else if ((svp = hv_fetch(specs, "scalar", 6, 0))) {
++ if (SvTRUE(*svp)) {
+ context = G_SCALAR;
+ }
+- } else if (hv_exists(specs, "void", 4)) {
+- if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
++ } else if ((svp = hv_fetch(specs, "void", 4, 0))) {
++ if (SvTRUE(*svp)) {
+ context = G_VOID;
+ }
+ }
+
+ /* exit => thread_only */
+- if (hv_exists(specs, "exit", 4)) {
+- str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0));
++ if ((svp = hv_fetch(specs, "exit", 4, 0))) {
++ str = (char *)SvPV_nolen(*svp);
+ exit_opt = (*str == 't' || *str == 'T')
+ ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
+ }
+@@ -941,11 +1057,11 @@ ithread_create(...)
+ }
+
+ /* Function args */
+- params = newAV();
++ args_start = &ST(idx + 2);
+ if (items > 2) {
+- for (ii=2; ii < items ; ii++) {
+- av_push(params, SvREFCNT_inc(ST(idx+ii)));
+- }
++ args_end = &ST(idx + items);
++ } else {
++ args_end = args_start;
+ }
+
+ /* Create thread */
+@@ -954,7 +1070,8 @@ ithread_create(...)
+ stack_size,
+ context,
+ exit_opt,
+- newRV_noinc((SV*)params));
++ args_start,
++ args_end);
+ if (! thread) {
+ XSRETURN_UNDEF; /* Mutex already unlocked */
+ }
+@@ -1122,12 +1239,12 @@ ithread_join(...)
+ MUTEX_LOCK(&thread->mutex);
+ /* Get the return value from the call_sv */
+ /* Objects do not survive this process - FIXME */
+- if (! (thread->gimme & G_VOID)) {
++ if ((thread->gimme & G_WANT) != G_VOID) {
+ AV *params_copy;
+ PerlInterpreter *other_perl;
+ CLONE_PARAMS clone_params;
+
+- params_copy = (AV *)SvRV(thread->params);
++ params_copy = thread->params;
+ other_perl = thread->interp;
+ clone_params.stashes = newAV();
+ clone_params.flags = CLONEf_JOIN_IN;
+@@ -1228,6 +1345,7 @@ ithread_kill(...)
+ ithread *thread;
+ char *sig_name;
+ IV signal;
++ int no_handler = 1;
+ CODE:
+ /* Must have safe signals */
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
+@@ -1257,11 +1375,21 @@ ithread_kill(...)
+ MUTEX_LOCK(&thread->mutex);
+ if (thread->interp) {
+ dTHXa(thread->interp);
+- PL_psig_pend[signal]++;
+- PL_sig_pending = 1;
++ if (PL_psig_pend && PL_psig_ptr[signal]) {
++ PL_psig_pend[signal]++;
++ PL_sig_pending = 1;
++ no_handler = 0;
++ }
++ } else {
++ /* Ignore signal to terminated thread */
++ no_handler = 0;
+ }
+ MUTEX_UNLOCK(&thread->mutex);
+
++ if (no_handler) {
++ Perl_croak(aTHX_ "Signal %s received in thread %"UVuf", but no signal handler set.", sig_name, thread->tid);
++ }
++
+ /* Return the thread to allow for method chaining */
+ ST(0) = ST(0);
+ /* XSRETURN(1); - implied */
+@@ -1300,6 +1428,7 @@ void
+ ithread_object(...)
+ PREINIT:
+ char *classname;
++ SV *arg;
+ UV tid;
+ ithread *thread;
+ int state;
+@@ -1312,34 +1441,47 @@ ithread_object(...)
+ }
+ classname = (char *)SvPV_nolen(ST(0));
+
+- if ((items < 2) || ! SvOK(ST(1))) {
++ /* Turn $tid from PVLV to SV if needed (bug #73330) */
++ arg = ST(1);
++ SvGETMAGIC(arg);
++
++ if ((items < 2) || ! SvOK(arg)) {
+ XSRETURN_UNDEF;
+ }
+
+ /* threads->object($tid) */
+- tid = SvUV(ST(1));
++ tid = SvUV(arg);
+
+- /* Walk through threads list */
+- MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
+- for (thread = MY_POOL.main_thread.next;
+- thread != &MY_POOL.main_thread;
+- thread = thread->next)
+- {
+- /* Look for TID */
+- if (thread->tid == tid) {
+- /* Ignore if detached or joined */
+- MUTEX_LOCK(&thread->mutex);
+- state = thread->state;
+- MUTEX_UNLOCK(&thread->mutex);
+- if (! (state & PERL_ITHR_UNCALLABLE)) {
+- /* Put object on stack */
+- ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+- have_obj = 1;
++ /* If current thread wants its own object, then behave the same as
++ ->self() */
++ thread = S_ithread_get(aTHX);
++ if (thread->tid == tid) {
++ ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
++ have_obj = 1;
++
++ } else {
++ /* Walk through threads list */
++ MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
++ for (thread = MY_POOL.main_thread.next;
++ thread != &MY_POOL.main_thread;
++ thread = thread->next)
++ {
++ /* Look for TID */
++ if (thread->tid == tid) {
++ /* Ignore if detached or joined */
++ MUTEX_LOCK(&thread->mutex);
++ state = thread->state;
++ MUTEX_UNLOCK(&thread->mutex);
++ if (! (state & PERL_ITHR_UNCALLABLE)) {
++ /* Put object on stack */
++ ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
++ have_obj = 1;
++ }
++ break;
+ }
+- break;
+ }
++ MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
+ }
+- MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
+
+ if (! have_obj) {
+ XSRETURN_UNDEF;
+@@ -1459,9 +1601,9 @@ ithread_wantarray(...)
+ CODE:
+ PERL_UNUSED_VAR(items);
+ thread = S_SV_to_ithread(aTHX_ ST(0));
+- ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes :
+- (thread->gimme & G_VOID) ? &PL_sv_undef
+- /* G_SCALAR */ : &PL_sv_no;
++ ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes :
++ ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef
++ /* G_SCALAR */ : &PL_sv_no;
+ /* XSRETURN(1); - implied */
+
+
+diff -up perl-5.10.0/ext/threads/t/join.t.tr perl-5.10.0/ext/threads/t/join.t
+--- perl-5.10.0/ext/threads/t/join.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/join.t 2010-10-12 11:41:12.392237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -57,7 +49,7 @@ sub ok {
+ }
+
+ sub skip {
+- ok(1, '# Skipped: ' . $_[0]);
++ ok(1, '# SKIP ' . $_[0]);
+ }
+
+
+@@ -228,4 +220,6 @@ if ($^O eq 'linux') {
+ $joiner->join;
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/kill2.t.tr perl-5.10.0/ext/threads/t/kill2.t
+--- perl-5.10.0/ext/threads/t/kill2.t.tr 2010-10-12 11:41:12.394237001 +0200
++++ perl-5.10.0/ext/threads/t/kill2.t 2010-10-12 11:41:12.393237001 +0200
+@@ -0,0 +1,91 @@
++use strict;
++use warnings;
++
++BEGIN {
++ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
++
++ use Config;
++ if (! $Config{'useithreads'}) {
++ skip_all(q/Perl not compiled with 'useithreads'/);
++ }
++}
++
++use ExtUtils::testlib;
++
++use threads;
++
++BEGIN {
++ if (! eval 'use threads::shared; 1') {
++ skip_all('threads::shared not available');
++ }
++
++ local $SIG{'HUP'} = sub {};
++ my $thr = threads->create(sub {});
++ eval { $thr->kill('HUP') };
++ $thr->join();
++ if ($@ && $@ =~ /safe signals/) {
++ skip_all('Not using safe signals');
++ }
++
++ plan(3);
++};
++
++fresh_perl_is(<<'EOI', 'ok', { }, 'No signal handler in thread');
++ use threads;
++ use Thread::Semaphore;
++ my $sema = Thread::Semaphore->new(0);
++ my $test = sub {
++ my $sema = shift;
++ $sema->up();
++ while(1) { sleep(1); }
++ };
++ my $thr = threads->create($test, $sema);
++ $sema->down();
++ $thr->detach();
++ eval {
++ $thr->kill('STOP');
++ };
++ print(($@ =~ /no signal handler set/) ? 'ok' : 'not ok');
++EOI
++
++fresh_perl_is(<<'EOI', 'ok', { }, 'Handler to signal mismatch');
++ use threads;
++ use Thread::Semaphore;
++ my $sema = Thread::Semaphore->new(0);
++ my $test = sub {
++ my $sema = shift;
++ $SIG{'TERM'} = sub { threads->exit() };
++ $sema->up();
++ while(1) { sleep(1); }
++ };
++ my $thr = threads->create($test, $sema);
++ $sema->down();
++ $thr->detach();
++ eval {
++ $thr->kill('STOP');
++ };
++ print(($@ =~ /no signal handler set/) ? 'ok' : 'not ok');
++EOI
++
++fresh_perl_is(<<'EOI', 'ok', { }, 'Handler and signal match');
++ use threads;
++ use Thread::Semaphore;
++ my $sema = Thread::Semaphore->new(0);
++ my $test = sub {
++ my $sema = shift;
++ $SIG{'STOP'} = sub { threads->exit() };
++ $sema->up();
++ while(1) { sleep(1); }
++ };
++ my $thr = threads->create($test, $sema);
++ $sema->down();
++ $thr->detach();
++ eval {
++ $thr->kill('STOP');
++ };
++ print((! $@) ? 'ok' : 'not ok');
++EOI
++
++exit(0);
++
++# EOF
+diff -up perl-5.10.0/ext/threads/t/kill.t.tr perl-5.10.0/ext/threads/t/kill.t
+--- perl-5.10.0/ext/threads/t/kill.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/kill.t 2010-10-12 11:41:12.395237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -32,7 +24,7 @@ BEGIN {
+ eval { $thr->kill('HUP') };
+ $thr->join();
+ if ($@ && $@ =~ /safe signals/) {
+- print("1..0 # Skip: Not using safe signals\n");
++ print("1..0 # SKIP Not using safe signals\n");
+ exit(0);
+ }
+
+@@ -175,4 +167,6 @@ ok($rc eq 'OKAY', 'Thread return value')
+
+ ok($thr->kill('TERM') == $thr, 'Ignore signal to terminated thread');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/libc.t.tr perl-5.10.0/ext/threads/t/libc.t
+--- perl-5.10.0/ext/threads/t/libc.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/libc.t 2010-10-12 11:41:12.396237001 +0200
+@@ -2,12 +2,7 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+-
+- require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
++ require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+
+ use Config;
+ if (! $Config{'useithreads'}) {
+@@ -51,4 +46,6 @@ for (1..$i) {
+ is($threads[$_]->join(), 0, 'localtime() thread-safe');
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/list.t.tr perl-5.10.0/ext/threads/t/list.t
+--- perl-5.10.0/ext/threads/t/list.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/list.t 2010-10-12 11:41:12.397237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -69,4 +65,6 @@ $thread->join();
+ ok(14, scalar @{[threads->list()]} == 0, 'Thread list empty');
+ ok(15, threads->list() == 0, 'Thread list empty');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/no_threads.t.tr perl-5.10.0/ext/threads/t/no_threads.t
+--- perl-5.10.0/ext/threads/t/no_threads.t.tr 2010-10-12 11:41:12.398237001 +0200
++++ perl-5.10.0/ext/threads/t/no_threads.t 2010-10-12 11:41:12.398237001 +0200
+@@ -0,0 +1,39 @@
++use strict;
++use warnings;
++
++BEGIN {
++ use Config;
++ if ($Config{'useithreads'}) {
++ print("1..0 # SKIP Perl compiled with 'useithreads'\n");
++ exit(0);
++ }
++}
++
++use ExtUtils::testlib;
++
++sub ok {
++ my ($id, $ok, $name) = @_;
++
++ # You have to do it this way or VMS will get confused.
++ if ($ok) {
++ print("ok $id - $name\n");
++ } else {
++ print("not ok $id - $name\n");
++ printf("# Failed test at line %d\n", (caller)[2]);
++ }
++
++ return ($ok);
++}
++
++BEGIN {
++ $| = 1;
++ print("1..1\n"); ### Number of tests that will be run ###
++};
++
++eval 'use threads; 1';
++
++ok(1, (($@ =~ /not built to support thread/)?1:0), "No threads support");
++
++exit(0);
++
++# EOF
+diff -up perl-5.10.0/ext/threads/t/pod.t.tr perl-5.10.0/ext/threads/t/pod.t
+--- perl-5.10.0/ext/threads/t/pod.t.tr 2010-10-12 11:41:12.399237001 +0200
++++ perl-5.10.0/ext/threads/t/pod.t 2010-10-12 11:41:12.399237001 +0200
+@@ -0,0 +1,83 @@
++use strict;
++use warnings;
++
++use Test::More;
++if ($ENV{RUN_MAINTAINER_TESTS}) {
++ plan 'tests' => 3;
++} else {
++ plan 'skip_all' => 'Module maintainer tests';
++}
++
++SKIP: {
++ if (! eval 'use Test::Pod 1.26; 1') {
++ skip('Test::Pod 1.26 required for testing POD', 1);
++ }
++
++ pod_file_ok('lib/threads.pm');
++}
++
++SKIP: {
++ if (! eval 'use Test::Pod::Coverage 1.08; 1') {
++ skip('Test::Pod::Coverage 1.08 required for testing POD coverage', 1);
++ }
++
++ pod_coverage_ok('threads',
++ {
++ 'trustme' => [
++ qr/^new$/,
++ qr/^exit$/,
++ qr/^async$/,
++ qr/^\(/,
++ qr/^(all|running|joinable)$/,
++ ],
++ 'private' => [
++ qr/^import$/,
++ qr/^DESTROY$/,
++ qr/^bootstrap$/,
++ ]
++ }
++ );
++}
++
++SKIP: {
++ if (! eval 'use Test::Spelling; 1') {
++ skip('Test::Spelling required for testing POD spelling', 1);
++ }
++ if (system('aspell help >/dev/null 2>&1')) {
++ skip(q/'aspell' required for testing POD spelling/, 1);
++ }
++ set_spell_cmd('aspell list --lang=en');
++ add_stopwords(<DATA>);
++ pod_file_spelling_ok('lib/threads.pm', 'thread.pm spelling');
++ unlink("/home/$ENV{'USER'}/en.prepl", "/home/$ENV{'USER'}/en.pws");
++}
++
++exit(0);
++
++__DATA__
++
++API
++async
++cpan
++MSWin32
++pthreads
++SIGTERM
++TID
++
++Hedden
++Soderberg
++crystalflame
++brecon
++netrus
++Rocco
++Caputo
++netrus
++vipul
++Ved
++Prakash
++presicient
++
++okay
++unjoinable
++
++__END__
+diff -up perl-5.10.0/ext/threads/t/problems.t.tr perl-5.10.0/ext/threads/t/problems.t
+--- perl-5.10.0/ext/threads/t/problems.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/problems.t 2010-10-12 11:41:12.400237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -95,7 +87,7 @@ if ($] != 5.008)
+ my $not = eval { Config::myconfig() } ? '' : 'not ';
+ print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
+ } else {
+- print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
++ print "ok $test # SKIP Are we able to call Config::myconfig after clone\n";
+ }
+ $test++;
+ }
+@@ -123,7 +115,7 @@ threads->create(sub {
+ print $@ =~ /disallowed/
+ ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
+ } else {
+- print("ok $test # Skip $TODO - unique_hash\n");
++ print("ok $test # SKIP $TODO - unique_hash\n");
+ }
+ $test++;
+ })->join;
+@@ -138,7 +130,7 @@ for my $decl ('my $x : unique', 'sub foo
+ print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
+ ? '' : 'not ', "ok $test - $decl\n";
+ } else {
+- print("ok $test # Skip $decl\n");
++ print("ok $test # SKIP $decl\n");
+ }
+ $test++;
+ }
+@@ -178,4 +170,6 @@ is(keys(%h), 1, "keys correct in parent
+ $child = threads->create(sub { return (scalar(keys(%h))); })->join;
+ is($child, 1, "keys correct in child with restricted hash");
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/stack_env.t.tr perl-5.10.0/ext/threads/t/stack_env.t
+--- perl-5.10.0/ext/threads/t/stack_env.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/stack_env.t 2010-10-12 11:41:12.401237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -48,4 +44,6 @@ ok(3, threads->set_stack_size(144*4096)
+ ok(4, threads->get_stack_size() == 144*4096,
+ 'Get stack size');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/stack.t.tr perl-5.10.0/ext/threads/t/stack.t
+--- perl-5.10.0/ext/threads/t/stack.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/stack.t 2010-10-12 11:41:12.403237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -102,4 +98,6 @@ $thr->join();
+ ok(18, threads->get_stack_size() == 160*4096,
+ 'Default thread sized changed in thread');
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/state.t.tr perl-5.10.0/ext/threads/t/state.t
+--- perl-5.10.0/ext/threads/t/state.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/state.t 2010-10-12 11:41:12.404237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -18,12 +14,8 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
++ if (! eval 'use threads::shared; 1') {
++ print("1..0 # SKIP threads::shared not available\n");
+ exit(0);
+ }
+
+@@ -263,4 +255,6 @@ ok(threads->list(threads::joinable) == 0
+ for (threads->list) { $_->join; }
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/stress_cv.t.tr perl-5.10.0/ext/threads/t/stress_cv.t
+--- perl-5.10.0/ext/threads/t/stress_cv.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/stress_cv.t 2010-10-12 11:41:12.405237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -58,4 +54,6 @@ for (1..$cnt) {
+ ok($thr, "Thread joined - iter $_");
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/stress_re.t.tr perl-5.10.0/ext/threads/t/stress_re.t
+--- perl-5.10.0/ext/threads/t/stress_re.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/stress_re.t 2010-10-12 11:41:12.406237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -64,4 +60,6 @@ for (1..$cnt) {
+ ok($thr && defined($result) && ($result eq 'ok'), "Thread joined - iter $_");
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/stress_string.t.tr perl-5.10.0/ext/threads/t/stress_string.t
+--- perl-5.10.0/ext/threads/t/stress_string.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/stress_string.t 2010-10-12 11:41:12.407237001 +0200
+@@ -2,13 +2,9 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -62,4 +58,6 @@ for (1..$cnt) {
+ ok($thr, "Thread joined - iter $_");
+ }
+
++exit(0);
++
+ # EOF
+diff -up perl-5.10.0/ext/threads/t/test.pl.tr perl-5.10.0/ext/threads/t/test.pl
+--- perl-5.10.0/ext/threads/t/test.pl.tr 2010-10-12 11:41:12.410237001 +0200
++++ perl-5.10.0/ext/threads/t/test.pl 2010-10-12 11:41:12.410237001 +0200
+@@ -0,0 +1,1128 @@
++#
++# t/test.pl - most of Test::More functionality without the fuss, plus
++# has mappings native_to_latin1 and latin1_to_native so that fewer tests
++# on non ASCII-ish platforms need to be skipped
++
++
++# NOTE:
++#
++# Increment ($x++) has a certain amount of cleverness for things like
++#
++# $x = 'zz';
++# $x++; # $x eq 'aaa';
++#
++# stands more chance of breaking than just a simple
++#
++# $x = $x + 1
++#
++# In this file, we use the latter "Baby Perl" approach, and increment
++# will be worked over by t/op/inc.t
++
++$Level = 1;
++my $test = 1;
++my $planned;
++my $noplan;
++my $Perl; # Safer version of $^X set by which_perl()
++
++$TODO = 0;
++$NO_ENDING = 0;
++
++# Use this instead of print to avoid interference while testing globals.
++sub _print {
++ local($\, $", $,) = (undef, ' ', '');
++ print STDOUT @_;
++}
++
++sub _print_stderr {
++ local($\, $", $,) = (undef, ' ', '');
++ print STDERR @_;
++}
++
++sub plan {
++ my $n;
++ if (@_ == 1) {
++ $n = shift;
++ if ($n eq 'no_plan') {
++ undef $n;
++ $noplan = 1;
++ }
++ } else {
++ my %plan = @_;
++ $n = $plan{tests};
++ }
++ _print "1..$n\n" unless $noplan;
++ $planned = $n;
++}
++
++
++# Set the plan at the end. See Test::More::done_testing.
++sub done_testing {
++ my $n = $test - 1;
++ $n = shift if @_;
++
++ _print "1..$n\n";
++ $planned = $n;
++}
++
++
++END {
++ my $ran = $test - 1;
++ if (!$NO_ENDING) {
++ if (defined $planned && $planned != $ran) {
++ _print_stderr
++ "# Looks like you planned $planned tests but ran $ran.\n";
++ } elsif ($noplan) {
++ _print "1..$ran\n";
++ }
++ }
++}
++
++sub _diag {
++ return unless @_;
++ my @mess = _comment(@_);
++ $TODO ? _print(@mess) : _print_stderr(@mess);
++}
++
++# Use this instead of "print STDERR" when outputing failure diagnostic
++# messages
++sub diag {
++ _diag(@_);
++}
++
++# Use this instead of "print" when outputing informational messages
++sub note {
++ return unless @_;
++ _print( _comment(@_) );
++}
++
++sub _comment {
++ return map { /^#/ ? "$_\n" : "# $_\n" }
++ map { split /\n/ } @_;
++}
++
++sub skip_all {
++ if (@_) {
++ _print "1..0 # Skip @_\n";
++ } else {
++ _print "1..0\n";
++ }
++ exit(0);
++}
++
++sub _ok {
++ my ($pass, $where, $name, @mess) = @_;
++ # Do not try to microoptimize by factoring out the "not ".
++ # VMS will avenge.
++ my $out;
++ if ($name) {
++ # escape out '#' or it will interfere with '# skip' and such
++ $name =~ s/#/\\#/g;
++ $out = $pass ? "ok $test - $name" : "not ok $test - $name";
++ } else {
++ $out = $pass ? "ok $test" : "not ok $test";
++ }
++
++ $out = $out . " # TODO $TODO" if $TODO;
++ _print "$out\n";
++
++ unless ($pass) {
++ _diag "# Failed $where\n";
++ }
++
++ # Ensure that the message is properly escaped.
++ _diag @mess;
++
++ $test = $test + 1; # don't use ++
++
++ return $pass;
++}
++
++sub _where {
++ my @caller = caller($Level);
++ return "at $caller[1] line $caller[2]";
++}
++
++# DON'T use this for matches. Use like() instead.
++sub ok ($@) {
++ my ($pass, $name, @mess) = @_;
++ _ok($pass, _where(), $name, @mess);
++}
++
++sub _q {
++ my $x = shift;
++ return 'undef' unless defined $x;
++ my $q = $x;
++ $q =~ s/\\/\\\\/g;
++ $q =~ s/'/\\'/g;
++ return "'$q'";
++}
++
++sub _qq {
++ my $x = shift;
++ return defined $x ? '"' . display ($x) . '"' : 'undef';
++};
++
++# keys are the codes \n etc map to, values are 2 char strings such as \n
++my %backslash_escape;
++foreach my $x (split //, 'nrtfa\\\'"') {
++ $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
++}
++# A way to display scalars containing control characters and Unicode.
++# Trying to avoid setting $_, or relying on local $_ to work.
++sub display {
++ my @result;
++ foreach my $x (@_) {
++ if (defined $x and not ref $x) {
++ my $y = '';
++ foreach my $c (unpack("U*", $x)) {
++ if ($c > 255) {
++ $y = $y . sprintf "\\x{%x}", $c;
++ } elsif ($backslash_escape{$c}) {
++ $y = $y . $backslash_escape{$c};
++ } else {
++ my $z = chr $c; # Maybe we can get away with a literal...
++ if ($z =~ /[[:^print:]]/) {
++
++ # Use octal for characters traditionally expressed as
++ # such: the low controls
++ if ($c <= 037) {
++ $z = sprintf "\\%03o", $c;
++ } else {
++ $z = sprintf "\\x{%x}", $c;
++ }
++ }
++ $y = $y . $z;
++ }
++ }
++ $x = $y;
++ }
++ return $x unless wantarray;
++ push @result, $x;
++ }
++ return @result;
++}
++
++sub is ($$@) {
++ my ($got, $expected, $name, @mess) = @_;
++
++ my $pass;
++ if( !defined $got || !defined $expected ) {
++ # undef only matches undef
++ $pass = !defined $got && !defined $expected;
++ }
++ else {
++ $pass = $got eq $expected;
++ }
++
++ unless ($pass) {
++ unshift(@mess, "# got "._qq($got)."\n",
++ "# expected "._qq($expected)."\n");
++ }
++ _ok($pass, _where(), $name, @mess);
++}
++
++sub isnt ($$@) {
++ my ($got, $isnt, $name, @mess) = @_;
++
++ my $pass;
++ if( !defined $got || !defined $isnt ) {
++ # undef only matches undef
++ $pass = defined $got || defined $isnt;
++ }
++ else {
++ $pass = $got ne $isnt;
++ }
++
++ unless( $pass ) {
++ unshift(@mess, "# it should not be "._qq($got)."\n",
++ "# but it is.\n");
++ }
++ _ok($pass, _where(), $name, @mess);
++}
++
++sub cmp_ok ($$$@) {
++ my($got, $type, $expected, $name, @mess) = @_;
++
++ my $pass;
++ {
++ local $^W = 0;
++ local($@,$!); # don't interfere with $@
++ # eval() sometimes resets $!
++ $pass = eval "\$got $type \$expected";
++ }
++ unless ($pass) {
++ # It seems Irix long doubles can have 2147483648 and 2147483648
++ # that stringify to the same thing but are acutally numerically
++ # different. Display the numbers if $type isn't a string operator,
++ # and the numbers are stringwise the same.
++ # (all string operators have alphabetic names, so tr/a-z// is true)
++ # This will also show numbers for some uneeded cases, but will
++ # definately be helpful for things such as == and <= that fail
++ if ($got eq $expected and $type !~ tr/a-z//) {
++ unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
++ }
++ unshift(@mess, "# got "._qq($got)."\n",
++ "# expected $type "._qq($expected)."\n");
++ }
++ _ok($pass, _where(), $name, @mess);
++}
++
++# Check that $got is within $range of $expected
++# if $range is 0, then check it's exact
++# else if $expected is 0, then $range is an absolute value
++# otherwise $range is a fractional error.
++# Here $range must be numeric, >= 0
++# Non numeric ranges might be a useful future extension. (eg %)
++sub within ($$$@) {
++ my ($got, $expected, $range, $name, @mess) = @_;
++ my $pass;
++ if (!defined $got or !defined $expected or !defined $range) {
++ # This is a fail, but doesn't need extra diagnostics
++ } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
++ # This is a fail
++ unshift @mess, "# got, expected and range must be numeric\n";
++ } elsif ($range < 0) {
++ # This is also a fail
++ unshift @mess, "# range must not be negative\n";
++ } elsif ($range == 0) {
++ # Within 0 is ==
++ $pass = $got == $expected;
++ } elsif ($expected == 0) {
++ # If expected is 0, treat range as absolute
++ $pass = ($got <= $range) && ($got >= - $range);
++ } else {
++ my $diff = $got - $expected;
++ $pass = abs ($diff / $expected) < $range;
++ }
++ unless ($pass) {
++ if ($got eq $expected) {
++ unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
++ }
++ unshift at mess, "# got "._qq($got)."\n",
++ "# expected "._qq($expected)." (within "._qq($range).")\n";
++ }
++ _ok($pass, _where(), $name, @mess);
++}
++
++# Note: this isn't quite as fancy as Test::More::like().
++
++sub like ($$@) { like_yn (0, at _) }; # 0 for -
++sub unlike ($$@) { like_yn (1, at _) }; # 1 for un-
++
++sub like_yn ($$$@) {
++ my ($flip, $got, $expected, $name, @mess) = @_;
++ my $pass;
++ $pass = $got =~ /$expected/ if !$flip;
++ $pass = $got !~ /$expected/ if $flip;
++ unless ($pass) {
++ unshift(@mess, "# got '$got'\n",
++ $flip
++ ? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
++ }
++ local $Level = $Level + 1;
++ _ok($pass, _where(), $name, @mess);
++}
++
++sub pass {
++ _ok(1, '', @_);
++}
++
++sub fail {
++ _ok(0, _where(), @_);
++}
++
++sub curr_test {
++ $test = shift if @_;
++ return $test;
++}
++
++sub next_test {
++ my $retval = $test;
++ $test = $test + 1; # don't use ++
++ $retval;
++}
++
++# Note: can't pass multipart messages since we try to
++# be compatible with Test::More::skip().
++sub skip {
++ my $why = shift;
++ my $n = @_ ? shift : 1;
++ for (1..$n) {
++ _print "ok $test # skip $why\n";
++ $test = $test + 1;
++ }
++ local $^W = 0;
++ last SKIP;
++}
++
++sub todo_skip {
++ my $why = shift;
++ my $n = @_ ? shift : 1;
++
++ for (1..$n) {
++ _print "not ok $test # TODO & SKIP $why\n";
++ $test = $test + 1;
++ }
++ local $^W = 0;
++ last TODO;
++}
++
++sub eq_array {
++ my ($ra, $rb) = @_;
++ return 0 unless $#$ra == $#$rb;
++ for my $i (0..$#$ra) {
++ next if !defined $ra->[$i] && !defined $rb->[$i];
++ return 0 if !defined $ra->[$i];
++ return 0 if !defined $rb->[$i];
++ return 0 unless $ra->[$i] eq $rb->[$i];
++ }
++ return 1;
++}
++
++sub eq_hash {
++ my ($orig, $suspect) = @_;
++ my $fail;
++ while (my ($key, $value) = each %$suspect) {
++ # Force a hash recompute if this perl's internals can cache the hash key.
++ $key = "" . $key;
++ if (exists $orig->{$key}) {
++ if ($orig->{$key} ne $value) {
++ _print "# key ", _qq($key), " was ", _qq($orig->{$key}),
++ " now ", _qq($value), "\n";
++ $fail = 1;
++ }
++ } else {
++ _print "# key ", _qq($key), " is ", _qq($value),
++ ", not in original.\n";
++ $fail = 1;
++ }
++ }
++ foreach (keys %$orig) {
++ # Force a hash recompute if this perl's internals can cache the hash key.
++ $_ = "" . $_;
++ next if (exists $suspect->{$_});
++ _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
++ $fail = 1;
++ }
++ !$fail;
++}
++
++sub require_ok ($) {
++ my ($require) = @_;
++ eval <<REQUIRE_OK;
++require $require;
++REQUIRE_OK
++ _ok(!$@, _where(), "require $require");
++}
++
++sub use_ok ($) {
++ my ($use) = @_;
++ eval <<USE_OK;
++use $use;
++USE_OK
++ _ok(!$@, _where(), "use $use");
++}
++
++# runperl - Runs a separate perl interpreter.
++# Arguments :
++# switches => [ command-line switches ]
++# nolib => 1 # don't use -I../lib (included by default)
++# non_portable => Don't warn if a one liner contains quotes
++# prog => one-liner (avoid quotes)
++# progs => [ multi-liner (avoid quotes) ]
++# progfile => perl script
++# stdin => string to feed the stdin
++# stderr => redirect stderr to stdout
++# args => [ command-line arguments to the perl program ]
++# verbose => print the command line
++
++my $is_mswin = $^O eq 'MSWin32';
++my $is_netware = $^O eq 'NetWare';
++my $is_vms = $^O eq 'VMS';
++my $is_cygwin = $^O eq 'cygwin';
++
++sub _quote_args {
++ my ($runperl, $args) = @_;
++
++ foreach (@$args) {
++ # In VMS protect with doublequotes because otherwise
++ # DCL will lowercase -- unless already doublequoted.
++ $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
++ $runperl = $runperl . ' ' . $_;
++ }
++ return $runperl;
++}
++
++sub _create_runperl { # Create the string to qx in runperl().
++ my %args = @_;
++ my $runperl = which_perl();
++ if ($runperl =~ m/\s/) {
++ $runperl = qq{"$runperl"};
++ }
++ #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind
++ if ($ENV{PERL_RUNPERL_DEBUG}) {
++ $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
++ }
++ unless ($args{nolib}) {
++ $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS
++ }
++ if ($args{switches}) {
++ local $Level = 2;
++ die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
++ unless ref $args{switches} eq "ARRAY";
++ $runperl = _quote_args($runperl, $args{switches});
++ }
++ if (defined $args{prog}) {
++ die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
++ if defined $args{progs};
++ $args{progs} = [$args{prog}]
++ }
++ if (defined $args{progs}) {
++ die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
++ unless ref $args{progs} eq "ARRAY";
++ foreach my $prog (@{$args{progs}}) {
++ if ($prog =~ tr/'"// && !$args{non_portable}) {
++ warn "quotes in prog >>$prog<< are not portable";
++ }
++ if ($is_mswin || $is_netware || $is_vms) {
++ $runperl = $runperl . qq ( -e "$prog" );
++ }
++ else {
++ $runperl = $runperl . qq ( -e '$prog' );
++ }
++ }
++ } elsif (defined $args{progfile}) {
++ $runperl = $runperl . qq( "$args{progfile}");
++ } else {
++ # You probaby didn't want to be sucking in from the upstream stdin
++ die "test.pl:runperl(): none of prog, progs, progfile, args, "
++ . " switches or stdin specified"
++ unless defined $args{args} or defined $args{switches}
++ or defined $args{stdin};
++ }
++ if (defined $args{stdin}) {
++ # so we don't try to put literal newlines and crs onto the
++ # command line.
++ $args{stdin} =~ s/\n/\\n/g;
++ $args{stdin} =~ s/\r/\\r/g;
++
++ if ($is_mswin || $is_netware || $is_vms) {
++ $runperl = qq{$Perl -e "print qq(} .
++ $args{stdin} . q{)" | } . $runperl;
++ }
++ else {
++ $runperl = qq{$Perl -e 'print qq(} .
++ $args{stdin} . q{)' | } . $runperl;
++ }
++ }
++ if (defined $args{args}) {
++ $runperl = _quote_args($runperl, $args{args});
++ }
++ $runperl = $runperl . ' 2>&1' if $args{stderr};
++ if ($args{verbose}) {
++ my $runperldisplay = $runperl;
++ $runperldisplay =~ s/\n/\n\#/g;
++ _print_stderr "# $runperldisplay\n";
++ }
++ return $runperl;
++}
++
++sub runperl {
++ die "test.pl:runperl() does not take a hashref"
++ if ref $_[0] and ref $_[0] eq 'HASH';
++ my $runperl = &_create_runperl;
++ my $result;
++
++ my $tainted = ${^TAINT};
++ my %args = @_;
++ exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1;
++
++ if ($tainted) {
++ # We will assume that if you're running under -T, you really mean to
++ # run a fresh perl, so we'll brute force launder everything for you
++ my $sep;
++
++ if (! eval 'require Config; 1') {
++ warn "test.pl had problems loading Config: $@";
++ $sep = ':';
++ } else {
++ $sep = $Config::Config{path_sep};
++ }
++
++ my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV);
++ local @ENV{@keys} = ();
++ # Untaint, plus take out . and empty string:
++ local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s);
++ $ENV{PATH} =~ /(.*)/s;
++ local $ENV{PATH} =
++ join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
++ ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
++ split quotemeta ($sep), $1;
++ $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin
++
++ $runperl =~ /(.*)/s;
++ $runperl = $1;
++
++ $result = `$runperl`;
++ } else {
++ $result = `$runperl`;
++ }
++ $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
++ return $result;
++}
++
++# Nice alias
++*run_perl = *run_perl = \&runperl; # shut up "used only once" warning
++
++sub DIE {
++ _print_stderr "# @_\n";
++ exit 1;
++}
++
++# A somewhat safer version of the sometimes wrong $^X.
++sub which_perl {
++ unless (defined $Perl) {
++ $Perl = $^X;
++
++ # VMS should have 'perl' aliased properly
++ return $Perl if $^O eq 'VMS';
++
++ my $exe;
++ if (! eval 'require Config; 1') {
++ warn "test.pl had problems loading Config: $@";
++ $exe = '';
++ } else {
++ $exe = $Config::Config{_exe};
++ }
++ $exe = '' unless defined $exe;
++
++ # This doesn't absolutize the path: beware of future chdirs().
++ # We could do File::Spec->abs2rel() but that does getcwd()s,
++ # which is a bit heavyweight to do here.
++
++ if ($Perl =~ /^perl\Q$exe\E$/i) {
++ my $perl = "perl$exe";
++ if (! eval 'require File::Spec; 1') {
++ warn "test.pl had problems loading File::Spec: $@";
++ $Perl = "./$perl";
++ } else {
++ $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
++ }
++ }
++
++ # Build up the name of the executable file from the name of
++ # the command.
++
++ if ($Perl !~ /\Q$exe\E$/i) {
++ $Perl = $Perl . $exe;
++ }
++
++ warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
++
++ # For subcommands to use.
++ $ENV{PERLEXE} = $Perl;
++ }
++ return $Perl;
++}
++
++sub unlink_all {
++ foreach my $file (@_) {
++ 1 while unlink $file;
++ _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file;
++ }
++}
++
++my %tmpfiles;
++END { unlink_all keys %tmpfiles }
++
++# A regexp that matches the tempfile names
++$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?';
++
++# Avoid ++, avoid ranges, avoid split //
++my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
++sub tempfile {
++ my $count = 0;
++ do {
++ my $temp = $count;
++ my $try = "tmp$$";
++ do {
++ $try = $try . $letters[$temp % 26];
++ $temp = int ($temp / 26);
++ } while $temp;
++ # Need to note all the file names we allocated, as a second request may
++ # come before the first is created.
++ if (!-e $try && !$tmpfiles{$try}) {
++ # We have a winner
++ $tmpfiles{$try} = 1;
++ return $try;
++ }
++ $count = $count + 1;
++ } while $count < 26 * 26;
++ die "Can't find temporary file name starting 'tmp$$'";
++}
++
++# This is the temporary file for _fresh_perl
++my $tmpfile = tempfile();
++
++#
++# _fresh_perl
++#
++# The $resolve must be a subref that tests the first argument
++# for success, or returns the definition of success (e.g. the
++# expected scalar) if given no arguments.
++#
++
++sub _fresh_perl {
++ my($prog, $resolve, $runperl_args, $name) = @_;
++
++ # Given the choice of the mis-parsable {}
++ # (we want an anon hash, but a borked lexer might think that it's a block)
++ # or relying on taking a reference to a lexical
++ # (\ might be mis-parsed, and the reference counting on the pad may go
++ # awry)
++ # it feels like the least-worse thing is to assume that auto-vivification
++ # works. At least, this is only going to be a run-time failure, so won't
++ # affect tests using this file but not this function.
++ $runperl_args->{progfile} = $tmpfile;
++ $runperl_args->{stderr} = 1;
++
++ open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
++
++ # VMS adjustments
++ if( $^O eq 'VMS' ) {
++ $prog =~ s#/dev/null#NL:#;
++
++ # VMS file locking
++ $prog =~ s{if \(-e _ and -f _ and -r _\)}
++ {if (-e _ and -f _)}
++ }
++
++ print TEST $prog;
++ close TEST or die "Cannot close $tmpfile: $!";
++
++ my $results = runperl(%$runperl_args);
++ my $status = $?;
++
++ # Clean up the results into something a bit more predictable.
++ $results =~ s/\n+$//;
++ $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g;
++ $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g;
++
++ # bison says 'parse error' instead of 'syntax error',
++ # various yaccs may or may not capitalize 'syntax'.
++ $results =~ s/^(syntax|parse) error/syntax error/mig;
++
++ if ($^O eq 'VMS') {
++ # some tests will trigger VMS messages that won't be expected
++ $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
++
++ # pipes double these sometimes
++ $results =~ s/\n\n/\n/g;
++ }
++
++ my $pass = $resolve->($results);
++ unless ($pass) {
++ _diag "# PROG: \n$prog\n";
++ _diag "# EXPECTED:\n", $resolve->(), "\n";
++ _diag "# GOT:\n$results\n";
++ _diag "# STATUS: $status\n";
++ }
++
++ # Use the first line of the program as a name if none was given
++ unless( $name ) {
++ ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
++ $name = $name . '...' if length $first_line > length $name;
++ }
++
++ _ok($pass, _where(), "fresh_perl - $name");
++}
++
++#
++# fresh_perl_is
++#
++# Combination of run_perl() and is().
++#
++
++sub fresh_perl_is {
++ my($prog, $expected, $runperl_args, $name) = @_;
++
++ # _fresh_perl() is going to clip the trailing newlines off the result.
++ # This will make it so the test author doesn't have to know that.
++ $expected =~ s/\n+$//;
++
++ local $Level = 2;
++ _fresh_perl($prog,
++ sub { @_ ? $_[0] eq $expected : $expected },
++ $runperl_args, $name);
++}
++
++#
++# fresh_perl_like
++#
++# Combination of run_perl() and like().
++#
++
++sub fresh_perl_like {
++ my($prog, $expected, $runperl_args, $name) = @_;
++ local $Level = 2;
++ _fresh_perl($prog,
++ sub { @_ ? $_[0] =~ $expected : $expected },
++ $runperl_args, $name);
++}
++
++sub can_ok ($@) {
++ my($proto, @methods) = @_;
++ my $class = ref $proto || $proto;
++
++ unless( @methods ) {
++ return _ok( 0, _where(), "$class->can(...)" );
++ }
++
++ my @nok = ();
++ foreach my $method (@methods) {
++ local($!, $@); # don't interfere with caller's $@
++ # eval sometimes resets $!
++ eval { $proto->can($method) } || push @nok, $method;
++ }
++
++ my $name;
++ $name = @methods == 1 ? "$class->can('$methods[0]')"
++ : "$class->can(...)";
++
++ _ok( !@nok, _where(), $name );
++}
++
++
++# Call $class->new( @$args ); and run the result through isa_ok.
++# See Test::More::new_ok
++sub new_ok {
++ my($class, $args, $obj_name) = @_;
++ $args ||= [];
++ $object_name = "The object" unless defined $obj_name;
++
++ local $Level = $Level + 1;
++
++ my $obj;
++ my $ok = eval { $obj = $class->new(@$args); 1 };
++ my $error = $@;
++
++ if($ok) {
++ isa_ok($obj, $class, $object_name);
++ }
++ else {
++ ok( 0, "new() died" );
++ diag("Error was: $@");
++ }
++
++ return $obj;
++
++}
++
++
++sub isa_ok ($$;$) {
++ my($object, $class, $obj_name) = @_;
++
++ my $diag;
++ $obj_name = 'The object' unless defined $obj_name;
++ my $name = "$obj_name isa $class";
++ if( !defined $object ) {
++ $diag = "$obj_name isn't defined";
++ }
++ elsif( !ref $object ) {
++ $diag = "$obj_name isn't a reference";
++ }
++ else {
++ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
++ local($@, $!); # eval sometimes resets $!
++ my $rslt = eval { $object->isa($class) };
++ if( $@ ) {
++ if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
++ if( !UNIVERSAL::isa($object, $class) ) {
++ my $ref = ref $object;
++ $diag = "$obj_name isn't a '$class' it's a '$ref'";
++ }
++ } else {
++ die <<WHOA;
++WHOA! I tried to call ->isa on your object and got some weird error.
++This should never happen. Please contact the author immediately.
++Here's the error.
++$@
++WHOA
++ }
++ }
++ elsif( !$rslt ) {
++ my $ref = ref $object;
++ $diag = "$obj_name isn't a '$class' it's a '$ref'";
++ }
++ }
++
++ _ok( !$diag, _where(), $name );
++}
++
++# Set a watchdog to timeout the entire test file
++# NOTE: If the test file uses 'threads', then call the watchdog() function
++# _AFTER_ the 'threads' module is loaded.
++sub watchdog ($;$)
++{
++ my $timeout = shift;
++ my $method = shift || "";
++ my $timeout_msg = 'Test process timed out - terminating';
++
++ # Valgrind slows perl way down so give it more time before dying.
++ $timeout *= 10 if $ENV{PERL_VALGRIND};
++
++ my $pid_to_kill = $$; # PID for this process
++
++ if ($method eq "alarm") {
++ goto WATCHDOG_VIA_ALARM;
++ }
++
++ # shut up use only once warning
++ my $threads_on = $threads::threads && $threads::threads;
++
++ # Don't use a watchdog process if 'threads' is loaded -
++ # use a watchdog thread instead
++ if (!$threads_on) {
++
++ # On Windows and VMS, try launching a watchdog process
++ # using system(1, ...) (see perlport.pod)
++ if (($^O eq 'MSWin32') || ($^O eq 'VMS')) {
++ # On Windows, try to get the 'real' PID
++ if ($^O eq 'MSWin32') {
++ eval { require Win32; };
++ if (defined(&Win32::GetCurrentProcessId)) {
++ $pid_to_kill = Win32::GetCurrentProcessId();
++ }
++ }
++
++ # If we still have a fake PID, we can't use this method at all
++ return if ($pid_to_kill <= 0);
++
++ # Launch watchdog process
++ my $watchdog;
++ eval {
++ local $SIG{'__WARN__'} = sub {
++ _diag("Watchdog warning: $_[0]");
++ };
++ my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
++ my $cmd = _create_runperl( prog => "sleep($timeout);" .
++ "warn qq/# $timeout_msg" . '\n/;' .
++ "kill($sig, $pid_to_kill);");
++ $watchdog = system(1, $cmd);
++ };
++ if ($@ || ($watchdog <= 0)) {
++ _diag('Failed to start watchdog');
++ _diag($@) if $@;
++ undef($watchdog);
++ return;
++ }
++
++ # Add END block to parent to terminate and
++ # clean up watchdog process
++ eval "END { local \$! = 0; local \$? = 0;
++ wait() if kill('KILL', $watchdog); };";
++ return;
++ }
++
++ # Try using fork() to generate a watchdog process
++ my $watchdog;
++ eval { $watchdog = fork() };
++ if (defined($watchdog)) {
++ if ($watchdog) { # Parent process
++ # Add END block to parent to terminate and
++ # clean up watchdog process
++ eval "END { local \$! = 0; local \$? = 0;
++ wait() if kill('KILL', $watchdog); };";
++ return;
++ }
++
++ ### Watchdog process code
++
++ # Load POSIX if available
++ eval { require POSIX; };
++
++ # Execute the timeout
++ sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073
++ sleep(2);
++
++ # Kill test process if still running
++ if (kill(0, $pid_to_kill)) {
++ _diag($timeout_msg);
++ kill('KILL', $pid_to_kill);
++ }
++
++ # Don't execute END block (added at beginning of this file)
++ $NO_ENDING = 1;
++
++ # Terminate ourself (i.e., the watchdog)
++ POSIX::_exit(1) if (defined(&POSIX::_exit));
++ exit(1);
++ }
++
++ # fork() failed - fall through and try using a thread
++ }
++
++ # Use a watchdog thread because either 'threads' is loaded,
++ # or fork() failed
++ if (eval 'require threads; 1') {
++ threads->create(sub {
++ # Load POSIX if available
++ eval { require POSIX; };
++
++ # Execute the timeout
++ my $time_left = $timeout;
++ do {
++ $time_left = $time_left - sleep($time_left);
++ } while ($time_left > 0);
++
++ # Kill the parent (and ourself)
++ select(STDERR); $| = 1;
++ _diag($timeout_msg);
++ POSIX::_exit(1) if (defined(&POSIX::_exit));
++ my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
++ kill($sig, $pid_to_kill);
++ })->detach();
++ return;
++ }
++
++ # If everything above fails, then just use an alarm timeout
++WATCHDOG_VIA_ALARM:
++ if (eval { alarm($timeout); 1; }) {
++ # Load POSIX if available
++ eval { require POSIX; };
++
++ # Alarm handler will do the actual 'killing'
++ $SIG{'ALRM'} = sub {
++ select(STDERR); $| = 1;
++ _diag($timeout_msg);
++ POSIX::_exit(1) if (defined(&POSIX::_exit));
++ my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
++ kill($sig, $pid_to_kill);
++ };
++ }
++}
++
++my $cp_0037 = # EBCDIC code page 0037
++ '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x25\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' .
++ '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' .
++ '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' .
++ '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBA\xE0\xBB\xB0\x6D' .
++ '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' .
++ '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' .
++ '\x20\x21\x22\x23\x24\x15\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' .
++ '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' .
++ '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBD\xB4\x9A\x8A\x5F\xCA\xAF\xBC' .
++ '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' .
++ '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' .
++ '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xAD\xAE\x59' .
++ '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' .
++ '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF';
++
++my $cp_1047 = # EBCDIC code page 1047
++ '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' .
++ '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' .
++ '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' .
++ '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xAD\xE0\xBD\x5F\x6D' .
++ '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' .
++ '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' .
++ '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' .
++ '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' .
++ '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBB\xB4\x9A\x8A\xB0\xCA\xAF\xBC' .
++ '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' .
++ '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' .
++ '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xBA\xAE\x59' .
++ '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' .
++ '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF';
++
++my $cp_bc = # EBCDIC code page POSiX-BC
++ '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' .
++ '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' .
++ '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' .
++ '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBB\xBC\xBD\x6A\x6D' .
++ '\x4A\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' .
++ '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xFB\x4F\xFD\xFF\x07' .
++ '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' .
++ '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\x5F' .
++ '\x41\xAA\xB0\xB1\x9F\xB2\xD0\xB5\x79\xB4\x9A\x8A\xBA\xCA\xAF\xA1' .
++ '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' .
++ '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' .
++ '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xE0\xFE\xDD\xFC\xAD\xAE\x59' .
++ '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' .
++ '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xC0\xDE\xDB\xDC\x8D\x8E\xDF';
++
++my $straight = # Avoid ranges
++ '\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F' .
++ '\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F' .
++ '\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F' .
++ '\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F' .
++ '\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F' .
++ '\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F' .
++ '\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F' .
++ '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F' .
++ '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F' .
++ '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF' .
++ '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF' .
++ '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF' .
++ '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF' .
++ '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF';
++
++# The following 2 functions allow tests to work on both EBCDIC and
++# ASCII-ish platforms. They convert string scalars between the native
++# character set and the set of 256 characters which is usually called
++# Latin1.
++#
++# These routines don't work on UTF-EBCDIC and UTF-8.
++
++sub native_to_latin1($) {
++ my $string = shift;
++
++ return $string if ord('^') == 94; # ASCII, Latin1
++ my $cp;
++ if (ord('^') == 95) { # EBCDIC 1047
++ $cp = \$cp_1047;
++ }
++ elsif (ord('^') == 106) { # EBCDIC POSIX-BC
++ $cp = \$cp_bc;
++ }
++ elsif (ord('^') == 176) { # EBCDIC 037 */
++ $cp = \$cp_0037;
++ }
++ else {
++ die "Unknown native character set";
++ }
++
++ eval '$string =~ tr/' . $$cp . '/' . $straight . '/';
++ return $string;
++}
++
++sub latin1_to_native($) {
++ my $string = shift;
++
++ return $string if ord('^') == 94; # ASCII, Latin1
++ my $cp;
++ if (ord('^') == 95) { # EBCDIC 1047
++ $cp = \$cp_1047;
++ }
++ elsif (ord('^') == 106) { # EBCDIC POSIX-BC
++ $cp = \$cp_bc;
++ }
++ elsif (ord('^') == 176) { # EBCDIC 037 */
++ $cp = \$cp_0037;
++ }
++ else {
++ die "Unknown native character set";
++ }
++
++ eval '$string =~ tr/' . $straight . '/' . $$cp . '/';
++ return $string;
++}
++
++1;
+diff -up perl-5.10.0/ext/threads/t/thread.t.tr perl-5.10.0/ext/threads/t/thread.t
+--- perl-5.10.0/ext/threads/t/thread.t.tr 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/t/thread.t 2010-10-12 11:41:12.411237001 +0200
+@@ -2,17 +2,12 @@ use strict;
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
++ require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
++
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+- exit(0);
++ skip_all(q/Perl not compiled with 'useithreads'/);
+ }
+-
+- require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
+ }
+
+ use ExtUtils::testlib;
+@@ -20,17 +15,12 @@ use ExtUtils::testlib;
+ use threads;
+
+ BEGIN {
+- eval {
+- require threads::shared;
+- threads::shared->import();
+- };
+- if ($@ || ! $threads::shared::threads_shared) {
+- print("1..0 # Skip: threads::shared not available\n");
+- exit(0);
++ if (! eval 'use threads::shared; 1') {
++ skip_all('threads::shared not available');
+ }
+
+ $| = 1;
+- print("1..34\n"); ### Number of tests that will be run ###
++ print("1..35\n"); ### Number of tests that will be run ###
+ };
+
+ print("ok 1 - Loaded\n");
+@@ -171,7 +161,7 @@ package main;
+
+ # bugid #24165
+
+-run_perl(prog => 'use threads 1.67;' .
++run_perl(prog => 'use threads 1.79;' .
+ 'sub a{threads->create(shift)} $t = a sub{};' .
+ '$t->tid; $t->join; $t->tid',
+ nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+@@ -314,4 +304,26 @@ SKIP: {
+ "counts of calls to DESTROY");
+ }
+
++# Bug 73330 - Apply magic to arg to ->object()
++{
++ my @tids :shared;
++
++ my $thr = threads->create(sub {
++ lock(@tids);
++ push(@tids, threads->tid());
++ cond_signal(@tids);
++ });
++
++ {
++ lock(@tids);
++ cond_wait(@tids) while (! @tids);
++ }
++
++ ok(threads->object($_), 'Got threads object') foreach (@tids);
++
++ $thr->join();
++}
++
++exit(0);
++
+ # EOF
diff --git a/perl-update-threadsshared.patch b/perl-update-threadsshared.patch
index 7c6c22b..36ba549 100644
--- a/perl-update-threadsshared.patch
+++ b/perl-update-threadsshared.patch
@@ -1,782 +1,8723 @@
-diff -up perl-5.10.0/ext/threads/shared/shared.pm.shared perl-5.10.0/ext/threads/shared/shared.pm
---- perl-5.10.0/ext/threads/shared/shared.pm.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/shared.pm 2010-09-07 08:35:16.185631381 +0200
-@@ -5,7 +5,9 @@ use 5.008;
- use strict;
- use warnings;
-
--our $VERSION = '1.14';
-+use Scalar::Util qw(reftype refaddr blessed);
+diff -up perl-5.10.0/ext/threads/shared/ppport.h.newshare perl-5.10.0/ext/threads/shared/ppport.h
+--- perl-5.10.0/ext/threads/shared/ppport.h.newshare 2010-10-12 10:48:36.741237001 +0200
++++ perl-5.10.0/ext/threads/shared/ppport.h 2010-10-12 10:48:36.740237001 +0200
+@@ -0,0 +1,7063 @@
++#if 0
++<<'SKIP';
++#endif
++/*
++----------------------------------------------------------------------
+
-+our $VERSION = '1.29';
- my $XS_VERSION = $VERSION;
- $VERSION = eval $VERSION;
-
-@@ -41,7 +43,7 @@ sub import
- {
- # Exported subroutines
- my @EXPORT = qw(share is_shared cond_wait cond_timedwait
-- cond_signal cond_broadcast);
-+ cond_signal cond_broadcast shared_clone);
- if ($threads::threads) {
- push(@EXPORT, 'bless');
- }
-@@ -55,6 +57,10 @@ sub import
- }
-
-
-+# Predeclarations for internal functions
-+my ($make_shared);
++ ppport.h -- Perl/Pollution/Portability Version 3.19
+
++ Automatically created by Devel::PPPort running under perl 5.010000.
+
- ### Methods, etc. ###
-
- sub threads::shared::tie::SPLICE
-@@ -63,6 +69,114 @@ sub threads::shared::tie::SPLICE
- Carp::croak('Splice not implemented for shared arrays');
- }
-
++ Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
++ includes in parts/inc/ instead.
+
-+# Create a thread-shared clone of a complex data structure or object
-+sub shared_clone
-+{
-+ if (@_ != 1) {
-+ require Carp;
-+ Carp::croak('Usage: shared_clone(REF)');
-+ }
++ Use 'perldoc ppport.h' to view the documentation below.
+
-+ return $make_shared->(shift, {});
-+}
++----------------------------------------------------------------------
+
++SKIP
+
-+### Internal Functions ###
++=pod
+
-+# Used by shared_clone() to recursively clone
-+# a complex data structure or object
-+$make_shared = sub {
-+ my ($item, $cloned) = @_;
++=head1 NAME
+
-+ # Just return the item if:
-+ # 1. Not a ref;
-+ # 2. Already shared; or
-+ # 3. Not running 'threads'.
-+ return $item if (! ref($item) || is_shared($item) || ! $threads::threads);
++ppport.h - Perl/Pollution/Portability version 3.19
+
-+ # Check for previously cloned references
-+ # (this takes care of circular refs as well)
-+ my $addr = refaddr($item);
-+ if (exists($cloned->{$addr})) {
-+ # Return the already existing clone
-+ return $cloned->{$addr};
-+ }
++=head1 SYNOPSIS
+
-+ # Make copies of array, hash and scalar refs and refs of refs
-+ my $copy;
-+ my $ref_type = reftype($item);
++ perl ppport.h [options] [source files]
+
-+ # Copy an array ref
-+ if ($ref_type eq 'ARRAY') {
-+ # Make empty shared array ref
-+ $copy = &share([]);
-+ # Add to clone checking hash
-+ $cloned->{$addr} = $copy;
-+ # Recursively copy and add contents
-+ push(@$copy, map { $make_shared->($_, $cloned) } @$item);
-+ }
++ Searches current directory for files if no [source files] are given
+
-+ # Copy a hash ref
-+ elsif ($ref_type eq 'HASH') {
-+ # Make empty shared hash ref
-+ $copy = &share({});
-+ # Add to clone checking hash
-+ $cloned->{$addr} = $copy;
-+ # Recursively copy and add contents
-+ foreach my $key (keys(%{$item})) {
-+ $copy->{$key} = $make_shared->($item->{$key}, $cloned);
-+ }
-+ }
++ --help show short help
+
-+ # Copy a scalar ref
-+ elsif ($ref_type eq 'SCALAR') {
-+ $copy = \do{ my $scalar = $$item; };
-+ share($copy);
-+ # Add to clone checking hash
-+ $cloned->{$addr} = $copy;
-+ }
++ --version show version
+
-+ # Copy of a ref of a ref
-+ elsif ($ref_type eq 'REF') {
-+ # Special handling for $x = \$x
-+ if ($addr == refaddr($$item)) {
-+ $copy = \$copy;
-+ share($copy);
-+ $cloned->{$addr} = $copy;
-+ } else {
-+ my $tmp;
-+ $copy = \$tmp;
-+ share($copy);
-+ # Add to clone checking hash
-+ $cloned->{$addr} = $copy;
-+ # Recursively copy and add contents
-+ $tmp = $make_shared->($$item, $cloned);
-+ }
++ --patch=file write one patch file with changes
++ --copy=suffix write changed copies with suffix
++ --diff=program use diff program and options
+
-+ } else {
-+ require Carp;
-+ Carp::croak("Unsupported ref type: ", $ref_type);
-+ }
++ --compat-version=version provide compatibility with Perl version
++ --cplusplus accept C++ comments
+
-+ # If input item is an object, then bless the copy into the same class
-+ if (my $class = blessed($item)) {
-+ bless($copy, $class);
-+ }
++ --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
+
-+ # Clone READONLY flag
-+ if ($ref_type eq 'SCALAR') {
-+ if (Internals::SvREADONLY($$item)) {
-+ Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003);
-+ }
-+ }
-+ if (Internals::SvREADONLY($item)) {
-+ Internals::SvREADONLY($copy, 1) if ($] >= 5.008003);
-+ }
++ --strip strip all script and doc functionality from
++ ppport.h
+
-+ return $copy;
-+};
++ --list-provided list provided API
++ --list-unsupported list unsupported API
++ --api-info=name show Perl API portability information
+
- 1;
-
- __END__
-@@ -73,7 +187,7 @@ threads::shared - Perl extension for sha
-
- =head1 VERSION
-
--This document describes threads::shared version 1.14
-+This document describes threads::shared version 1.29
-
- =head1 SYNOPSIS
-
-@@ -81,16 +195,28 @@ This document describes threads::shared
- use threads::shared;
-
- my $var :shared;
-- $var = $scalar_value;
-- $var = $shared_ref_value;
-- $var = share($simple_unshared_ref_value);
-+ my %hsh :shared;
-+ my @ary :shared;
-
- my ($scalar, @array, %hash);
- share($scalar);
- share(@array);
- share(%hash);
-- my $bar = &share([]);
-- $hash{bar} = &share({});
++=head1 COMPATIBILITY
+
-+ $var = $scalar_value;
-+ $var = $shared_ref_value;
-+ $var = shared_clone($non_shared_ref_value);
-+ $var = shared_clone({'foo' => [qw/foo bar baz/]});
++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.10.0.
+
-+ $hsh{'foo'} = $scalar_value;
-+ $hsh{'bar'} = $shared_ref_value;
-+ $hsh{'baz'} = shared_clone($non_shared_ref_value);
-+ $hsh{'quz'} = shared_clone([1..3]);
++=head1 OPTIONS
+
-+ $ary[0] = $scalar_value;
-+ $ary[1] = $shared_ref_value;
-+ $ary[2] = shared_clone($non_shared_ref_value);
-+ $ary[3] = shared_clone([ {}, [] ]);
-
- { lock(%hash); ... }
-
-@@ -108,13 +234,17 @@ This document describes threads::shared
-
- By default, variables are private to each thread, and each newly created
- thread gets a private copy of each existing variable. This module allows you
--to share variables across different threads (and pseudo-forks on Win32). It is
--used together with the L<threads> module.
-+to share variables across different threads (and pseudo-forks on Win32). It
-+is used together with the L<threads> module.
++=head2 --help
+
-+This module supports the sharing of the following data types only: scalars
-+and scalar refs, arrays and array refs, and hashes and hash refs.
-
- =head1 EXPORT
-
--C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>,
--C<is_shared>
-+The following functions are exported by this module: C<share>,
-+C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>
-+and C<cond_broadcast>
-
- Note that if this module is imported when L<threads> has not yet been loaded,
- then these functions all become no-ops. This makes it possible to write
-@@ -126,33 +256,60 @@ modules that will work in both threaded
-
- =item share VARIABLE
-
--C<share> takes a value and marks it as shared. You can share a scalar, array,
--hash, scalar ref, array ref, or hash ref. C<share> will return the shared
--rvalue, but always as a reference.
-+C<share> takes a variable and marks it as shared:
++Display a brief usage summary.
+
-+ my ($scalar, @array, %hash);
-+ share($scalar);
-+ share(@array);
-+ share(%hash);
-
--A variable can also be marked as shared at compile time by using the
--C<:shared> attribute: C<my $var :shared;>.
-+C<share> will return the shared rvalue, but always as a reference.
-
--Due to problems with Perl's prototyping, if you want to share a newly created
--reference, you need to use the C<&share([])> and C<&share({})> syntax.
-+Variables can also be marked as shared at compile time by using the
-+C<:shared> attribute:
-
--The only values that can be assigned to a shared scalar are other scalar
--values, or shared refs:
-+ my ($var, %hash, @array) :shared;
-
-- my $var :shared;
-- $var = 1; # ok
-- $var = []; # error
-- $var = &share([]); # ok
--
--C<share> will traverse up references exactly I<one> level. C<share(\$a)> is
--equivalent to C<share($a)>, while C<share(\\$a)> is not. This means that you
--must create nested shared data structures by first creating individual shared
--leaf nodes, and then adding them to a shared hash or array.
-+Shared variables can only store scalars, refs of shared variables, or
-+refs of shared data (discussed in next section):
-
-- my %hash :shared;
-- $hash{'meaning'} = &share([]);
-- $hash{'meaning'}[0] = &share({});
-- $hash{'meaning'}[0]{'life'} = 42;
-+ my ($var, %hash, @array) :shared;
-+ my $bork;
++=head2 --version
+
-+ # Storing scalars
-+ $var = 1;
-+ $hash{'foo'} = 'bar';
-+ $array[0] = 1.5;
++Display the version of F<ppport.h>.
+
-+ # Storing shared refs
-+ $var = \%hash;
-+ $hash{'ary'} = \@array;
-+ $array[1] = \$var;
++=head2 --patch=I<file>
+
-+ # The following are errors:
-+ # $var = \$bork; # ref of non-shared variable
-+ # $hash{'bork'} = []; # non-shared array ref
-+ # push(@array, { 'x' => 1 }); # non-shared hash ref
++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.
+
-+=item shared_clone REF
++=head2 --copy=I<suffix>
+
-+C<shared_clone> takes a reference, and returns a shared version of its
-+argument, performing a deep copy on any non-shared elements. Any shared
-+elements in the argument are used as is (i.e., they are not cloned).
++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
++automagially add a dot between the original filename and the
++suffix. If you want the dot, you have to include it in the option
++argument.
+
-+ my $cpy = shared_clone({'foo' => [qw/foo bar baz/]});
++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.
+
-+Object status (i.e., the class an object is blessed into) is also cloned.
++=head2 --diff=I<program>
+
-+ my $obj = {'foo' => [qw/foo bar baz/]};
-+ bless($obj, 'Foo');
-+ my $cpy = shared_clone($obj);
-+ print(ref($cpy), "\n"); # Outputs 'Foo'
++Manually set the diff program and options to use. The default
++is to use C<Text::Diff>, when installed, and output unified
++context diffs.
+
-+For cloning empty array or hash refs, the following may also be used:
++=head2 --compat-version=I<version>
+
-+ $var = &share([]); # Same as $var = shared_clone([]);
-+ $var = &share({}); # Same as $var = shared_clone({});
-
- =item is_shared VARIABLE
-
-@@ -166,20 +323,33 @@ L<refaddr()|Scalar::Util/"refaddr EXPR">
- print("\$var is not shared\n");
- }
-
-+When used on an element of an array or hash, C<is_shared> checks if the
-+specified element belongs to a shared array or hash. (It does not check
-+the contents of that element.)
++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.
+
-+ my %hash :shared;
-+ if (is_shared(%hash)) {
-+ print("\%hash is shared\n");
-+ }
++=head2 --cplusplus
+
-+ $hash{'elem'} = 1;
-+ if (is_shared($hash{'elem'})) {
-+ print("\$hash{'elem'} is in a shared hash\n");
-+ }
++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.
+
- =item lock VARIABLE
-
--C<lock> places a lock on a variable until the lock goes out of scope. If the
--variable is locked by another thread, the C<lock> call will block until it's
--available. Multiple calls to C<lock> by the same thread from within
--dynamically nested scopes are safe -- the variable will remain locked until
--the outermost lock on the variable goes out of scope.
--
--Locking a container object, such as a hash or array, doesn't lock the elements
--of that container. For example, if a thread does a C<lock(@a)>, any other
--thread doing a C<lock($a[12])> won't block.
-+C<lock> places a B<advisory> lock on a variable until the lock goes out of
-+scope. If the variable is locked by another thread, the C<lock> call will
-+block until it's available. Multiple calls to C<lock> by the same thread from
-+within dynamically nested scopes are safe -- the variable will remain locked
-+until the outermost lock on the variable goes out of scope.
-
--C<lock()> follows references exactly I<one> level. C<lock(\$a)> is equivalent
--to C<lock($a)>, while C<lock(\\$a)> is not.
-+C<lock> follows references exactly I<one> level:
++=head2 --quiet
+
-+ my %hash :shared;
-+ my $ref = \%hash;
-+ lock($ref); # This is equivalent to lock(%hash)
-
- Note that you cannot explicitly unlock a variable; you can only wait for the
- lock to go out of scope. This is most easily accomplished by locking the
-@@ -193,6 +363,16 @@ variable inside a block.
- }
- # $var is now unlocked
-
-+As locks are advisory, they do not prevent data access or modification by
-+another thread that does not itself attempt to obtain a lock on the variable.
++Be quiet. Don't print anything except fatal errors.
+
-+You cannot lock the individual elements of a container variable:
++=head2 --nodiag
+
-+ my %hash :shared;
-+ $hash{'foo'} = 'bar';
-+ #lock($hash{'foo'}); # Error
-+ lock(%hash); # Works
++Don't output any diagnostic messages. Only portability
++alerts will be printed.
+
- If you need more fine-grained control over shared variable access, see
- L<Thread::Semaphore>.
-
-@@ -221,7 +401,7 @@ important to check the value of the vari
- requirement is not fulfilled. For example, to pause until a shared counter
- drops to zero:
-
-- { lock($counter); cond_wait($count) until $counter == 0; }
-+ { lock($counter); cond_wait($counter) until $counter == 0; }
-
- =item cond_timedwait VARIABLE, ABS_TIMEOUT
-
-@@ -279,17 +459,13 @@ a C<cond_wait> on the locked variable, r
- L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that
- works on shared objects such that I<blessings> propagate across threads.
-
-- # Create a shared 'foo' object
-- my $foo;
-- share($foo);
-- $foo = &share({});
-- bless($foo, 'foo');
--
-- # Create a shared 'bar' object
-- my $bar;
-- share($bar);
-- $bar = &share({});
-- bless($bar, 'bar');
-+ # Create a shared 'Foo' object
-+ my $foo :shared = shared_clone({});
-+ bless($foo, 'Foo');
++=head2 --nohints
+
-+ # Create a shared 'Bar' object
-+ my $bar :shared = shared_clone({});
-+ bless($bar, 'Bar');
-
- # Put 'bar' inside 'foo'
- $foo->{'bar'} = $bar;
-@@ -297,26 +473,29 @@ works on shared objects such that I<bles
- # Rebless the objects via a thread
- threads->create(sub {
- # Rebless the outer object
-- bless($foo, 'yin');
-+ bless($foo, 'Yin');
-
- # Cannot directly rebless the inner object
-- #bless($foo->{'bar'}, 'yang');
-+ #bless($foo->{'bar'}, 'Yang');
-
- # Retrieve and rebless the inner object
- my $obj = $foo->{'bar'};
-- bless($obj, 'yang');
-+ bless($obj, 'Yang');
- $foo->{'bar'} = $obj;
-
- })->join();
-
-- print(ref($foo), "\n"); # Prints 'yin'
-- print(ref($foo->{'bar'}), "\n"); # Prints 'yang'
-- print(ref($bar), "\n"); # Also prints 'yang'
-+ print(ref($foo), "\n"); # Prints 'Yin'
-+ print(ref($foo->{'bar'}), "\n"); # Prints 'Yang'
-+ print(ref($bar), "\n"); # Also prints 'Yang'
-
- =head1 NOTES
-
--threads::shared is designed to disable itself silently if threads are not
--available. If you want access to threads, you must C<use threads> before you
-+L<threads::shared> is designed to disable itself silently if threads are not
-+available. This allows you to write modules and packages that can be used
-+in both threaded and non-threaded applications.
++Don't output any hints. Hints often contain useful portability
++notes. Warnings will still be displayed.
+
-+If you want access to threads, you must C<use threads> before you
- C<use threads::shared>. L<threads> will emit a warning if you use it after
- L<threads::shared>.
-
-@@ -354,13 +533,54 @@ Taking references to the elements of sha
- autovivify the elements, and neither does slicing a shared array/hash over
- non-existent indices/keys autovivify the elements.
-
--C<share()> allows you to C<< share($hashref->{key}) >> without giving any
--error message. But the C<< $hashref->{key} >> is B<not> shared, causing the
--error "locking can only be used on shared values" to occur when you attempt to
--C<< lock($hasref->{key}) >>.
-+C<share()> allows you to C<< share($hashref->{key}) >> and
-+C<< share($arrayref->[idx]) >> without giving any error message. But the
-+C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing
-+the error "lock can only be used on shared values" to occur when you attempt
-+to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another
-+thread.
++=head2 --nochanges
+
-+Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing
-+whether or not two shared references are equivalent (e.g., when testing for
-+circular references). Use L<is_shared()/"is_shared VARIABLE">, instead:
++Don't suggest any changes. Only give diagnostic output and hints
++unless these are also deactivated.
+
-+ use threads;
-+ use threads::shared;
-+ use Scalar::Util qw(refaddr);
++=head2 --nofilter
+
-+ # If ref is shared, use threads::shared's internal ID.
-+ # Otherwise, use refaddr().
-+ my $addr1 = is_shared($ref1) || refaddr($ref1);
-+ my $addr2 = is_shared($ref2) || refaddr($ref2);
++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.
+
-+ if ($addr1 == $addr2) {
-+ # The refs are equivalent
-+ }
++=head2 --strip
+
-+L<each()|perlfunc/"each HASH"> does not work properly on shared references
-+embedded in shared structures. For example:
++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.
+
-+ my %foo :shared;
-+ $foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'});
++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.
+
-+ while (my ($key, $val) = each(%{$foo{'bar'}})) {
-+ ...
-+ }
++=head2 --list-provided
+
-+Either of the following will work instead:
++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.
+
-+ my $ref = $foo{'bar'};
-+ while (my ($key, $val) = each(%{$ref})) {
-+ ...
-+ }
++=head2 --list-unsupported
+
-+ foreach my $key (keys(%{$foo{'bar'}})) {
-+ my $val = $foo{'bar'}{$key};
-+ ...
-+ }
-
- View existing bug reports at, and submit any new bugs, problems, patches, etc.
--to: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads-shared>
-+to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
-
- =head1 SEE ALSO
-
-@@ -368,7 +588,7 @@ L<threads::shared> Discussion Forum on C
- L<http://www.cpanforum.com/dist/threads-shared>
-
- Annotated POD for L<threads::shared>:
--L<http://annocpan.org/~JDHEDDEN/threads-shared-1.14/shared.pm>
-+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.29/shared.pm>
-
- Source repository:
- L<http://code.google.com/p/threads-shared/>
-@@ -385,10 +605,12 @@ L<http://lists.cpan.org/showlist.cgi?nam
-
- Artur Bergman E<lt>sky AT crucially DOT netE<gt>
-
--threads::shared is released under the same license as Perl.
--
- Documentation borrowed from the old Thread.pm.
-
- CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>.
-
-+=head1 LICENSE
++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.
+
-+threads::shared is released under the same license as Perl.
++=head2 --api-info=I<name>
+
- =cut
-diff -up perl-5.10.0/ext/threads/shared/shared.xs.shared perl-5.10.0/ext/threads/shared/shared.xs
---- perl-5.10.0/ext/threads/shared/shared.xs.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/shared.xs 2010-09-07 08:35:16.188635414 +0200
-@@ -123,6 +123,7 @@
- # define NEED_sv_2pv_flags
- # define NEED_vnewSVpvf
- # define NEED_warner
-+# define NEED_newSVpvn_flags
- # include "ppport.h"
- # include "shared.h"
- #endif
-@@ -712,6 +713,11 @@ sharedsv_scalar_mg_get(pTHX_ SV *sv, MAG
- ENTER_LOCK;
- if (SvROK(ssv)) {
- S_get_RV(aTHX_ sv, ssv);
-+ /* Look ahead for refs of refs */
-+ if (SvROK(SvRV(ssv))) {
-+ SvROK_on(SvRV(sv));
-+ S_get_RV(aTHX_ SvRV(sv), SvRV(ssv));
-+ }
- } else {
- sv_setsv_nomg(sv, ssv);
- }
-@@ -867,10 +873,15 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAG
- svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
- } else {
- char *key = mg->mg_ptr;
-- STRLEN len = mg->mg_len;
-+ I32 len = mg->mg_len;
- assert ( mg->mg_ptr != 0 );
- if (mg->mg_len == HEf_SVKEY) {
-- key = SvPV((SV *) mg->mg_ptr, len);
-+ STRLEN slen;
-+ key = SvPV((SV *)mg->mg_ptr, slen);
-+ len = slen;
-+ if (SvUTF8((SV *)mg->mg_ptr)) {
-+ len = -len;
-+ }
- }
- SHARED_CONTEXT;
- svp = hv_fetch((HV*) saggregate, key, len, 0);
-@@ -880,9 +891,13 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAG
- /* Exists in the array */
- if (SvROK(*svp)) {
- S_get_RV(aTHX_ sv, *svp);
-+ /* Look ahead for refs of refs */
-+ if (SvROK(SvRV(*svp))) {
-+ SvROK_on(SvRV(sv));
-+ S_get_RV(aTHX_ SvRV(sv), SvRV(*svp));
-+ }
- } else {
-- /* XXX Can this branch ever happen? DAPM */
-- /* XXX assert("no such branch"); */
-+ /* $ary->[elem] or $ary->{elem} is a scalar */
- Perl_sharedsv_associate(aTHX_ sv, *svp);
- sv_setsv(sv, *svp);
- }
-@@ -914,10 +929,16 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAG
- svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
- } else {
- char *key = mg->mg_ptr;
-- STRLEN len = mg->mg_len;
-+ I32 len = mg->mg_len;
- assert ( mg->mg_ptr != 0 );
-- if (mg->mg_len == HEf_SVKEY)
-- key = SvPV((SV *) mg->mg_ptr, len);
-+ if (mg->mg_len == HEf_SVKEY) {
-+ STRLEN slen;
-+ key = SvPV((SV *)mg->mg_ptr, slen);
-+ len = slen;
-+ if (SvUTF8((SV *)mg->mg_ptr)) {
-+ len = -len;
-+ }
++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
++ 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
++ 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
++ 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 using the CPAN Request Tracker at L<http://rt.cpan.org/>.
++
++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-2009, 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.19;
++
++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(
++AvFILLp|5.004050||p
++AvFILL|||
++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||p
++Copy|||
++CvPADLIST|||
++CvSTASH|||
++CvWEAKOUTSIDE|||
++DEFSV_set|5.011000||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|||
++GvSVn|5.009003||p
++GvSV|||
++Gv_AMupdate|||
++HEf_SVKEY||5.004000|
++HeHASH||5.004000|
++HeKEY||5.004000|
++HeKLEN||5.004000|
++HePV||5.004000|
++HeSVKEY_force||5.004000|
++HeSVKEY_set||5.004000|
++HeSVKEY||5.004000|
++HeUTF8||5.011000|
++HeVAL||5.004000|
++HvNAMELEN_get|5.009003||p
++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|||
++LVRET|||
++MARK|||
++MULTICALL||5.011000|
++MY_CXT_CLONE|5.009002||p
++MY_CXT_INIT|5.007003||p
++MY_CXT|5.007003||p
++MoveD|5.009002||p
++Move|||
++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|||
++ORIGMARK|||
++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_DUP|||
++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.011000||p
++PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
++PERL_HASH|5.004000||p
++PERL_INT_MAX|5.004000||p
++PERL_INT_MIN|5.004000||p
++PERL_LONG_MAX|5.004000||p
++PERL_LONG_MIN|5.004000||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.011000||p
++PERL_MAGIC_isaelem|5.007002||p
++PERL_MAGIC_isa|5.007002||p
++PERL_MAGIC_mutex|5.011000||p
++PERL_MAGIC_nkeys|5.007002||p
++PERL_MAGIC_overload_elem|5.007002||p
++PERL_MAGIC_overload_table|5.007002||p
++PERL_MAGIC_overload|5.007002||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.004000||p
++PERL_QUAD_MIN|5.004000||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.004000||p
++PERL_SHORT_MIN|5.004000||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.011000|
++PERL_UCHAR_MAX|5.004000||p
++PERL_UCHAR_MIN|5.004000||p
++PERL_UINT_MAX|5.004000||p
++PERL_UINT_MIN|5.004000||p
++PERL_ULONG_MAX|5.004000||p
++PERL_ULONG_MIN|5.004000||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.004000||p
++PERL_UQUAD_MIN|5.004000||p
++PERL_USE_GCC_BRACE_GROUPS|5.009004||p
++PERL_USHORT_MAX|5.004000||p
++PERL_USHORT_MIN|5.004000||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.011000||p
++PL_bufptr|5.011000||p
++PL_compiling|5.004050||p
++PL_copline|5.011000||p
++PL_curcop|5.004050||p
++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.011000||p
++PL_expect|5.011000||p
++PL_hexdigit|5.005000||p
++PL_hints|5.005000||p
++PL_in_my_stash|5.011000||p
++PL_in_my|5.011000||p
++PL_last_in_gv|||n
++PL_laststatval|5.005000||p
++PL_lex_state|5.011000||p
++PL_lex_stuff|5.011000||p
++PL_linestr|5.011000||p
++PL_modglobal||5.005000|n
++PL_na|5.004050||pn
++PL_no_modify|5.006000||p
++PL_ofsgv|||n
++PL_parser|5.009005||p
++PL_perl_destruct_level|5.004050||p
++PL_perldb|5.004050||p
++PL_ppaddr|5.006000||p
++PL_rsfp_filters|5.004050||p
++PL_rsfp|5.004050||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.011000||p
++POP_MULTICALL||5.011000|
++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.011000|
++PUSHi|||
++PUSHmortal|5.009002||p
++PUSHn|||
++PUSHp|||
++PUSHs|||
++PUSHu|5.004000||p
++PUTBACK|||
++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_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
++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_IV|||
++SVt_NV|||
++SVt_PVAV|||
++SVt_PVCV|||
++SVt_PVHV|||
++SVt_PVMG|||
++SVt_PV|||
++Safefree|||
++Slab_Alloc|||
++Slab_Free|||
++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_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|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|||
++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|||
++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.011000||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
++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_VERSION_BOOTCHECK|||
++XS_VERSION|||
++XSprePUSH|5.006000||p
++XS|||
++ZeroD|5.009002||p
++Zero|||
++_aMY_CXT|5.007003||p
++_pMY_CXT|5.007003||p
++aMY_CXT_|5.007003||p
++aMY_CXT|5.007003||p
++aTHXR_|5.011000||p
++aTHXR|5.011000||p
++aTHX_|5.006000||p
++aTHX|5.006000||p
++add_data|||n
++addmad|||
++allocmy|||
++amagic_call|||
++amagic_cmp_locale|||
++amagic_cmp|||
++amagic_i_ncmp|||
++amagic_ncmp|||
++any_dup|||
++ao|||
++append_elem|||
++append_list|||
++append_madprops|||
++apply_attrs_my|||
++apply_attrs_string||5.006001|
++apply_attrs|||
++apply|||
++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|||
++av_fetch|||
++av_fill|||
++av_iter_p||5.011000|
++av_len|||
++av_make|||
++av_pop|||
++av_push|||
++av_reify|||
++av_shift|||
++av_store|||
++av_undef|||
++av_unshift|||
++ax|||n
++bad_type|||
++bind_match|||
++block_end|||
++block_gimme||5.004000|
++block_start|||
++boolSV|5.004000||p
++boot_core_PerlIO|||
++boot_core_UNIVERSAL|||
++boot_core_mro|||
++bytes_from_utf8||5.007001|
++bytes_to_uni|||n
++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
++calloc||5.007002|n
++cando|||
++cast_i32||5.006000|
++cast_iv||5.006000|
++cast_ulong||5.006000|
++cast_uv||5.006000|
++check_type_and_open|||
++check_uni|||
++checkcomma|||
++checkposixcc|||
++ckWARN|5.006000||p
++ck_anoncode|||
++ck_bitop|||
++ck_concat|||
++ck_defined|||
++ck_delete|||
++ck_die|||
++ck_each|||
++ck_eof|||
++ck_eval|||
++ck_exec|||
++ck_exists|||
++ck_exit|||
++ck_ftst|||
++ck_fun|||
++ck_glob|||
++ck_grep|||
++ck_index|||
++ck_join|||
++ck_lfun|||
++ck_listiob|||
++ck_match|||
++ck_method|||
++ck_null|||
++ck_open|||
++ck_readline|||
++ck_repeat|||
++ck_require|||
++ck_return|||
++ck_rfun|||
++ck_rvconst|||
++ck_sassign|||
++ck_select|||
++ck_shift|||
++ck_sort|||
++ck_spair|||
++ck_split|||
++ck_subr|||
++ck_substr|||
++ck_svconst|||
++ck_trunc|||
++ck_unpack|||
++ckwarn_d||5.009003|
++ckwarn||5.009003|
++cl_and|||n
++cl_anything|||n
++cl_init_zero|||n
++cl_init|||n
++cl_is_anything|||n
++cl_or|||n
++clear_placeholders|||
++closest_cop|||
++convert|||
++cop_free|||
++cr_textfilter|||
++create_eval_scope|||
++croak_nocontext|||vn
++croak_xs_usage||5.011000|
++croak|||v
++csighandler||5.009003|n
++curmad|||
++custom_op_desc||5.007003|
++custom_op_name||5.007003|
++cv_ckproto_len|||
++cv_clone|||
++cv_const_sv||5.004000|
++cv_dump|||
++cv_undef|||
++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.011000||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
++del_sv|||
++delete_eval_scope|||
++delimcpy||5.004000|
++deprecate_old|||
++deprecate|||
++despatch_signals||5.007001|
++destroy_matcher|||
++die_nocontext|||vn
++die_where|||
++die|||v
++dirp_dup|||
++div128|||
++djSP|||
++do_aexec5|||
++do_aexec|||
++do_aspawn|||
++do_binmode||5.004050|
++do_chomp|||
++do_chop|||
++do_close|||
++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_kv|||
++do_magic_dump||5.006000|
++do_msgrcv|||
++do_msgsnd|||
++do_oddball|||
++do_op_dump||5.006000|
++do_op_xmldump|||
++do_open9||5.006000|
++do_openn||5.007001|
++do_open||5.004000|
++do_pmop_dump||5.006000|
++do_pmop_xmldump|||
++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|||
++dump_all||5.006000|
++dump_eval||5.006000|
++dump_exec_pos|||
++dump_fds|||
++dump_form||5.006000|
++dump_indent||5.006000|v
++dump_mstats|||
++dump_packsubs||5.006000|
++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|||
++fetch_cop_label||5.011000|
++filter_add|||
++filter_del|||
++filter_gets|||
++filter_read|||
++find_and_forget_pmops|||
++find_array_subscript|||
++find_beginning|||
++find_byclass|||
++find_hash_subscript|||
++find_in_my_stash|||
++find_runcv||5.008001|
++find_rundefsvoffset||5.009002|
++find_script|||
++find_uninit_var|||
++first_symbol|||n
++fold_constants|||
++forbid_setid|||
++force_ident|||
++force_list|||
++force_next|||
++force_version|||
++force_word|||
++forget_pmop|||
++form_nocontext|||vn
++form||5.004000|v
++fp_dup|||
++fprintf_nocontext|||vn
++free_global_struct|||
++free_tied_hv_pool|||
++free_tmps|||
++gen_constant_list|||
++get_arena|||
++get_aux_mg|||
++get_av|5.006000||p
++get_context||5.006000|n
++get_cvn_flags||5.009005|
++get_cv|5.006000||p
++get_db_sub|||
++get_debug_opts|||
++get_hash_seed|||
++get_hv|5.006000||p
++get_isa_hash|||
++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|||
++glob_assign_ref|||
++gp_dup|||
++gp_free|||
++gp_ref|||
++grok_bin|5.007003||p
++grok_hex|5.007003||p
++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_autoload4||5.004000|
++gv_check|||
++gv_const_sv||5.009003|
++gv_dump||5.006000|
++gv_efullname3||5.004000|
++gv_efullname4||5.006001|
++gv_efullname|||
++gv_ename|||
++gv_fetchfile_flags||5.009005|
++gv_fetchfile|||
++gv_fetchmeth_autoload||5.007003|
++gv_fetchmethod_autoload||5.004000|
++gv_fetchmethod_flags||5.011000|
++gv_fetchmethod|||
++gv_fetchmeth|||
++gv_fetchpvn_flags|5.009002||p
++gv_fetchpvs|5.009004||p
++gv_fetchpv|||
++gv_fetchsv||5.009002|
++gv_fullname3||5.004000|
++gv_fullname4||5.006001|
++gv_fullname|||
++gv_get_super_pkg|||
++gv_handler||5.007001|
++gv_init_sv|||
++gv_init|||
++gv_name_set||5.009004|
++gv_stashpvn|5.004000||p
++gv_stashpvs|5.009003||p
++gv_stashpv|||
++gv_stashsv|||
++he_dup|||
++hek_dup|||
++hfreeentries|||
++hsplit|||
++hv_assert||5.011000|
++hv_auxinit|||n
++hv_backreferences_p|||
++hv_clear_placeholders||5.009001|
++hv_clear|||
++hv_common_key_len||5.010000|
++hv_common||5.010000|
++hv_copy_hints_hv|||
++hv_delayfree_ent||5.004000|
++hv_delete_common|||
++hv_delete_ent||5.004000|
++hv_delete|||
++hv_eiter_p||5.009003|
++hv_eiter_set||5.009003|
++hv_exists_ent||5.004000|
++hv_exists|||
++hv_fetch_ent||5.004000|
++hv_fetchs|5.009003||p
++hv_fetch|||
++hv_free_ent||5.004000|
++hv_iterinit|||
++hv_iterkeysv||5.004000|
++hv_iterkey|||
++hv_iternext_flags||5.008000|
++hv_iternextsv|||
++hv_iternext|||
++hv_iterval|||
++hv_kill_backrefs|||
++hv_ksplit||5.004000|
++hv_magic_check|||n
++hv_magic|||
++hv_name_set||5.009003|
++hv_notallowed|||
++hv_placeholders_get||5.009003|
++hv_placeholders_p||5.009003|
++hv_placeholders_set||5.009003|
++hv_riter_p||5.009003|
++hv_riter_set||5.009003|
++hv_scalar||5.009001|
++hv_store_ent||5.004000|
++hv_store_flags||5.008000|
++hv_stores|5.009004||p
++hv_store|||
++hv_undef|||
++ibcmp_locale||5.004000|
++ibcmp_utf8||5.007003|
++ibcmp|||
++incline|||
++incpush_if_exists|||
++incpush_use_sep|||
++incpush|||
++ingroup|||
++init_argv_symbols|||
++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|
++instr|||
++intro_my|||
++intuit_method|||
++intuit_more|||
++invert|||
++io_close|||
++isALNUMC|5.006000||p
++isALNUM|||
++isALPHA|||
++isASCII|5.006000||p
++isBLANK|5.006001||p
++isCNTRL|5.006000||p
++isDIGIT|||
++isGRAPH|5.006000||p
++isGV_with_GP|5.009004||p
++isLOWER|||
++isPRINT|5.004000||p
++isPSXSPC|5.006001||p
++isPUNCT|5.006000||p
++isSPACE|||
++isUPPER|||
++isXDIGIT|5.006000||p
++is_an_int|||
++is_gv_magical_sv|||
++is_handle_constructor|||n
++is_list_assignment|||
++is_lvalue_sub||5.007001|
++is_uni_alnum_lc||5.006000|
++is_uni_alnumc_lc||5.006000|
++is_uni_alnumc||5.006000|
++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_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.006000|
++is_utf8_alnum||5.006000|
++is_utf8_alpha||5.006000|
++is_utf8_ascii||5.006000|
++is_utf8_char_slow|||n
++is_utf8_char||5.006000|
++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_print||5.006000|
++is_utf8_punct||5.006000|
++is_utf8_space||5.006000|
++is_utf8_string_loclen||5.009003|
++is_utf8_string_loc||5.008001|
++is_utf8_string||5.006001|
++is_utf8_upper||5.006000|
++is_utf8_xdigit||5.006000|
++isa_lookup|||
++items|||n
++ix|||n
++jmaybe|||
++join_exact|||
++keyword|||
++leave_scope|||
++lex_end|||
++lex_start|||
++linklist|||
++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.011000||p
++mPUSHu|5.009002||p
++mXPUSHi|5.009002||p
++mXPUSHn|5.009002||p
++mXPUSHp|5.009002||p
++mXPUSHs|5.011000||p
++mXPUSHu|5.009002||p
++mad_free|||
++madlex|||
++madparse|||
++magic_clear_all_env|||
++magic_clearenv|||
++magic_clearhint|||
++magic_clearisa|||
++magic_clearpack|||
++magic_clearsig|||
++magic_dump||5.006000|
++magic_existspack|||
++magic_freearylen_p|||
++magic_freeovrld|||
++magic_getarylen|||
++magic_getdefelem|||
++magic_getnkeys|||
++magic_getpack|||
++magic_getpos|||
++magic_getsig|||
++magic_getsubstr|||
++magic_gettaint|||
++magic_getuvar|||
++magic_getvec|||
++magic_get|||
++magic_killbackrefs|||
++magic_len|||
++magic_methcall|||
++magic_methpack|||
++magic_nextpack|||
++magic_regdata_cnt|||
++magic_regdatum_get|||
++magic_regdatum_set|||
++magic_scalarpack|||
++magic_set_all_env|||
++magic_setamagic|||
++magic_setarylen|||
++magic_setcollxfrm|||
++magic_setdbline|||
++magic_setdefelem|||
++magic_setenv|||
++magic_sethint|||
++magic_setisa|||
++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_failtable|||
++make_trie|||
++malloc_good_size|||n
++malloced_size|||n
++malloc||5.007002|n
++markstack_grow|||
++matcher_matches_sv|||
++measure_struct|||
++memEQ|5.004000||p
++memNE|5.004000||p
++mem_collxfrm|||
++mem_log_common|||n
++mess_alloc|||
++mess_nocontext|||vn
++mess||5.006000|v
++method_common|||
++mfree||5.007002|n
++mg_clear|||
++mg_copy|||
++mg_dup|||
++mg_find|||
++mg_free|||
++mg_get|||
++mg_length||5.005000|
++mg_localize|||
++mg_magical|||
++mg_set|||
++mg_size||5.005000|
++mini_mktime||5.007002|
++missingterm|||
++mode_from_discipline|||
++modkids|||
++mod|||
++more_bodies|||
++more_sv|||
++moreswitches|||
++mro_get_from_name||5.011000|
++mro_get_linear_isa_dfs|||
++mro_get_linear_isa||5.009005|
++mro_get_private_data||5.011000|
++mro_isa_changed_in|||
++mro_meta_dup|||
++mro_meta_init|||
++mro_method_changed_in||5.009005|
++mro_register||5.011000|
++mro_set_mro||5.011000|
++mro_set_private_data||5.011000|
++mul128|||
++mulexp10|||n
++my_atof2||5.007002|
++my_atof||5.006000|
++my_attrs|||
++my_bcopy|||n
++my_betoh16|||n
++my_betoh32|||n
++my_betoh64|||n
++my_betohi|||n
++my_betohl|||n
++my_betohs|||n
++my_bzero|||n
++my_chsize|||
++my_clearenv|||
++my_cxt_index|||
++my_cxt_init|||
++my_dirfd||5.009005|
++my_exit_jump|||
++my_exit|||
++my_failure_exit||5.004000|
++my_fflush_all||5.006000|
++my_fork||5.007003|n
++my_htobe16|||n
++my_htobe32|||n
++my_htobe64|||n
++my_htobei|||n
++my_htobel|||n
++my_htobes|||n
++my_htole16|||n
++my_htole32|||n
++my_htole64|||n
++my_htolei|||n
++my_htolel|||n
++my_htoles|||n
++my_htonl|||
++my_kid|||
++my_letoh16|||n
++my_letoh32|||n
++my_letoh64|||n
++my_letohi|||n
++my_letohl|||n
++my_letohs|||n
++my_lstat|||
++my_memcmp||5.004000|n
++my_memset|||n
++my_ntohl|||
++my_pclose||5.004000|
++my_popen_list||5.007001|
++my_popen||5.004000|
++my_setenv|||
++my_snprintf|5.009004||pvn
++my_socketpair||5.007003|n
++my_sprintf|5.009003||pvn
++my_stat|||
++my_strftime||5.007002|
++my_strlcat|5.009004||pn
++my_strlcpy|5.009004||pn
++my_swabn|||n
++my_swap|||
++my_unexec|||
++my_vsnprintf||5.009004|n
++need_utf8|||n
++newANONATTRSUB||5.006000|
++newANONHASH|||
++newANONLIST|||
++newANONSUB|||
++newASSIGNOP|||
++newATTRSUB||5.006000|
++newAVREF|||
++newAV|||
++newBINOP|||
++newCONDOP|||
++newCONSTSUB|5.004050||p
++newCVREF|||
++newDEFSVOP|||
++newFORM|||
++newFOROP|||
++newGIVENOP||5.009003|
++newGIVWHENOP|||
++newGP|||
++newGVOP|||
++newGVREF|||
++newGVgen|||
++newHVREF|||
++newHVhv||5.005000|
++newHV|||
++newIO|||
++newLISTOP|||
++newLOGOP|||
++newLOOPEX|||
++newLOOPOP|||
++newMADPROP|||
++newMADsv|||
++newMYSUB|||
++newNULLLIST|||
++newOP|||
++newPADOP|||
++newPMOP|||
++newPROG|||
++newPVOP|||
++newRANGE|||
++newRV_inc|5.004000||p
++newRV_noinc|5.004000||p
++newRV|||
++newSLICEOP|||
++newSTATEOP|||
++newSUB|||
++newSVOP|||
++newSVREF|||
++newSV_type|5.009005||p
++newSVhek||5.009003|
++newSViv|||
++newSVnv|||
++newSVpvf_nocontext|||vn
++newSVpvf||5.004000|v
++newSVpvn_flags|5.011000||p
++newSVpvn_share|5.007001||p
++newSVpvn_utf8|5.011000||p
++newSVpvn|5.004050||p
++newSVpvs_flags|5.011000||p
++newSVpvs_share||5.009003|
++newSVpvs|5.009003||p
++newSVpv|||
++newSVrv|||
++newSVsv|||
++newSVuv|5.006000||p
++newSV|||
++newTOKEN|||
++newUNOP|||
++newWHENOP||5.009003|
++newWHILEOP||5.009003|
++newXS_flags||5.009004|
++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|||
++no_bareword_allowed|||
++no_fh_allowed|||
++no_op|||
++not_a_number|||
++nothreadhook||5.008000|
++nuke_stacks|||
++num_overflow|||n
++offer_nice_chunk|||
++oopsAV|||
++oopsHV|||
++op_clear|||
++op_const_sv|||
++op_dump||5.006000|
++op_free|||
++op_getmad_weak|||
++op_getmad|||
++op_null||5.007002|
++op_refcnt_dec|||
++op_refcnt_inc|||
++op_refcnt_lock||5.009002|
++op_refcnt_unlock||5.009002|
++op_xmldump|||
++open_script|||
++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|||
++packlist||5.008001|
++pad_add_anon|||
++pad_add_name|||
++pad_alloc|||
++pad_block_start|||
++pad_check_dup|||
++pad_compname_type|||
++pad_findlex|||
++pad_findmy|||
++pad_fixup_inner_anons|||
++pad_free|||
++pad_leavemy|||
++pad_new|||
++pad_peg|||n
++pad_push|||
++pad_reset|||
++pad_setsv|||
++pad_sv||5.011000|
++pad_swipe|||
++pad_tidy|||
++pad_undef|||
++parse_body|||
++parse_unicode_opts|||
++parser_dup|||
++parser_free|||
++path_is_absolute|||n
++peep|||
++pending_Slabs_to_ro|||
++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|||
++pmflag|||
++pmop_dump||5.006000|
++pmop_xmldump|||
++pmruntime|||
++pmtrans|||
++pop_scope|||
++pregcomp||5.009005|
++pregexec|||
++pregfree2||5.011000|
++pregfree|||
++prepend_elem|||
++prepend_madprops|||
++printbuf|||
++printf_nocontext|||vn
++process_special_blocks|||
++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_byte|||
++pv_display|5.006000||p
++pv_escape|5.009004||p
++pv_pretty|5.009004||p
++pv_uni_display||5.007003|
++qerror|||
++qsortsvu|||
++re_compile||5.009005|
++re_croak2|||
++re_dup_guts|||
++re_intuit_start||5.009005|
++re_intuit_string||5.006000|
++readpipe_override|||
++realloc||5.007002|n
++reentrant_free|||
++reentrant_init|||
++reentrant_retry|||vn
++reentrant_size|||
++ref_array_or_hash|||
++refcounted_he_chain_2hv|||
++refcounted_he_fetch|||
++refcounted_he_free|||
++refcounted_he_new_common|||
++refcounted_he_new|||
++refcounted_he_value|||
++refkids|||
++refto|||
++ref||5.011000|
++reg_check_named_buff_matched|||
++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_namedseq|||
++reg_node|||
++reg_numbered_buff_fetch|||
++reg_numbered_buff_length|||
++reg_numbered_buff_store|||
++reg_qr_package|||
++reg_recode|||
++reg_scan_name|||
++reg_skipcomment|||
++reg_temp_copy|||
++reganode|||
++regatom|||
++regbranch|||
++regclass_swash||5.009004|
++regclass|||
++regcppop|||
++regcppush|||
++regcurly|||n
++regdump_extflags|||
++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|
++regpiece|||
++regpposixcc|||
++regprop|||
++regrepeat|||
++regtail_study|||
++regtail|||
++regtry|||
++reguni|||
++regwhite|||n
++reg|||
++repeatcpy|||
++report_evil_fh|||
++report_uninit|||
++require_pv||5.006000|
++require_tie_mod|||
++restore_magic|||
++rninstr|||
++rsignal_restore|||
++rsignal_save|||
++rsignal_state||5.004000|
++rsignal||5.004000|
++run_body|||
++run_user_filter|||
++runops_debug||5.005000|
++runops_standard||5.005000|
++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||5.004050|
++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_hek_flags|||n
++save_helem_flags||5.011000|
++save_helem||5.004050|
++save_hints|||
++save_hptr|||
++save_int|||
++save_item|||
++save_iv||5.005000|
++save_lines|||
++save_list|||
++save_long|||
++save_magic|||
++save_mortalizesv||5.007001|
++save_nogv|||
++save_op|||
++save_padsv_and_mortalize||5.011000|
++save_pptr|||
++save_pushi32ptr|||
++save_pushptri32ptr|||
++save_pushptrptr|||
++save_pushptr||5.011000|
++save_re_context||5.006000|
++save_scalar_at|||
++save_scalar|||
++save_set_svflags||5.009000|
++save_shared_pvref||5.007003|
++save_sptr|||
++save_svref|||
++save_vptr||5.006000|
++savepvn|||
++savepvs||5.009003|
++savepv|||
++savesharedpvn||5.009005|
++savesharedpv||5.007003|
++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|||
++scope|||
++screaminstr||5.005000|
++search_const|||
++seed||5.008001|
++sequence_num|||
++sequence_tail|||
++sequence|||
++set_context||5.006000|n
++set_numeric_local||5.006000|
++set_numeric_radix||5.006000|
++set_numeric_standard||5.006000|
++setdefout|||
++share_hek_flags|||
++share_hek||5.004000|
++si_dup|||
++sighandler|||n
++simplify_sort|||
++skipspace0|||
++skipspace1|||
++skipspace2|||
++skipspace|||
++softref2xv|||
++sortcv_stacked|||
++sortcv_xsub|||
++sortcv|||
++sortsv_flags||5.009003|
++sortsv||5.007003|
++space_join_names_mortal|||
++ss_dup|||
++stack_grow|||
++start_force|||
++start_glob|||
++start_subparse||5.004000|
++stashpv_hvname_match||5.011000|
++stdize_locale|||
++store_cop_label|||
++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|||
++sv_2cv|||
++sv_2io|||
++sv_2iuv_common|||
++sv_2iuv_non_preserve|||
++sv_2iv_flags||5.009001|
++sv_2iv|||
++sv_2mortal|||
++sv_2num|||
++sv_2nv|||
++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|||
++sv_bless|||
++sv_cat_decode||5.008001|
++sv_catpv_mg|5.004050||p
++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|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_catxmlpvn|||
++sv_catxmlsv|||
++sv_chop|||
++sv_clean_all|||
++sv_clean_objs|||
++sv_clear|||
++sv_cmp_locale||5.004000|
++sv_cmp|||
++sv_collxfrm|||
++sv_compile_2op||5.008001|
++sv_copypv||5.007003|
++sv_dec|||
++sv_del_backref|||
++sv_derived_from||5.004000|
++sv_destroyable||5.010000|
++sv_does||5.009004|
++sv_dump|||
++sv_dup_inc_multiple|||
++sv_dup|||
++sv_eq|||
++sv_exp_grow|||
++sv_force_normal_flags||5.007001|
++sv_force_normal||5.006000|
++sv_free2|||
++sv_free_arenas|||
++sv_free|||
++sv_gets||5.004000|
++sv_grow|||
++sv_i_ncmp|||
++sv_inc|||
++sv_insert_flags||5.011000|
++sv_insert|||
++sv_isa|||
++sv_isobject|||
++sv_iv||5.005000|
++sv_kill_backrefs|||
++sv_len_utf8||5.006000|
++sv_len|||
++sv_magic_portable|5.011000|5.004000|p
++sv_magicext||5.007003|
++sv_magic|||
++sv_mortalcopy|||
++sv_ncmp|||
++sv_newmortal|||
++sv_newref|||
++sv_nolocking||5.007003|
++sv_nosharing||5.007003|
++sv_nounlocking|||
++sv_nv||5.005000|
++sv_peek||5.005000|
++sv_pos_b2u_midway|||
++sv_pos_b2u||5.006000|
++sv_pos_u2b_cached|||
++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_release_COW|||
++sv_replace|||
++sv_report_used|||
++sv_reset|||
++sv_rvweaken||5.006000|
++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|5.009004||p
++sv_setpv|||
++sv_setref_iv|||
++sv_setref_nv|||
++sv_setref_pvn|||
++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_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||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
++sv_xmlpeek|||
++svtype|||
++swallow_bom|||
++swap_match_buff|||
++swash_fetch||5.007002|
++swash_get|||
++swash_init||5.006000|
++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|||
++tmps_grow||5.006000|
++toLOWER|||
++toUPPER|||
++to_byte_substr|||
++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.007003|
++to_utf8_lower||5.007003|
++to_utf8_substr|||
++to_utf8_title||5.007003|
++to_utf8_upper||5.007003|
++token_free|||
++token_getmad|||
++tokenize_use|||
++tokeq|||
++tokereport|||
++too_few_arguments|||
++too_many_arguments|||
++uiv_2buf|||n
++unlnk|||
++unpack_rec|||
++unpack_str||5.007003|
++unpackstring||5.008001|
++unshare_hek_or_pvn|||
++unshare_hek|||
++unsharepvn||5.004000|
++unwind_handler_stack|||
++update_debugger_info|||
++upg_version||5.009005|
++usage|||
++utf16_to_utf8_reversed||5.006001|
++utf16_to_utf8||5.006001|
++utf8_distance||5.006000|
++utf8_hop||5.006000|
++utf8_length||5.007001|
++utf8_mg_pos_cache_update|||
++utf8_to_bytes||5.006001|
++utf8_to_uvchr||5.007001|
++utf8_to_uvuni||5.007001|
++utf8n_to_uvchr|||
++utf8n_to_uvuni||5.007001|
++utilize|||
++uvchr_to_utf8_flags||5.007003|
++uvchr_to_utf8|||
++uvuni_to_utf8_flags||5.007003|
++uvuni_to_utf8||5.007001|
++validate_suid|||
++varname|||
++vcmp||5.009000|
++vcroak||5.006000|
++vdeb||5.007003|
++vdie_common|||
++vdie_croak_common|||
++vdie|||
++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
++warner_nocontext|||vn
++warner|5.006000|5.004000|pv
++warn|||v
++watch|||
++whichsig|||
++write_no_mem|||
++write_to_stderr|||
++xmldump_all|||
++xmldump_attr|||
++xmldump_eval|||
++xmldump_form|||
++xmldump_indent|||v
++xmldump_packsubs|||
++xmldump_sub|||
++xmldump_vindent|||
++yyerror|||
++yylex|||
++yyparse|||
++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{$_};
++ }
+ }
- SHARED_CONTEXT;
- svp = hv_fetch((HV*) saggregate, key, len, 1);
++ }
++ 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 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 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 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
++#ifndef isALNUMC
++# define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
++#endif
++
++#ifndef isASCII
++# define isASCII(c) ((c) <= 127)
++#endif
++
++#ifndef isCNTRL
++# define isCNTRL(c) ((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
++
++#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);
++#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"
++# else
++# if IVSIZE == INTSIZE
++# define IVdf "d"
++# define UVuf "u"
++# define UVof "o"
++# define UVxf "x"
++# define UVXf "X"
++# endif
++# 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_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
++
++#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 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 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_fetchpvn_flags
++# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
++#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 SvGETMAGIC
++# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
++#endif
++#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
++
++#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 */
++#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 -up perl-5.10.0/ext/threads/shared/shared.h.newshare perl-5.10.0/ext/threads/shared/shared.h
+--- perl-5.10.0/ext/threads/shared/shared.h.newshare 2010-10-12 10:48:36.742237001 +0200
++++ perl-5.10.0/ext/threads/shared/shared.h 2010-10-12 10:48:36.741237001 +0200
+@@ -0,0 +1,10 @@
++#ifndef _SHARED_H_
++#define _SHARED_H_
++
++#include "ppport.h"
++
++#ifndef HvNAME_get
++# define HvNAME_get(hv) (0 + ((XPVHV*)SvANY(hv))->xhv_name)
++#endif
++
++#endif
+diff -up perl-5.10.0/ext/threads/shared/shared.pm.newshare perl-5.10.0/ext/threads/shared/shared.pm
+--- perl-5.10.0/ext/threads/shared/shared.pm.newshare 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/shared.pm 2010-10-12 10:48:36.744237001 +0200
+@@ -5,7 +5,9 @@ use 5.008;
+ use strict;
+ use warnings;
+
+-our $VERSION = '1.14';
++use Scalar::Util qw(reftype refaddr blessed);
++
++our $VERSION = '1.34';
+ my $XS_VERSION = $VERSION;
+ $VERSION = eval $VERSION;
+
+@@ -41,7 +43,7 @@ sub import
+ {
+ # Exported subroutines
+ my @EXPORT = qw(share is_shared cond_wait cond_timedwait
+- cond_signal cond_broadcast);
++ cond_signal cond_broadcast shared_clone);
+ if ($threads::threads) {
+ push(@EXPORT, 'bless');
+ }
+@@ -55,6 +57,10 @@ sub import
+ }
+
+
++# Predeclarations for internal functions
++my ($make_shared);
++
++
+ ### Methods, etc. ###
+
+ sub threads::shared::tie::SPLICE
+@@ -63,6 +69,114 @@ sub threads::shared::tie::SPLICE
+ Carp::croak('Splice not implemented for shared arrays');
+ }
+
++
++# Create a thread-shared clone of a complex data structure or object
++sub shared_clone
++{
++ if (@_ != 1) {
++ require Carp;
++ Carp::croak('Usage: shared_clone(REF)');
++ }
++
++ return $make_shared->(shift, {});
++}
++
++
++### Internal Functions ###
++
++# Used by shared_clone() to recursively clone
++# a complex data structure or object
++$make_shared = sub {
++ my ($item, $cloned) = @_;
++
++ # Just return the item if:
++ # 1. Not a ref;
++ # 2. Already shared; or
++ # 3. Not running 'threads'.
++ return $item if (! ref($item) || is_shared($item) || ! $threads::threads);
++
++ # Check for previously cloned references
++ # (this takes care of circular refs as well)
++ my $addr = refaddr($item);
++ if (exists($cloned->{$addr})) {
++ # Return the already existing clone
++ return $cloned->{$addr};
++ }
++
++ # Make copies of array, hash and scalar refs and refs of refs
++ my $copy;
++ my $ref_type = reftype($item);
++
++ # Copy an array ref
++ if ($ref_type eq 'ARRAY') {
++ # Make empty shared array ref
++ $copy = &share([]);
++ # Add to clone checking hash
++ $cloned->{$addr} = $copy;
++ # Recursively copy and add contents
++ push(@$copy, map { $make_shared->($_, $cloned) } @$item);
++ }
++
++ # Copy a hash ref
++ elsif ($ref_type eq 'HASH') {
++ # Make empty shared hash ref
++ $copy = &share({});
++ # Add to clone checking hash
++ $cloned->{$addr} = $copy;
++ # Recursively copy and add contents
++ foreach my $key (keys(%{$item})) {
++ $copy->{$key} = $make_shared->($item->{$key}, $cloned);
++ }
++ }
++
++ # Copy a scalar ref
++ elsif ($ref_type eq 'SCALAR') {
++ $copy = \do{ my $scalar = $$item; };
++ share($copy);
++ # Add to clone checking hash
++ $cloned->{$addr} = $copy;
++ }
++
++ # Copy of a ref of a ref
++ elsif ($ref_type eq 'REF') {
++ # Special handling for $x = \$x
++ if ($addr == refaddr($$item)) {
++ $copy = \$copy;
++ share($copy);
++ $cloned->{$addr} = $copy;
++ } else {
++ my $tmp;
++ $copy = \$tmp;
++ share($copy);
++ # Add to clone checking hash
++ $cloned->{$addr} = $copy;
++ # Recursively copy and add contents
++ $tmp = $make_shared->($$item, $cloned);
++ }
++
++ } else {
++ require Carp;
++ Carp::croak("Unsupported ref type: ", $ref_type);
++ }
++
++ # If input item is an object, then bless the copy into the same class
++ if (my $class = blessed($item)) {
++ bless($copy, $class);
++ }
++
++ # Clone READONLY flag
++ if ($ref_type eq 'SCALAR') {
++ if (Internals::SvREADONLY($$item)) {
++ Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003);
++ }
++ }
++ if (Internals::SvREADONLY($item)) {
++ Internals::SvREADONLY($copy, 1) if ($] >= 5.008003);
++ }
++
++ return $copy;
++};
++
+ 1;
+
+ __END__
+@@ -73,7 +187,7 @@ threads::shared - Perl extension for sha
+
+ =head1 VERSION
+
+-This document describes threads::shared version 1.14
++This document describes threads::shared version 1.34
+
+ =head1 SYNOPSIS
+
+@@ -81,16 +195,28 @@ This document describes threads::shared
+ use threads::shared;
+
+ my $var :shared;
+- $var = $scalar_value;
+- $var = $shared_ref_value;
+- $var = share($simple_unshared_ref_value);
++ my %hsh :shared;
++ my @ary :shared;
+
+ my ($scalar, @array, %hash);
+ share($scalar);
+ share(@array);
+ share(%hash);
+- my $bar = &share([]);
+- $hash{bar} = &share({});
++
++ $var = $scalar_value;
++ $var = $shared_ref_value;
++ $var = shared_clone($non_shared_ref_value);
++ $var = shared_clone({'foo' => [qw/foo bar baz/]});
++
++ $hsh{'foo'} = $scalar_value;
++ $hsh{'bar'} = $shared_ref_value;
++ $hsh{'baz'} = shared_clone($non_shared_ref_value);
++ $hsh{'quz'} = shared_clone([1..3]);
++
++ $ary[0] = $scalar_value;
++ $ary[1] = $shared_ref_value;
++ $ary[2] = shared_clone($non_shared_ref_value);
++ $ary[3] = shared_clone([ {}, [] ]);
+
+ { lock(%hash); ... }
+
+@@ -108,13 +234,17 @@ This document describes threads::shared
+
+ By default, variables are private to each thread, and each newly created
+ thread gets a private copy of each existing variable. This module allows you
+-to share variables across different threads (and pseudo-forks on Win32). It is
+-used together with the L<threads> module.
++to share variables across different threads (and pseudo-forks on Win32). It
++is used together with the L<threads> module.
++
++This module supports the sharing of the following data types only: scalars
++and scalar refs, arrays and array refs, and hashes and hash refs.
+
+ =head1 EXPORT
+
+-C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>,
+-C<is_shared>
++The following functions are exported by this module: C<share>,
++C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>
++and C<cond_broadcast>
+
+ Note that if this module is imported when L<threads> has not yet been loaded,
+ then these functions all become no-ops. This makes it possible to write
+@@ -126,33 +256,60 @@ modules that will work in both threaded
+
+ =item share VARIABLE
+
+-C<share> takes a value and marks it as shared. You can share a scalar, array,
+-hash, scalar ref, array ref, or hash ref. C<share> will return the shared
+-rvalue, but always as a reference.
++C<share> takes a variable and marks it as shared:
++
++ my ($scalar, @array, %hash);
++ share($scalar);
++ share(@array);
++ share(%hash);
+
+-A variable can also be marked as shared at compile time by using the
+-C<:shared> attribute: C<my $var :shared;>.
++C<share> will return the shared rvalue, but always as a reference.
+
+-Due to problems with Perl's prototyping, if you want to share a newly created
+-reference, you need to use the C<&share([])> and C<&share({})> syntax.
++Variables can also be marked as shared at compile time by using the
++C<:shared> attribute:
+
+-The only values that can be assigned to a shared scalar are other scalar
+-values, or shared refs:
++ my ($var, %hash, @array) :shared;
+
+- my $var :shared;
+- $var = 1; # ok
+- $var = []; # error
+- $var = &share([]); # ok
+-
+-C<share> will traverse up references exactly I<one> level. C<share(\$a)> is
+-equivalent to C<share($a)>, while C<share(\\$a)> is not. This means that you
+-must create nested shared data structures by first creating individual shared
+-leaf nodes, and then adding them to a shared hash or array.
++Shared variables can only store scalars, refs of shared variables, or
++refs of shared data (discussed in next section):
+
+- my %hash :shared;
+- $hash{'meaning'} = &share([]);
+- $hash{'meaning'}[0] = &share({});
+- $hash{'meaning'}[0]{'life'} = 42;
++ my ($var, %hash, @array) :shared;
++ my $bork;
++
++ # Storing scalars
++ $var = 1;
++ $hash{'foo'} = 'bar';
++ $array[0] = 1.5;
++
++ # Storing shared refs
++ $var = \%hash;
++ $hash{'ary'} = \@array;
++ $array[1] = \$var;
++
++ # The following are errors:
++ # $var = \$bork; # ref of non-shared variable
++ # $hash{'bork'} = []; # non-shared array ref
++ # push(@array, { 'x' => 1 }); # non-shared hash ref
++
++=item shared_clone REF
++
++C<shared_clone> takes a reference, and returns a shared version of its
++argument, performing a deep copy on any non-shared elements. Any shared
++elements in the argument are used as is (i.e., they are not cloned).
++
++ my $cpy = shared_clone({'foo' => [qw/foo bar baz/]});
++
++Object status (i.e., the class an object is blessed into) is also cloned.
++
++ my $obj = {'foo' => [qw/foo bar baz/]};
++ bless($obj, 'Foo');
++ my $cpy = shared_clone($obj);
++ print(ref($cpy), "\n"); # Outputs 'Foo'
++
++For cloning empty array or hash refs, the following may also be used:
++
++ $var = &share([]); # Same as $var = shared_clone([]);
++ $var = &share({}); # Same as $var = shared_clone({});
+
+ =item is_shared VARIABLE
+
+@@ -166,20 +323,33 @@ L<refaddr()|Scalar::Util/"refaddr EXPR">
+ print("\$var is not shared\n");
+ }
+
++When used on an element of an array or hash, C<is_shared> checks if the
++specified element belongs to a shared array or hash. (It does not check
++the contents of that element.)
++
++ my %hash :shared;
++ if (is_shared(%hash)) {
++ print("\%hash is shared\n");
++ }
++
++ $hash{'elem'} = 1;
++ if (is_shared($hash{'elem'})) {
++ print("\$hash{'elem'} is in a shared hash\n");
++ }
++
+ =item lock VARIABLE
+
+-C<lock> places a lock on a variable until the lock goes out of scope. If the
+-variable is locked by another thread, the C<lock> call will block until it's
+-available. Multiple calls to C<lock> by the same thread from within
+-dynamically nested scopes are safe -- the variable will remain locked until
+-the outermost lock on the variable goes out of scope.
+-
+-Locking a container object, such as a hash or array, doesn't lock the elements
+-of that container. For example, if a thread does a C<lock(@a)>, any other
+-thread doing a C<lock($a[12])> won't block.
++C<lock> places a B<advisory> lock on a variable until the lock goes out of
++scope. If the variable is locked by another thread, the C<lock> call will
++block until it's available. Multiple calls to C<lock> by the same thread from
++within dynamically nested scopes are safe -- the variable will remain locked
++until the outermost lock on the variable goes out of scope.
+
+-C<lock()> follows references exactly I<one> level. C<lock(\$a)> is equivalent
+-to C<lock($a)>, while C<lock(\\$a)> is not.
++C<lock> follows references exactly I<one> level:
++
++ my %hash :shared;
++ my $ref = \%hash;
++ lock($ref); # This is equivalent to lock(%hash)
+
+ Note that you cannot explicitly unlock a variable; you can only wait for the
+ lock to go out of scope. This is most easily accomplished by locking the
+@@ -193,6 +363,16 @@ variable inside a block.
+ }
+ # $var is now unlocked
+
++As locks are advisory, they do not prevent data access or modification by
++another thread that does not itself attempt to obtain a lock on the variable.
++
++You cannot lock the individual elements of a container variable:
++
++ my %hash :shared;
++ $hash{'foo'} = 'bar';
++ #lock($hash{'foo'}); # Error
++ lock(%hash); # Works
++
+ If you need more fine-grained control over shared variable access, see
+ L<Thread::Semaphore>.
+
+@@ -221,7 +401,7 @@ important to check the value of the vari
+ requirement is not fulfilled. For example, to pause until a shared counter
+ drops to zero:
+
+- { lock($counter); cond_wait($count) until $counter == 0; }
++ { lock($counter); cond_wait($counter) until $counter == 0; }
+
+ =item cond_timedwait VARIABLE, ABS_TIMEOUT
+
+@@ -279,17 +459,13 @@ a C<cond_wait> on the locked variable, r
+ L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that
+ works on shared objects such that I<blessings> propagate across threads.
+
+- # Create a shared 'foo' object
+- my $foo;
+- share($foo);
+- $foo = &share({});
+- bless($foo, 'foo');
+-
+- # Create a shared 'bar' object
+- my $bar;
+- share($bar);
+- $bar = &share({});
+- bless($bar, 'bar');
++ # Create a shared 'Foo' object
++ my $foo :shared = shared_clone({});
++ bless($foo, 'Foo');
++
++ # Create a shared 'Bar' object
++ my $bar :shared = shared_clone({});
++ bless($bar, 'Bar');
+
+ # Put 'bar' inside 'foo'
+ $foo->{'bar'} = $bar;
+@@ -297,26 +473,29 @@ works on shared objects such that I<bles
+ # Rebless the objects via a thread
+ threads->create(sub {
+ # Rebless the outer object
+- bless($foo, 'yin');
++ bless($foo, 'Yin');
+
+ # Cannot directly rebless the inner object
+- #bless($foo->{'bar'}, 'yang');
++ #bless($foo->{'bar'}, 'Yang');
+
+ # Retrieve and rebless the inner object
+ my $obj = $foo->{'bar'};
+- bless($obj, 'yang');
++ bless($obj, 'Yang');
+ $foo->{'bar'} = $obj;
+
+ })->join();
+
+- print(ref($foo), "\n"); # Prints 'yin'
+- print(ref($foo->{'bar'}), "\n"); # Prints 'yang'
+- print(ref($bar), "\n"); # Also prints 'yang'
++ print(ref($foo), "\n"); # Prints 'Yin'
++ print(ref($foo->{'bar'}), "\n"); # Prints 'Yang'
++ print(ref($bar), "\n"); # Also prints 'Yang'
+
+ =head1 NOTES
+
+-threads::shared is designed to disable itself silently if threads are not
+-available. If you want access to threads, you must C<use threads> before you
++L<threads::shared> is designed to disable itself silently if threads are not
++available. This allows you to write modules and packages that can be used
++in both threaded and non-threaded applications.
++
++If you want access to threads, you must C<use threads> before you
+ C<use threads::shared>. L<threads> will emit a warning if you use it after
+ L<threads::shared>.
+
+@@ -348,19 +527,61 @@ that the contents of hash-based objects
+ mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of
+ this module) for how to create a class that supports object sharing.
+
+-Does not support C<splice> on arrays!
++Does not support C<splice> on arrays. Does not support explicitly changing
++array lengths via $#array -- use C<push> and C<pop> instead.
+
+ Taking references to the elements of shared arrays and hashes does not
+ autovivify the elements, and neither does slicing a shared array/hash over
+ non-existent indices/keys autovivify the elements.
+
+-C<share()> allows you to C<< share($hashref->{key}) >> without giving any
+-error message. But the C<< $hashref->{key} >> is B<not> shared, causing the
+-error "locking can only be used on shared values" to occur when you attempt to
+-C<< lock($hasref->{key}) >>.
++C<share()> allows you to C<< share($hashref->{key}) >> and
++C<< share($arrayref->[idx]) >> without giving any error message. But the
++C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing
++the error "lock can only be used on shared values" to occur when you attempt
++to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another
++thread.
++
++Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing
++whether or not two shared references are equivalent (e.g., when testing for
++circular references). Use L<is_shared()/"is_shared VARIABLE">, instead:
++
++ use threads;
++ use threads::shared;
++ use Scalar::Util qw(refaddr);
++
++ # If ref is shared, use threads::shared's internal ID.
++ # Otherwise, use refaddr().
++ my $addr1 = is_shared($ref1) || refaddr($ref1);
++ my $addr2 = is_shared($ref2) || refaddr($ref2);
++
++ if ($addr1 == $addr2) {
++ # The refs are equivalent
++ }
++
++L<each()|perlfunc/"each HASH"> does not work properly on shared references
++embedded in shared structures. For example:
++
++ my %foo :shared;
++ $foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'});
++
++ while (my ($key, $val) = each(%{$foo{'bar'}})) {
++ ...
++ }
++
++Either of the following will work instead:
++
++ my $ref = $foo{'bar'};
++ while (my ($key, $val) = each(%{$ref})) {
++ ...
++ }
++
++ foreach my $key (keys(%{$foo{'bar'}})) {
++ my $val = $foo{'bar'}{$key};
++ ...
++ }
+
+ View existing bug reports at, and submit any new bugs, problems, patches, etc.
+-to: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads-shared>
++to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
+
+ =head1 SEE ALSO
+
+@@ -368,7 +589,7 @@ L<threads::shared> Discussion Forum on C
+ L<http://www.cpanforum.com/dist/threads-shared>
+
+ Annotated POD for L<threads::shared>:
+-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.14/shared.pm>
++L<http://annocpan.org/~JDHEDDEN/threads-shared-1.34/shared.pm>
+
+ Source repository:
+ L<http://code.google.com/p/threads-shared/>
+@@ -385,10 +606,12 @@ L<http://lists.cpan.org/showlist.cgi?nam
+
+ Artur Bergman E<lt>sky AT crucially DOT netE<gt>
+
+-threads::shared is released under the same license as Perl.
+-
+ Documentation borrowed from the old Thread.pm.
+
+ CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>.
+
++=head1 LICENSE
++
++threads::shared is released under the same license as Perl.
++
+ =cut
+diff -up perl-5.10.0/ext/threads/shared/shared.xs.newshare perl-5.10.0/ext/threads/shared/shared.xs
+--- perl-5.10.0/ext/threads/shared/shared.xs.newshare 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/shared.xs 2010-10-12 10:49:07.921236937 +0200
+@@ -119,13 +119,12 @@
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+-#ifdef HAS_PPPORT_H
+ # define NEED_sv_2pv_flags
+ # define NEED_vnewSVpvf
+ # define NEED_warner
++# define NEED_newSVpvn_flags
+ # include "ppport.h"
+ # include "shared.h"
+-#endif
+
+ #ifdef USE_ITHREADS
+
+@@ -712,6 +711,11 @@ sharedsv_scalar_mg_get(pTHX_ SV *sv, MAG
+ ENTER_LOCK;
+ if (SvROK(ssv)) {
+ S_get_RV(aTHX_ sv, ssv);
++ /* Look ahead for refs of refs */
++ if (SvROK(SvRV(ssv))) {
++ SvROK_on(SvRV(sv));
++ S_get_RV(aTHX_ SvRV(sv), SvRV(ssv));
++ }
+ } else {
+ sv_setsv_nomg(sv, ssv);
+ }
+@@ -858,31 +862,43 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAG
+ {
+ dTHXc;
+ SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+- SV** svp;
++ SV** svp = NULL;
+
+ ENTER_LOCK;
+- if (SvTYPE(saggregate) == SVt_PVAV) {
+- assert ( mg->mg_ptr == 0 );
+- SHARED_CONTEXT;
+- svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
+- } else {
+- char *key = mg->mg_ptr;
+- STRLEN len = mg->mg_len;
+- assert ( mg->mg_ptr != 0 );
+- if (mg->mg_len == HEf_SVKEY) {
+- key = SvPV((SV *) mg->mg_ptr, len);
++ if (saggregate) { /* During global destruction, underlying
++ aggregate may no longer exist */
++ if (SvTYPE(saggregate) == SVt_PVAV) {
++ assert ( mg->mg_ptr == 0 );
++ SHARED_CONTEXT;
++ svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
++ } else {
++ char *key = mg->mg_ptr;
++ I32 len = mg->mg_len;
++ assert ( mg->mg_ptr != 0 );
++ if (mg->mg_len == HEf_SVKEY) {
++ STRLEN slen;
++ key = SvPV((SV *)mg->mg_ptr, slen);
++ len = slen;
++ if (SvUTF8((SV *)mg->mg_ptr)) {
++ len = -len;
++ }
++ }
++ SHARED_CONTEXT;
++ svp = hv_fetch((HV*) saggregate, key, len, 0);
+ }
+- SHARED_CONTEXT;
+- svp = hv_fetch((HV*) saggregate, key, len, 0);
++ CALLER_CONTEXT;
+ }
+- CALLER_CONTEXT;
+ if (svp) {
+ /* Exists in the array */
+ if (SvROK(*svp)) {
+ S_get_RV(aTHX_ sv, *svp);
++ /* Look ahead for refs of refs */
++ if (SvROK(SvRV(*svp))) {
++ SvROK_on(SvRV(sv));
++ S_get_RV(aTHX_ SvRV(sv), SvRV(*svp));
++ }
+ } else {
+- /* XXX Can this branch ever happen? DAPM */
+- /* XXX assert("no such branch"); */
++ /* $ary->[elem] or $ary->{elem} is a scalar */
+ Perl_sharedsv_associate(aTHX_ sv, *svp);
+ sv_setsv(sv, *svp);
+ }
+@@ -914,10 +930,16 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAG
+ svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
+ } else {
+ char *key = mg->mg_ptr;
+- STRLEN len = mg->mg_len;
++ I32 len = mg->mg_len;
+ assert ( mg->mg_ptr != 0 );
+- if (mg->mg_len == HEf_SVKEY)
+- key = SvPV((SV *) mg->mg_ptr, len);
++ if (mg->mg_len == HEf_SVKEY) {
++ STRLEN slen;
++ key = SvPV((SV *)mg->mg_ptr, slen);
++ len = slen;
++ if (SvUTF8((SV *)mg->mg_ptr)) {
++ len = -len;
++ }
++ }
+ SHARED_CONTEXT;
+ svp = hv_fetch((HV*) saggregate, key, len, 1);
+ }
+@@ -936,6 +958,12 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MA
+ dTHXc;
+ MAGIC *shmg;
+ SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
++
++ /* Object may not exist during global destruction */
++ if (! saggregate) {
++ return (0);
++ }
++
+ ENTER_LOCK;
+ sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
+ if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
+@@ -945,10 +973,16 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MA
+ av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
+ } else {
+ char *key = mg->mg_ptr;
+- STRLEN len = mg->mg_len;
++ I32 len = mg->mg_len;
+ assert ( mg->mg_ptr != 0 );
+- if (mg->mg_len == HEf_SVKEY)
+- key = SvPV((SV *) mg->mg_ptr, len);
++ if (mg->mg_len == HEf_SVKEY) {
++ STRLEN slen;
++ key = SvPV((SV *)mg->mg_ptr, slen);
++ len = slen;
++ if (SvUTF8((SV *)mg->mg_ptr)) {
++ len = -len;
++ }
++ }
+ SHARED_CONTEXT;
+ hv_delete((HV*) saggregate, key, len, G_DISCARD);
+ }
+@@ -1033,9 +1067,15 @@ sharedsv_array_mg_free(pTHX_ SV *sv, MAG
+ * This is called when perl is about to access an element of
+ * the array -
+ */
++#if PERL_VERSION >= 11
++int
++sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
++ SV *nsv, const char *name, I32 namlen)
++#else
+ int
+ sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
+ SV *nsv, const char *name, int namlen)
++#endif
+ {
+ MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
+ toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
+@@ -1108,6 +1148,41 @@ Perl_sharedsv_locksv(pTHX_ SV *sv)
+ }
+
+
++/* Can a shared object be destroyed?
++ * True if not a shared,
++ * or if detroying last proxy on a shared object
++ */
++#ifdef PL_destroyhook
++bool
++Perl_shared_object_destroy(pTHX_ SV *sv)
++{
++ SV *ssv;
++
++ if (SvROK(sv))
++ sv = SvRV(sv);
++ ssv = Perl_sharedsv_find(aTHX_ sv);
++ return (!ssv || (SvREFCNT(ssv) <= 1));
++}
++#endif
++
++/* veto signal despatch if we have the lock */
++
++#ifdef PL_signalhook
++
++STATIC despatch_signals_proc_t prev_signal_hook = NULL;
++
++STATIC void
++S_shared_signal_hook(pTHX) {
++ int us;
++ MUTEX_LOCK(&PL_sharedsv_lock.mutex);
++ us = (PL_sharedsv_lock.owner == aTHX);
++ MUTEX_UNLOCK(&PL_sharedsv_lock.mutex);
++ if (us)
++ return; /* try again later */
++ prev_signal_hook(aTHX);
++}
++#endif
++
+ /* Saves a space for keeping SVs wider than an interpreter. */
+
+ void
+@@ -1117,10 +1192,20 @@ Perl_sharedsv_init(pTHX)
+ /* This pair leaves us in shared context ... */
+ PL_sharedsv_space = perl_alloc();
+ perl_construct(PL_sharedsv_space);
+- CALLER_CONTEXT;
++ LEAVE; /* This balances the ENTER at the end of perl_construct. */
++ PERL_SET_CONTEXT((aTHX = caller_perl));
+ recursive_lock_init(aTHX_ &PL_sharedsv_lock);
+ PL_lockhook = &Perl_sharedsv_locksv;
+ PL_sharehook = &Perl_sharedsv_share;
++#ifdef PL_destroyhook
++ PL_destroyhook = &Perl_shared_object_destroy;
++#endif
++#ifdef PL_signalhook
++ if (!prev_signal_hook) {
++ prev_signal_hook = PL_signalhook;
++ PL_signalhook = &S_shared_signal_hook;
++ }
++#endif
+ }
+
+ #endif /* USE_ITHREADS */
+@@ -1238,8 +1323,13 @@ EXISTS(SV *obj, SV *index)
+ SHARED_EDIT;
+ exists = av_exists((AV*) sobj, SvIV(index));
+ } else {
+- STRLEN len;
+- char *key = SvPV(index,len);
++ I32 len;
++ STRLEN slen;
++ char *key = SvPVutf8(index, slen);
++ len = slen;
++ if (SvUTF8(index)) {
++ len = -len;
++ }
+ SHARED_EDIT;
+ exists = hv_exists((HV*) sobj, key, len);
+ }
+@@ -1261,9 +1351,10 @@ FIRSTKEY(SV *obj)
+ hv_iterinit((HV*) sobj);
+ entry = hv_iternext((HV*) sobj);
+ if (entry) {
++ I32 utf8 = HeKUTF8(entry);
+ key = hv_iterkey(entry,&len);
+ CALLER_CONTEXT;
+- ST(0) = sv_2mortal(newSVpv(key, len));
++ ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
+ } else {
+ CALLER_CONTEXT;
+ ST(0) = &PL_sv_undef;
+@@ -1287,9 +1378,10 @@ NEXTKEY(SV *obj, SV *oldkey)
+ SHARED_CONTEXT;
+ entry = hv_iternext((HV*) sobj);
+ if (entry) {
++ I32 utf8 = HeKUTF8(entry);
+ key = hv_iterkey(entry,&len);
+ CALLER_CONTEXT;
+- ST(0) = sv_2mortal(newSVpv(key, len));
++ ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
+ } else {
+ CALLER_CONTEXT;
+ ST(0) = &PL_sv_undef;
+@@ -1309,6 +1401,8 @@ _id(SV *myref)
+ SV *ssv;
+ CODE:
+ myref = SvRV(myref);
++ if (SvMAGICAL(myref))
++ mg_get(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/0nothread.t perl-5.10.0/ext/threads/shared/t/0nothread.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/0nothread.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/0nothread.t 2009-03-26 16:03:29.000000000 +0100
+@@ -1,18 +1,6 @@
+ use strict;
+ use warnings;
+
+-BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+- use Config;
+- if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+- exit(0);
+- }
+-}
+-
+ use Test::More (tests => 53);
+
+ ### Start of Testing ###
+@@ -70,7 +58,7 @@
+
+ ok((require threads::shared),"Require module");
+
+-if ($threads::shared::VERSION && ! exists($ENV{'PERL_CORE'})) {
++if ($threads::shared::VERSION && ! $ENV{'PERL_CORE'}) {
+ diag('Testing threads::shared ' . $threads::shared::VERSION);
+ }
+
+@@ -85,4 +73,6 @@
+ share(\%hash);
+ hash(24, 42, 'Thing');
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/av_refs.t perl-5.10.0/ext/threads/shared/t/av_refs.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/av_refs.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/av_refs.t 2009-03-26 15:43:30.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -94,4 +90,6 @@
+ my $x :shared;
+ ok(14, is_shared($x), "Check for sharing");
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/av_simple.t perl-5.10.0/ext/threads/shared/t/av_simple.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/av_simple.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/av_simple.t 2009-03-26 15:43:33.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -134,4 +130,6 @@
+
+ ok(44, is_shared(@foo), "Check for sharing");
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/blessed.t perl-5.10.0/ext/threads/shared/t/blessed.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/blessed.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/blessed.t 2009-03-26 15:43:37.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -138,4 +134,6 @@
+ ok(36, ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash");
+ ok(37, ${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents");
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/clone.t perl-5.10.0/ext/threads/shared/t/clone.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/clone.t 1970-01-01 01:00:00.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/clone.t 2009-03-26 15:43:40.000000000 +0100
+@@ -0,0 +1,175 @@
++use strict;
++use warnings;
++
++BEGIN {
++ use Config;
++ if (! $Config{'useithreads'}) {
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
++ exit(0);
++ }
++}
++
++use ExtUtils::testlib;
++
++sub ok {
++ my ($id, $ok, $name) = @_;
++
++ # You have to do it this way or VMS will get confused.
++ if ($ok) {
++ print("ok $id - $name\n");
++ } else {
++ print("not ok $id - $name\n");
++ printf("# Failed test at line %d\n", (caller)[2]);
++ }
++
++ return ($ok);
++}
++
++BEGIN {
++ $| = 1;
++ print("1..34\n"); ### Number of tests that will be run ###
++};
++
++my $test = 1;
++
++use threads;
++use threads::shared;
++ok($test++, 1, 'Loaded');
++
++### Start of Testing ###
++
++{
++ my $x = shared_clone(14);
++ ok($test++, $x == 14, 'number');
++
++ $x = shared_clone('test');
++ ok($test++, $x eq 'test', 'string');
++}
++
++{
++ my %hsh = ('foo' => 2);
++ eval {
++ my $x = shared_clone(%hsh);
++ };
++ ok($test++, $@ =~ /Usage:/, '1 arg');
++
++ threads->create(sub {})->join(); # Hide leaks, etc.
++}
++
++{
++ my $x = 'test';
++ my $foo :shared = shared_clone($x);
++ ok($test++, $foo eq 'test', 'cloned string');
++
++ $foo = shared_clone(\$x);
++ ok($test++, $$foo eq 'test', 'cloned scalar ref');
++
++ threads->create(sub {
++ ok($test++, $$foo eq 'test', 'cloned scalar ref in thread');
++ })->join();
++
++ $test++;
++}
++
++{
++ my $foo :shared;
++ $foo = shared_clone(\$foo);
++ ok($test++, ref($foo) eq 'REF', 'Circular ref typ');
++ ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref');
++
++ threads->create(sub {
++ ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread');
++
++ my ($x, $y, $z);
++ $x = \$y; $y = \$z; $z = \$x;
++ $foo = shared_clone($x);
++ })->join();
++
++ $test++;
++
++ ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo),
++ 'Cloned circular refs from thread');
++}
++
++{
++ my @ary = (qw/foo bar baz/);
++ my $ary = shared_clone(\@ary);
++
++ ok($test++, $ary->[1] eq 'bar', 'Cloned array');
++ $ary->[1] = 99;
++ ok($test++, $ary->[1] == 99, 'Clone mod');
++ ok($test++, $ary[1] eq 'bar', 'Original array');
++
++ threads->create(sub {
++ ok($test++, $ary->[1] == 99, 'Clone mod in thread');
++
++ $ary[1] = 'bork';
++ $ary->[1] = 'thread';
++ })->join();
++
++ $test++;
++
++ ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread');
++ ok($test++, $ary[1] eq 'bar', 'Original array');
++}
++
++{
++ my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]});
++ ok($test++, is_shared($hsh), 'Shared hash ref');
++ ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem');
++ ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure');
++}
++
++{
++ my $obj = \do { my $bork = 99; };
++ bless($obj, 'Bork');
++ Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);
++
++ my $bork = shared_clone($obj);
++ ok($test++, $$bork == 99, 'cloned scalar ref object');
++ ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
++ ok($test++, ref($bork) eq 'Bork', 'Object class');
++
++ threads->create(sub {
++ ok($test++, $$bork == 99, 'cloned scalar ref object in thread');
++ ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
++ ok($test++, ref($bork) eq 'Bork', 'Object class');
++ })->join();
++
++ $test += 3;
++}
++
++{
++ my $scalar = 'zip';
++
++ my $obj = {
++ 'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ],
++ 'ref' => \$scalar,
++ };
++
++ $obj->{'self'} = $obj;
++
++ bless($obj, 'Foo');
++
++ my $copy :shared;
++
++ threads->create(sub {
++ $copy = shared_clone($obj);
++
++ ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
++ ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
++ ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj');
++ })->join();
++
++ $test += 3;
++
++ ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread');
++ ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
++ ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
++ ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned');
++ ok($test++, ref($copy) eq 'Foo', 'Cloned object class');
++}
++
++exit(0);
++
++# EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/cond.t perl-5.10.0/ext/threads/shared/t/cond.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/cond.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/cond.t 2009-03-26 15:43:43.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
}
-@@ -945,10 +966,16 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MA
- av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
- } else {
- char *key = mg->mg_ptr;
-- STRLEN len = mg->mg_len;
-+ I32 len = mg->mg_len;
- assert ( mg->mg_ptr != 0 );
-- if (mg->mg_len == HEf_SVKEY)
-- key = SvPV((SV *) mg->mg_ptr, len);
-+ if (mg->mg_len == HEf_SVKEY) {
-+ STRLEN slen;
-+ key = SvPV((SV *)mg->mg_ptr, slen);
-+ len = slen;
-+ if (SvUTF8((SV *)mg->mg_ptr)) {
-+ len = -len;
-+ }
-+ }
- SHARED_CONTEXT;
- hv_delete((HV*) saggregate, key, len, G_DISCARD);
+ }
+@@ -282,4 +278,6 @@
+ $Base += 4;
+ }
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/disabled.t perl-5.10.0/ext/threads/shared/t/disabled.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/disabled.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/disabled.t 2009-03-26 15:43:48.000000000 +0100
+@@ -1,18 +1,6 @@
+ use strict;
+ use warnings;
+
+-BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+- use Config;
+- if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+- exit(0);
+- }
+-}
+-
+ use Test;
+ plan tests => 31;
+
+@@ -59,4 +47,6 @@
+ ok( "@array", "1 2 3 4" );
+ }
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/hv_refs.t perl-5.10.0/ext/threads/shared/t/hv_refs.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/hv_refs.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/hv_refs.t 2009-03-26 15:43:51.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
}
-@@ -1033,9 +1060,15 @@ sharedsv_array_mg_free(pTHX_ SV *sv, MAG
- * This is called when perl is about to access an element of
- * the array -
- */
-+#if PERL_VERSION >= 11
-+int
-+sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
-+ SV *nsv, const char *name, I32 namlen)
-+#else
- int
- sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
- SV *nsv, const char *name, int namlen)
-+#endif
- {
- MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
- toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
-@@ -1108,6 +1141,24 @@ Perl_sharedsv_locksv(pTHX_ SV *sv)
}
+@@ -110,4 +106,6 @@
+ ok(19, is_shared($foo), "Check for sharing");
+ ok(20, is_shared(%foo), "Check for sharing");
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/hv_simple.t perl-5.10.0/ext/threads/shared/t/hv_simple.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/hv_simple.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/hv_simple.t 2009-03-26 15:43:54.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
-+/* Can a shared object be destroyed?
-+ * True if not a shared,
-+ * or if detroying last proxy on a shared object
-+ */
-+#ifdef PL_destroyhook
-+bool
-+Perl_shared_object_destroy(pTHX_ SV *sv)
-+{
-+ SV *ssv;
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -77,4 +73,6 @@
+
+ ok(16, is_shared(%hash), "Check for sharing");
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/no_share.t perl-5.10.0/ext/threads/shared/t/no_share.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/no_share.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/no_share.t 2009-03-26 15:43:58.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
+
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -61,4 +57,6 @@
+
+ ok(6, ! is_shared($test), "Check for sharing");
+
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/object.t perl-5.10.0/ext/threads/shared/t/object.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/object.t 1970-01-01 01:00:00.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/object.t 2010-05-26 20:32:33.000000000 +0200
+@@ -0,0 +1,181 @@
++use strict;
++use warnings;
++
++BEGIN {
++ use Config;
++ if (! $Config{'useithreads'}) {
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
++ exit(0);
++ }
++ if ($] < 5.010) {
++ print("1..0 # SKIP Needs Perl 5.10.0 or later\n");
++ exit(0);
++ }
++}
++
++use ExtUtils::testlib;
++
++BEGIN {
++ $| = 1;
++ print("1..28\n"); ### Number of tests that will be run ###
++};
++
++use threads;
++use threads::shared;
++
++my $TEST;
++BEGIN {
++ share($TEST);
++ $TEST = 1;
++}
++
++sub ok {
++ my ($ok, $name) = @_;
++
++ lock($TEST);
++ my $id = $TEST++;
++
++ # You have to do it this way or VMS will get confused.
++ if ($ok) {
++ print("ok $id - $name\n");
++ } else {
++ print("not ok $id - $name\n");
++ printf("# Failed test at line %d\n", (caller)[2]);
++ }
++
++ return ($ok);
++}
++
++ok(1, 'Loaded');
++
++### Start of Testing ###
++
++{ package Jar;
++ my @jar :shared;
++
++ sub new
++ {
++ bless(&threads::shared::share({}), shift);
++ }
++
++ sub store
++ {
++ my ($self, $cookie) = @_;
++ push(@jar, $cookie);
++ return $jar[-1]; # Results in destruction of proxy object
++ }
++
++ sub peek
++ {
++ return $jar[-1];
++ }
++
++ sub fetch
++ {
++ pop(@jar);
++ }
++}
++
++{ package Cookie;
++
++ sub new
++ {
++ my $self = bless(&threads::shared::share({}), shift);
++ $self->{'type'} = shift;
++ return $self;
++ }
++
++ sub DESTROY
++ {
++ delete(shift->{'type'});
++ }
++}
++
++my $C1 = 'chocolate chip';
++my $C2 = 'oatmeal raisin';
++my $C3 = 'vanilla wafer';
++
++my $cookie = Cookie->new($C1);
++ok($cookie->{'type'} eq $C1, 'Have cookie');
++
++my $jar = Jar->new();
++$jar->store($cookie);
++
++ok($cookie->{'type'} eq $C1, 'Still have cookie');
++ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
++ok($cookie->{'type'} eq $C1, 'Still have cookie');
++
++threads->create(sub {
++ ok($cookie->{'type'} eq $C1, 'Have cookie in thread');
++ ok($jar->peek()->{'type'} eq $C1, 'Still have cookie in thread');
++ ok($cookie->{'type'} eq $C1, 'Still have cookie in thread');
++
++ $jar->store(Cookie->new($C2));
++ ok($jar->peek()->{'type'} eq $C2, 'Added cookie in thread');
++})->join();
++
++ok($cookie->{'type'} eq $C1, 'Still have original cookie after thread');
++ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
++
++$cookie = $jar->fetch();
++ok($cookie->{'type'} eq $C2, 'Fetched cookie from jar');
++ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
++
++$cookie = $jar->fetch();
++ok($cookie->{'type'} eq $C1, 'Fetched cookie from jar');
++undef($cookie);
+
-+ if (SvROK(sv))
-+ sv = SvRV(sv);
-+ ssv = Perl_sharedsv_find(aTHX_ sv);
-+ return (!ssv || (SvREFCNT(ssv) <= 1));
++share($cookie);
++$cookie = $jar->store(Cookie->new($C3));
++ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
++ok($cookie->{'type'} eq $C3, 'Have cookie');
++
++threads->create(sub {
++ ok($cookie->{'type'} eq $C3, 'Have cookie in thread');
++ $cookie = Cookie->new($C1);
++ ok($cookie->{'type'} eq $C1, 'Change cookie in thread');
++ ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
++})->join();
++
++ok($cookie->{'type'} eq $C1, 'Have changed cookie after thread');
++ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
++undef($cookie);
++ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
++$cookie = $jar->fetch();
++ok($cookie->{'type'} eq $C3, 'Fetched cookie from jar');
++
++{ package Foo;
++
++ my $ID = 1;
++ threads::shared::share($ID);
++
++ sub new
++ {
++ # Anonymous scalar with an internal ID
++ my $obj = \do{ my $scalar = $ID++; };
++ threads::shared::share($obj); # Make it shared
++ return (bless($obj, 'Foo')); # Make it an object
++ }
+}
-+#endif
+
++my $obj :shared;
++$obj = Foo->new();
++ok($$obj == 1, "Main: Object ID $$obj");
++
++threads->create( sub {
++ ok($$obj == 1, "Thread: Object ID $$obj");
++
++ $$obj = 10;
++ ok($$obj == 10, "Thread: Changed object ID $$obj");
+
- /* Saves a space for keeping SVs wider than an interpreter. */
++ $obj = Foo->new();
++ ok($$obj == 2, "Thread: New object ID $$obj");
++ } )->join();
++
++# Fixed by commit bb1bc619ea68d9703fbd3fe5bc65ae000f90151f
++my $todo = ($] <= 5.013001) ? " # TODO - should be 2" : "";
++ok($$obj == 2, "Main: New object ID $$obj".$todo);
++
++exit(0);
++
++# EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/pod.t perl-5.10.0/ext/threads/shared/t/pod.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/pod.t 1970-01-01 01:00:00.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/pod.t 2010-10-08 18:53:08.000000000 +0200
+@@ -0,0 +1,59 @@
++use strict;
++use warnings;
++
++use Test::More;
++if ($ENV{RUN_MAINTAINER_TESTS}) {
++ plan 'tests' => 3;
++} else {
++ plan 'skip_all' => 'Module maintainer tests';
++}
++
++SKIP: {
++ if (! eval 'use Test::Pod 1.26; 1') {
++ skip('Test::Pod 1.26 required for testing POD', 1);
++ }
++
++ pod_file_ok('lib/threads/shared.pm');
++}
++
++SKIP: {
++ if (! eval 'use Test::Pod::Coverage 1.08; 1') {
++ skip('Test::Pod::Coverage 1.08 required for testing POD coverage', 1);
++ }
++
++ pod_coverage_ok('threads::shared',
++ {
++ 'trustme' => [
++ ],
++ 'private' => [
++ qr/^import$/,
++ ]
++ }
++ );
++}
++
++SKIP: {
++ if (! eval 'use Test::Spelling; 1') {
++ skip('Test::Spelling required for testing POD spelling', 1);
++ }
++ if (system('aspell help >/dev/null 2>&1')) {
++ skip("'aspell' required for testing POD spelling", 1);
++ }
++ set_spell_cmd('aspell list --lang=en');
++ add_stopwords(<DATA>);
++ pod_file_spelling_ok('lib/threads/shared.pm', 'shared.pm spelling');
++ unlink("/home/$ENV{'USER'}/en.prepl", "/home/$ENV{'USER'}/en.pws");
++}
++
++exit(0);
++
++__DATA__
++
++Hedden
++
++cpan
++CONDVAR
++LOCKVAR
++refcnt
++
++__END__
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/shared_attr.t perl-5.10.0/ext/threads/shared/t/shared_attr.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/shared_attr.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/shared_attr.t 2009-03-26 15:44:09.000000000 +0100
+@@ -2,13 +2,9 @@
+ use warnings;
- void
-@@ -1121,6 +1172,9 @@ Perl_sharedsv_init(pTHX)
- recursive_lock_init(aTHX_ &PL_sharedsv_lock);
- PL_lockhook = &Perl_sharedsv_locksv;
- PL_sharehook = &Perl_sharedsv_share;
-+#ifdef PL_destroyhook
-+ PL_destroyhook = &Perl_shared_object_destroy;
-+#endif
+ BEGIN {
+- if ($ENV{'PERL_CORE'}){
+- chdir 't';
+- unshift @INC, '../lib';
+- }
+ use Config;
+ if (! $Config{'useithreads'}) {
+- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ }
+@@ -78,4 +74,6 @@
+ ok($test_count++, $str1 eq $str2, 'contents');
}
- #endif /* USE_ITHREADS */
-@@ -1238,8 +1292,13 @@ EXISTS(SV *obj, SV *index)
- SHARED_EDIT;
- exists = av_exists((AV*) sobj, SvIV(index));
- } else {
-- STRLEN len;
-- char *key = SvPV(index,len);
-+ I32 len;
-+ STRLEN slen;
-+ char *key = SvPVutf8(index, slen);
-+ len = slen;
-+ if (SvUTF8(index)) {
-+ len = -len;
-+ }
- SHARED_EDIT;
- exists = hv_exists((HV*) sobj, key, len);
- }
-@@ -1261,9 +1320,10 @@ FIRSTKEY(SV *obj)
- hv_iterinit((HV*) sobj);
- entry = hv_iternext((HV*) sobj);
- if (entry) {
-+ I32 utf8 = HeKUTF8(entry);
- key = hv_iterkey(entry,&len);
- CALLER_CONTEXT;
-- ST(0) = sv_2mortal(newSVpv(key, len));
-+ ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
- } else {
- CALLER_CONTEXT;
- ST(0) = &PL_sv_undef;
-@@ -1287,9 +1347,10 @@ NEXTKEY(SV *obj, SV *oldkey)
- SHARED_CONTEXT;
- entry = hv_iternext((HV*) sobj);
- if (entry) {
-+ I32 utf8 = HeKUTF8(entry);
- key = hv_iterkey(entry,&len);
- CALLER_CONTEXT;
-- ST(0) = sv_2mortal(newSVpv(key, len));
-+ ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
- } else {
- CALLER_CONTEXT;
- ST(0) = &PL_sv_undef;
-@@ -1309,6 +1370,8 @@ _id(SV *myref)
- SV *ssv;
- CODE:
- myref = SvRV(myref);
-+ if (SvMAGICAL(myref))
-+ mg_get(myref);
- if (SvROK(myref))
- myref = SvRV(myref);
- ssv = Perl_sharedsv_find(aTHX_ myref);
-diff -up perl-5.10.0/ext/threads/shared/t/0nothread.t.shared perl-5.10.0/ext/threads/shared/t/0nothread.t
---- perl-5.10.0/ext/threads/shared/t/0nothread.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/0nothread.t 2010-09-07 08:35:16.189630916 +0200
-@@ -1,18 +1,6 @@
- use strict;
++exit(0);
++
+ # EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/stress.t perl-5.10.0/ext/threads/shared/t/stress.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/stress.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/stress.t 2009-08-11 16:05:41.000000000 +0200
+@@ -2,17 +2,13 @@
use warnings;
--BEGIN {
+ BEGIN {
- if ($ENV{'PERL_CORE'}){
- chdir 't';
- unshift @INC, '../lib';
- }
-- use Config;
-- if (! $Config{'useithreads'}) {
+ use Config;
+ if (! $Config{'useithreads'}) {
- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-- exit(0);
-- }
--}
--
- use Test::More (tests => 53);
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+ if ($^O eq 'hpux' && $Config{osvers} <= 10.20) {
+- print("1..0 # Skip: Broken under HP-UX 10.20\n");
++ print("1..0 # SKIP Broken under HP-UX 10.20\n");
+ exit(0);
+ }
+ }
+@@ -38,16 +34,21 @@
+ {
+ my $cnt = 50;
- ### Start of Testing ###
-@@ -70,7 +58,7 @@ sub array
+- my $TIMEOUT = 30;
++ my $TIMEOUT = 60;
- ok((require threads::shared),"Require module");
+ my $mutex = 1;
+ share($mutex);
--if ($threads::shared::VERSION && ! exists($ENV{'PERL_CORE'})) {
-+if ($threads::shared::VERSION && ! $ENV{'PERL_CORE'}) {
- diag('Testing threads::shared ' . $threads::shared::VERSION);
- }
++ my $warning;
++ $SIG{__WARN__} = sub { $warning = shift; };
++
+ my @threads;
+- for (1..$cnt) {
++
++ for (reverse(1..$cnt)) {
+ $threads[$_] = threads->create(sub {
+ my $tnum = shift;
+ my $timeout = time() + $TIMEOUT;
++ threads->yield();
-@@ -85,4 +73,6 @@ array(24, 42, 'Thing');
- share(\%hash);
- hash(24, 42, 'Thing');
+ # Randomize the amount of work the thread does
+ my $sum;
+@@ -74,47 +75,75 @@
+ cond_broadcast($mutex);
+ return ('okay');
+ }, $_);
++
++ # Handle thread creation failures
++ if ($warning) {
++ my $printit = 1;
++ if ($warning =~ /returned 11/) {
++ $warning = "Thread creation failed due to 'No more processes'\n";
++ $printit = (! $ENV{'PERL_CORE'});
++ } elsif ($warning =~ /returned 12/) {
++ $warning = "Thread creation failed due to 'No more memory'\n";
++ $printit = (! $ENV{'PERL_CORE'});
++ }
++ print(STDERR "# Warning: $warning") if ($printit);
++ lock($mutex);
++ $mutex = $_ + 1;
++ last;
++ }
+ }
-+exit(0);
+ # Gather thread results
+- my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0);
++ my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0, 0);
+ for (1..$cnt) {
+- my $rc = $threads[$_]->join();
+- if (! $rc) {
++ if (! $threads[$_]) {
+ $failures++;
+- } elsif ($rc =~ /^timed out/) {
+- $timeouts++;
+- } elsif ($rc eq 'okay') {
+- $okay++;
+ } else {
+- $unknown++;
+- print("# Unknown error: $rc\n");
++ my $rc = $threads[$_]->join();
++ if (! $rc) {
++ $failures++;
++ } elsif ($rc =~ /^timed out/) {
++ $timeouts++;
++ } elsif ($rc eq 'okay') {
++ $okay++;
++ } else {
++ $unknown++;
++ print(STDERR "# Unknown error: $rc\n");
++ }
+ }
+ }
+
+- if ($failures || $unknown || (($okay + $timeouts) != $cnt)) {
+- print('not ok 1');
+- my $too_few = $cnt - ($okay + $failures + $timeouts + $unknown);
+- print(" - $too_few too few threads reported") if $too_few;
+- print(" - $failures threads failed") if $failures;
+- print(" - $unknown unknown errors") if $unknown;
+- print(" - $timeouts threads timed out") if $timeouts;
+- print("\n");
++ if ($failures) {
++ my $only = $cnt - $failures;
++ print(STDERR "# Warning: Intended to use $cnt threads, but could only muster $only\n");
++ $cnt -= $failures;
++ }
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/av_refs.t.shared perl-5.10.0/ext/threads/shared/t/av_refs.t
---- perl-5.10.0/ext/threads/shared/t/av_refs.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/av_refs.t 2010-09-07 08:35:16.191630997 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
++ if ($unknown || (($okay + $timeouts) != $cnt)) {
++ print("not ok 1\n");
++ my $too_few = $cnt - ($okay + $timeouts + $unknown);
++ print(STDERR "# Test failed:\n");
++ print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
++ print(STDERR "#\t$unknown unknown errors\n") if $unknown;
++ print(STDERR "#\t$timeouts threads timed out\n") if $timeouts;
+
+ } elsif ($timeouts) {
+ # Frequently fails under MSWin32 due to deadlocking bug in Windows
+ # hence test is TODO under MSWin32
+ # http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
+ # http://support.microsoft.com/kb/175332
+- print('not ok 1');
+- print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
+- print(" - $timeouts threads timed out\n");
++ if ($^O eq 'MSWin32') {
++ print("not ok 1 # TODO - not reliable under MSWin32\n")
++ } else {
++ print("not ok 1\n");
++ print(STDERR "# Test failed: $timeouts threads timed out\n");
++ }
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
+ } else {
+- print('ok 1');
+- print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
+- print("\n");
++ print("ok 1\n");
}
}
-@@ -94,4 +90,6 @@ ok(13, is_shared(@av), "Check for sharin
- my $x :shared;
- ok(14, is_shared($x), "Check for sharing");
+exit(0);
+
# EOF
-diff -up perl-5.10.0/ext/threads/shared/t/av_simple.t.shared perl-5.10.0/ext/threads/shared/t/av_simple.t
---- perl-5.10.0/ext/threads/shared/t/av_simple.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/av_simple.t 2010-09-07 08:35:16.192631387 +0200
-@@ -2,13 +2,9 @@ use strict;
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/sv_refs.t perl-5.10.0/ext/threads/shared/t/sv_refs.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/sv_refs.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/sv_refs.t 2009-03-26 15:44:17.000000000 +0100
+@@ -2,13 +2,9 @@
use warnings;
BEGIN {
@@ -791,17 +8732,52 @@ diff -up perl-5.10.0/ext/threads/shared/t/av_simple.t.shared perl-5.10.0/ext/thr
exit(0);
}
}
-@@ -134,4 +130,6 @@ ok(37, !defined delete($foo[0]), "Check
+@@ -31,7 +27,7 @@
- ok(44, is_shared(@foo), "Check for sharing");
+ BEGIN {
+ $| = 1;
+- print("1..11\n"); ### Number of tests that will be run ###
++ print("1..21\n"); ### Number of tests that will be run ###
+ };
+
+ use threads;
+@@ -74,4 +70,32 @@
+ ok(11, is_shared($foo), "Check for sharing");
+
++{
++ # Circular references with 3 shared scalars
++ my $x : shared;
++ my $y : shared;
++ my $z : shared;
++
++ $x = \$y;
++ $y = \$z;
++ $z = \$x;
++ ok(12, ref($x) eq 'REF', '$x ref type');
++ ok(13, ref($y) eq 'REF', '$y ref type');
++ ok(14, ref($z) eq 'REF', '$z ref type');
++
++ my @q :shared = ($x);
++ ok(15, ref($q[0]) eq 'REF', '$q[0] ref type');
++
++ my $w = $q[0];
++ ok(16, ref($w) eq 'REF', '$w ref type');
++ ok(17, ref($$w) eq 'REF', '$$w ref type');
++ ok(18, ref($$$w) eq 'REF', '$$$w ref type');
++ ok(19, ref($$$$w) eq 'REF', '$$$$w ref type');
++
++ ok(20, is_shared($x) == is_shared($w), '_id($x) == _id($w)');
++ ok(21, is_shared($w) == is_shared($$$$w), '_id($w) == _id($$$$w)');
++}
++
+exit(0);
+
# EOF
-diff -up perl-5.10.0/ext/threads/shared/t/blessed.t.shared perl-5.10.0/ext/threads/shared/t/blessed.t
---- perl-5.10.0/ext/threads/shared/t/blessed.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/blessed.t 2010-09-07 08:35:16.193631358 +0200
-@@ -2,13 +2,9 @@ use strict;
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/sv_simple.t perl-5.10.0/ext/threads/shared/t/sv_simple.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/sv_simple.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/sv_simple.t 2009-03-26 15:44:22.000000000 +0100
+@@ -2,13 +2,9 @@
use warnings;
BEGIN {
@@ -816,738 +8792,1249 @@ diff -up perl-5.10.0/ext/threads/shared/t/blessed.t.shared perl-5.10.0/ext/threa
exit(0);
}
}
-@@ -138,4 +134,6 @@ ok(35, ref($$hobj{'array'}) eq 'gnay', "
- ok(36, ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash");
- ok(37, ${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents");
+@@ -63,4 +59,6 @@
+
+ ok(11, is_shared($test), "Check for sharing");
+exit(0);
+
# EOF
-diff -up perl-5.10.0/ext/threads/shared/t/clone.t.shared perl-5.10.0/ext/threads/shared/t/clone.t
---- perl-5.10.0/ext/threads/shared/t/clone.t.shared 2010-09-07 08:35:16.194632098 +0200
-+++ perl-5.10.0/ext/threads/shared/t/clone.t 2010-09-07 08:35:16.194632098 +0200
-@@ -0,0 +1,175 @@
-+use strict;
-+use warnings;
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/test.pl perl-5.10.0/ext/threads/shared/t/test.pl
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/test.pl 1970-01-01 01:00:00.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/test.pl 2010-10-08 18:48:24.000000000 +0200
+@@ -0,0 +1,1128 @@
++#
++# t/test.pl - most of Test::More functionality without the fuss, plus
++# has mappings native_to_latin1 and latin1_to_native so that fewer tests
++# on non ASCII-ish platforms need to be skipped
++
++
++# NOTE:
++#
++# Increment ($x++) has a certain amount of cleverness for things like
++#
++# $x = 'zz';
++# $x++; # $x eq 'aaa';
++#
++# stands more chance of breaking than just a simple
++#
++# $x = $x + 1
++#
++# In this file, we use the latter "Baby Perl" approach, and increment
++# will be worked over by t/op/inc.t
++
++$Level = 1;
++my $test = 1;
++my $planned;
++my $noplan;
++my $Perl; # Safer version of $^X set by which_perl()
+
-+BEGIN {
-+ use Config;
-+ if (! $Config{'useithreads'}) {
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
-+ exit(0);
++$TODO = 0;
++$NO_ENDING = 0;
++
++# Use this instead of print to avoid interference while testing globals.
++sub _print {
++ local($\, $", $,) = (undef, ' ', '');
++ print STDOUT @_;
++}
++
++sub _print_stderr {
++ local($\, $", $,) = (undef, ' ', '');
++ print STDERR @_;
++}
++
++sub plan {
++ my $n;
++ if (@_ == 1) {
++ $n = shift;
++ if ($n eq 'no_plan') {
++ undef $n;
++ $noplan = 1;
++ }
++ } else {
++ my %plan = @_;
++ $n = $plan{tests};
+ }
++ _print "1..$n\n" unless $noplan;
++ $planned = $n;
+}
+
-+use ExtUtils::testlib;
+
-+sub ok {
-+ my ($id, $ok, $name) = @_;
++# Set the plan at the end. See Test::More::done_testing.
++sub done_testing {
++ my $n = $test - 1;
++ $n = shift if @_;
+
-+ # You have to do it this way or VMS will get confused.
-+ if ($ok) {
-+ print("ok $id - $name\n");
-+ } else {
-+ print("not ok $id - $name\n");
-+ printf("# Failed test at line %d\n", (caller)[2]);
++ _print "1..$n\n";
++ $planned = $n;
++}
++
++
++END {
++ my $ran = $test - 1;
++ if (!$NO_ENDING) {
++ if (defined $planned && $planned != $ran) {
++ _print_stderr
++ "# Looks like you planned $planned tests but ran $ran.\n";
++ } elsif ($noplan) {
++ _print "1..$ran\n";
++ }
+ }
++}
+
-+ return ($ok);
++sub _diag {
++ return unless @_;
++ my @mess = _comment(@_);
++ $TODO ? _print(@mess) : _print_stderr(@mess);
+}
+
-+BEGIN {
-+ $| = 1;
-+ print("1..34\n"); ### Number of tests that will be run ###
-+};
++# Use this instead of "print STDERR" when outputing failure diagnostic
++# messages
++sub diag {
++ _diag(@_);
++}
+
-+my $test = 1;
++# Use this instead of "print" when outputing informational messages
++sub note {
++ return unless @_;
++ _print( _comment(@_) );
++}
+
-+use threads;
-+use threads::shared;
-+ok($test++, 1, 'Loaded');
++sub _comment {
++ return map { /^#/ ? "$_\n" : "# $_\n" }
++ map { split /\n/ } @_;
++}
+
-+### Start of Testing ###
++sub skip_all {
++ if (@_) {
++ _print "1..0 # Skip @_\n";
++ } else {
++ _print "1..0\n";
++ }
++ exit(0);
++}
+
-+{
-+ my $x = shared_clone(14);
-+ ok($test++, $x == 14, 'number');
++sub _ok {
++ my ($pass, $where, $name, @mess) = @_;
++ # Do not try to microoptimize by factoring out the "not ".
++ # VMS will avenge.
++ my $out;
++ if ($name) {
++ # escape out '#' or it will interfere with '# skip' and such
++ $name =~ s/#/\\#/g;
++ $out = $pass ? "ok $test - $name" : "not ok $test - $name";
++ } else {
++ $out = $pass ? "ok $test" : "not ok $test";
++ }
+
-+ $x = shared_clone('test');
-+ ok($test++, $x eq 'test', 'string');
++ $out = $out . " # TODO $TODO" if $TODO;
++ _print "$out\n";
++
++ unless ($pass) {
++ _diag "# Failed $where\n";
++ }
++
++ # Ensure that the message is properly escaped.
++ _diag @mess;
++
++ $test = $test + 1; # don't use ++
++
++ return $pass;
+}
+
-+{
-+ my %hsh = ('foo' => 2);
-+ eval {
-+ my $x = shared_clone(%hsh);
-+ };
-+ ok($test++, $@ =~ /Usage:/, '1 arg');
++sub _where {
++ my @caller = caller($Level);
++ return "at $caller[1] line $caller[2]";
++}
+
-+ threads->create(sub {})->join(); # Hide leaks, etc.
++# DON'T use this for matches. Use like() instead.
++sub ok ($@) {
++ my ($pass, $name, @mess) = @_;
++ _ok($pass, _where(), $name, @mess);
+}
+
-+{
-+ my $x = 'test';
-+ my $foo :shared = shared_clone($x);
-+ ok($test++, $foo eq 'test', 'cloned string');
++sub _q {
++ my $x = shift;
++ return 'undef' unless defined $x;
++ my $q = $x;
++ $q =~ s/\\/\\\\/g;
++ $q =~ s/'/\\'/g;
++ return "'$q'";
++}
+
-+ $foo = shared_clone(\$x);
-+ ok($test++, $$foo eq 'test', 'cloned scalar ref');
++sub _qq {
++ my $x = shift;
++ return defined $x ? '"' . display ($x) . '"' : 'undef';
++};
+
-+ threads->create(sub {
-+ ok($test++, $$foo eq 'test', 'cloned scalar ref in thread');
-+ })->join();
++# keys are the codes \n etc map to, values are 2 char strings such as \n
++my %backslash_escape;
++foreach my $x (split //, 'nrtfa\\\'"') {
++ $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
++}
++# A way to display scalars containing control characters and Unicode.
++# Trying to avoid setting $_, or relying on local $_ to work.
++sub display {
++ my @result;
++ foreach my $x (@_) {
++ if (defined $x and not ref $x) {
++ my $y = '';
++ foreach my $c (unpack("U*", $x)) {
++ if ($c > 255) {
++ $y = $y . sprintf "\\x{%x}", $c;
++ } elsif ($backslash_escape{$c}) {
++ $y = $y . $backslash_escape{$c};
++ } else {
++ my $z = chr $c; # Maybe we can get away with a literal...
++ if ($z =~ /[[:^print:]]/) {
++
++ # Use octal for characters traditionally expressed as
++ # such: the low controls
++ if ($c <= 037) {
++ $z = sprintf "\\%03o", $c;
++ } else {
++ $z = sprintf "\\x{%x}", $c;
++ }
++ }
++ $y = $y . $z;
++ }
++ }
++ $x = $y;
++ }
++ return $x unless wantarray;
++ push @result, $x;
++ }
++ return @result;
++}
+
-+ $test++;
++sub is ($$@) {
++ my ($got, $expected, $name, @mess) = @_;
++
++ my $pass;
++ if( !defined $got || !defined $expected ) {
++ # undef only matches undef
++ $pass = !defined $got && !defined $expected;
++ }
++ else {
++ $pass = $got eq $expected;
++ }
++
++ unless ($pass) {
++ unshift(@mess, "# got "._qq($got)."\n",
++ "# expected "._qq($expected)."\n");
++ }
++ _ok($pass, _where(), $name, @mess);
+}
+
-+{
-+ my $foo :shared;
-+ $foo = shared_clone(\$foo);
-+ ok($test++, ref($foo) eq 'REF', 'Circular ref typ');
-+ ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref');
++sub isnt ($$@) {
++ my ($got, $isnt, $name, @mess) = @_;
+
-+ threads->create(sub {
-+ ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread');
++ my $pass;
++ if( !defined $got || !defined $isnt ) {
++ # undef only matches undef
++ $pass = defined $got || defined $isnt;
++ }
++ else {
++ $pass = $got ne $isnt;
++ }
+
-+ my ($x, $y, $z);
-+ $x = \$y; $y = \$z; $z = \$x;
-+ $foo = shared_clone($x);
-+ })->join();
++ unless( $pass ) {
++ unshift(@mess, "# it should not be "._qq($got)."\n",
++ "# but it is.\n");
++ }
++ _ok($pass, _where(), $name, @mess);
++}
+
-+ $test++;
++sub cmp_ok ($$$@) {
++ my($got, $type, $expected, $name, @mess) = @_;
+
-+ ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo),
-+ 'Cloned circular refs from thread');
++ my $pass;
++ {
++ local $^W = 0;
++ local($@,$!); # don't interfere with $@
++ # eval() sometimes resets $!
++ $pass = eval "\$got $type \$expected";
++ }
++ unless ($pass) {
++ # It seems Irix long doubles can have 2147483648 and 2147483648
++ # that stringify to the same thing but are acutally numerically
++ # different. Display the numbers if $type isn't a string operator,
++ # and the numbers are stringwise the same.
++ # (all string operators have alphabetic names, so tr/a-z// is true)
++ # This will also show numbers for some uneeded cases, but will
++ # definately be helpful for things such as == and <= that fail
++ if ($got eq $expected and $type !~ tr/a-z//) {
++ unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
++ }
++ unshift(@mess, "# got "._qq($got)."\n",
++ "# expected $type "._qq($expected)."\n");
++ }
++ _ok($pass, _where(), $name, @mess);
+}
+
-+{
-+ my @ary = (qw/foo bar baz/);
-+ my $ary = shared_clone(\@ary);
++# Check that $got is within $range of $expected
++# if $range is 0, then check it's exact
++# else if $expected is 0, then $range is an absolute value
++# otherwise $range is a fractional error.
++# Here $range must be numeric, >= 0
++# Non numeric ranges might be a useful future extension. (eg %)
++sub within ($$$@) {
++ my ($got, $expected, $range, $name, @mess) = @_;
++ my $pass;
++ if (!defined $got or !defined $expected or !defined $range) {
++ # This is a fail, but doesn't need extra diagnostics
++ } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
++ # This is a fail
++ unshift @mess, "# got, expected and range must be numeric\n";
++ } elsif ($range < 0) {
++ # This is also a fail
++ unshift @mess, "# range must not be negative\n";
++ } elsif ($range == 0) {
++ # Within 0 is ==
++ $pass = $got == $expected;
++ } elsif ($expected == 0) {
++ # If expected is 0, treat range as absolute
++ $pass = ($got <= $range) && ($got >= - $range);
++ } else {
++ my $diff = $got - $expected;
++ $pass = abs ($diff / $expected) < $range;
++ }
++ unless ($pass) {
++ if ($got eq $expected) {
++ unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
++ }
++ unshift at mess, "# got "._qq($got)."\n",
++ "# expected "._qq($expected)." (within "._qq($range).")\n";
++ }
++ _ok($pass, _where(), $name, @mess);
++}
+
-+ ok($test++, $ary->[1] eq 'bar', 'Cloned array');
-+ $ary->[1] = 99;
-+ ok($test++, $ary->[1] == 99, 'Clone mod');
-+ ok($test++, $ary[1] eq 'bar', 'Original array');
++# Note: this isn't quite as fancy as Test::More::like().
+
-+ threads->create(sub {
-+ ok($test++, $ary->[1] == 99, 'Clone mod in thread');
++sub like ($$@) { like_yn (0, at _) }; # 0 for -
++sub unlike ($$@) { like_yn (1, at _) }; # 1 for un-
+
-+ $ary[1] = 'bork';
-+ $ary->[1] = 'thread';
-+ })->join();
++sub like_yn ($$$@) {
++ my ($flip, $got, $expected, $name, @mess) = @_;
++ my $pass;
++ $pass = $got =~ /$expected/ if !$flip;
++ $pass = $got !~ /$expected/ if $flip;
++ unless ($pass) {
++ unshift(@mess, "# got '$got'\n",
++ $flip
++ ? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
++ }
++ local $Level = $Level + 1;
++ _ok($pass, _where(), $name, @mess);
++}
+
-+ $test++;
++sub pass {
++ _ok(1, '', @_);
++}
+
-+ ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread');
-+ ok($test++, $ary[1] eq 'bar', 'Original array');
++sub fail {
++ _ok(0, _where(), @_);
+}
+
-+{
-+ my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]});
-+ ok($test++, is_shared($hsh), 'Shared hash ref');
-+ ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem');
-+ ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure');
++sub curr_test {
++ $test = shift if @_;
++ return $test;
+}
+
-+{
-+ my $obj = \do { my $bork = 99; };
-+ bless($obj, 'Bork');
-+ Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);
++sub next_test {
++ my $retval = $test;
++ $test = $test + 1; # don't use ++
++ $retval;
++}
+
-+ my $bork = shared_clone($obj);
-+ ok($test++, $$bork == 99, 'cloned scalar ref object');
-+ ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
-+ ok($test++, ref($bork) eq 'Bork', 'Object class');
++# Note: can't pass multipart messages since we try to
++# be compatible with Test::More::skip().
++sub skip {
++ my $why = shift;
++ my $n = @_ ? shift : 1;
++ for (1..$n) {
++ _print "ok $test # skip $why\n";
++ $test = $test + 1;
++ }
++ local $^W = 0;
++ last SKIP;
++}
+
-+ threads->create(sub {
-+ ok($test++, $$bork == 99, 'cloned scalar ref object in thread');
-+ ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
-+ ok($test++, ref($bork) eq 'Bork', 'Object class');
-+ })->join();
++sub todo_skip {
++ my $why = shift;
++ my $n = @_ ? shift : 1;
+
-+ $test += 3;
++ for (1..$n) {
++ _print "not ok $test # TODO & SKIP $why\n";
++ $test = $test + 1;
++ }
++ local $^W = 0;
++ last TODO;
+}
+
-+{
-+ my $scalar = 'zip';
++sub eq_array {
++ my ($ra, $rb) = @_;
++ return 0 unless $#$ra == $#$rb;
++ for my $i (0..$#$ra) {
++ next if !defined $ra->[$i] && !defined $rb->[$i];
++ return 0 if !defined $ra->[$i];
++ return 0 if !defined $rb->[$i];
++ return 0 unless $ra->[$i] eq $rb->[$i];
++ }
++ return 1;
++}
+
-+ my $obj = {
-+ 'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ],
-+ 'ref' => \$scalar,
-+ };
++sub eq_hash {
++ my ($orig, $suspect) = @_;
++ my $fail;
++ while (my ($key, $value) = each %$suspect) {
++ # Force a hash recompute if this perl's internals can cache the hash key.
++ $key = "" . $key;
++ if (exists $orig->{$key}) {
++ if ($orig->{$key} ne $value) {
++ _print "# key ", _qq($key), " was ", _qq($orig->{$key}),
++ " now ", _qq($value), "\n";
++ $fail = 1;
++ }
++ } else {
++ _print "# key ", _qq($key), " is ", _qq($value),
++ ", not in original.\n";
++ $fail = 1;
++ }
++ }
++ foreach (keys %$orig) {
++ # Force a hash recompute if this perl's internals can cache the hash key.
++ $_ = "" . $_;
++ next if (exists $suspect->{$_});
++ _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
++ $fail = 1;
++ }
++ !$fail;
++}
+
-+ $obj->{'self'} = $obj;
++sub require_ok ($) {
++ my ($require) = @_;
++ eval <<REQUIRE_OK;
++require $require;
++REQUIRE_OK
++ _ok(!$@, _where(), "require $require");
++}
+
-+ bless($obj, 'Foo');
++sub use_ok ($) {
++ my ($use) = @_;
++ eval <<USE_OK;
++use $use;
++USE_OK
++ _ok(!$@, _where(), "use $use");
++}
+
-+ my $copy :shared;
++# runperl - Runs a separate perl interpreter.
++# Arguments :
++# switches => [ command-line switches ]
++# nolib => 1 # don't use -I../lib (included by default)
++# non_portable => Don't warn if a one liner contains quotes
++# prog => one-liner (avoid quotes)
++# progs => [ multi-liner (avoid quotes) ]
++# progfile => perl script
++# stdin => string to feed the stdin
++# stderr => redirect stderr to stdout
++# args => [ command-line arguments to the perl program ]
++# verbose => print the command line
++
++my $is_mswin = $^O eq 'MSWin32';
++my $is_netware = $^O eq 'NetWare';
++my $is_vms = $^O eq 'VMS';
++my $is_cygwin = $^O eq 'cygwin';
++
++sub _quote_args {
++ my ($runperl, $args) = @_;
++
++ foreach (@$args) {
++ # In VMS protect with doublequotes because otherwise
++ # DCL will lowercase -- unless already doublequoted.
++ $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
++ $runperl = $runperl . ' ' . $_;
++ }
++ return $runperl;
++}
+
-+ threads->create(sub {
-+ $copy = shared_clone($obj);
++sub _create_runperl { # Create the string to qx in runperl().
++ my %args = @_;
++ my $runperl = which_perl();
++ if ($runperl =~ m/\s/) {
++ $runperl = qq{"$runperl"};
++ }
++ #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind
++ if ($ENV{PERL_RUNPERL_DEBUG}) {
++ $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
++ }
++ unless ($args{nolib}) {
++ $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS
++ }
++ if ($args{switches}) {
++ local $Level = 2;
++ die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
++ unless ref $args{switches} eq "ARRAY";
++ $runperl = _quote_args($runperl, $args{switches});
++ }
++ if (defined $args{prog}) {
++ die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
++ if defined $args{progs};
++ $args{progs} = [$args{prog}]
++ }
++ if (defined $args{progs}) {
++ die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
++ unless ref $args{progs} eq "ARRAY";
++ foreach my $prog (@{$args{progs}}) {
++ if ($prog =~ tr/'"// && !$args{non_portable}) {
++ warn "quotes in prog >>$prog<< are not portable";
++ }
++ if ($is_mswin || $is_netware || $is_vms) {
++ $runperl = $runperl . qq ( -e "$prog" );
++ }
++ else {
++ $runperl = $runperl . qq ( -e '$prog' );
++ }
++ }
++ } elsif (defined $args{progfile}) {
++ $runperl = $runperl . qq( "$args{progfile}");
++ } else {
++ # You probaby didn't want to be sucking in from the upstream stdin
++ die "test.pl:runperl(): none of prog, progs, progfile, args, "
++ . " switches or stdin specified"
++ unless defined $args{args} or defined $args{switches}
++ or defined $args{stdin};
++ }
++ if (defined $args{stdin}) {
++ # so we don't try to put literal newlines and crs onto the
++ # command line.
++ $args{stdin} =~ s/\n/\\n/g;
++ $args{stdin} =~ s/\r/\\r/g;
++
++ if ($is_mswin || $is_netware || $is_vms) {
++ $runperl = qq{$Perl -e "print qq(} .
++ $args{stdin} . q{)" | } . $runperl;
++ }
++ else {
++ $runperl = qq{$Perl -e 'print qq(} .
++ $args{stdin} . q{)' | } . $runperl;
++ }
++ }
++ if (defined $args{args}) {
++ $runperl = _quote_args($runperl, $args{args});
++ }
++ $runperl = $runperl . ' 2>&1' if $args{stderr};
++ if ($args{verbose}) {
++ my $runperldisplay = $runperl;
++ $runperldisplay =~ s/\n/\n\#/g;
++ _print_stderr "# $runperldisplay\n";
++ }
++ return $runperl;
++}
++
++sub runperl {
++ die "test.pl:runperl() does not take a hashref"
++ if ref $_[0] and ref $_[0] eq 'HASH';
++ my $runperl = &_create_runperl;
++ my $result;
++
++ my $tainted = ${^TAINT};
++ my %args = @_;
++ exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1;
++
++ if ($tainted) {
++ # We will assume that if you're running under -T, you really mean to
++ # run a fresh perl, so we'll brute force launder everything for you
++ my $sep;
++
++ if (! eval 'require Config; 1') {
++ warn "test.pl had problems loading Config: $@";
++ $sep = ':';
++ } else {
++ $sep = $Config::Config{path_sep};
++ }
++
++ my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV);
++ local @ENV{@keys} = ();
++ # Untaint, plus take out . and empty string:
++ local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s);
++ $ENV{PATH} =~ /(.*)/s;
++ local $ENV{PATH} =
++ join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
++ ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
++ split quotemeta ($sep), $1;
++ $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin
++
++ $runperl =~ /(.*)/s;
++ $runperl = $1;
++
++ $result = `$runperl`;
++ } else {
++ $result = `$runperl`;
++ }
++ $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
++ return $result;
++}
++
++# Nice alias
++*run_perl = *run_perl = \&runperl; # shut up "used only once" warning
++
++sub DIE {
++ _print_stderr "# @_\n";
++ exit 1;
++}
+
-+ ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
-+ ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
-+ ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj');
-+ })->join();
++# A somewhat safer version of the sometimes wrong $^X.
++sub which_perl {
++ unless (defined $Perl) {
++ $Perl = $^X;
++
++ # VMS should have 'perl' aliased properly
++ return $Perl if $^O eq 'VMS';
++
++ my $exe;
++ if (! eval 'require Config; 1') {
++ warn "test.pl had problems loading Config: $@";
++ $exe = '';
++ } else {
++ $exe = $Config::Config{_exe};
++ }
++ $exe = '' unless defined $exe;
++
++ # This doesn't absolutize the path: beware of future chdirs().
++ # We could do File::Spec->abs2rel() but that does getcwd()s,
++ # which is a bit heavyweight to do here.
++
++ if ($Perl =~ /^perl\Q$exe\E$/i) {
++ my $perl = "perl$exe";
++ if (! eval 'require File::Spec; 1') {
++ warn "test.pl had problems loading File::Spec: $@";
++ $Perl = "./$perl";
++ } else {
++ $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
++ }
++ }
++
++ # Build up the name of the executable file from the name of
++ # the command.
++
++ if ($Perl !~ /\Q$exe\E$/i) {
++ $Perl = $Perl . $exe;
++ }
++
++ warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
++
++ # For subcommands to use.
++ $ENV{PERLEXE} = $Perl;
++ }
++ return $Perl;
++}
+
-+ $test += 3;
++sub unlink_all {
++ foreach my $file (@_) {
++ 1 while unlink $file;
++ _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file;
++ }
++}
+
-+ ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread');
-+ ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
-+ ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
-+ ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned');
-+ ok($test++, ref($copy) eq 'Foo', 'Cloned object class');
++my %tmpfiles;
++END { unlink_all keys %tmpfiles }
++
++# A regexp that matches the tempfile names
++$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?';
++
++# Avoid ++, avoid ranges, avoid split //
++my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
++sub tempfile {
++ my $count = 0;
++ do {
++ my $temp = $count;
++ my $try = "tmp$$";
++ do {
++ $try = $try . $letters[$temp % 26];
++ $temp = int ($temp / 26);
++ } while $temp;
++ # Need to note all the file names we allocated, as a second request may
++ # come before the first is created.
++ if (!-e $try && !$tmpfiles{$try}) {
++ # We have a winner
++ $tmpfiles{$try} = 1;
++ return $try;
++ }
++ $count = $count + 1;
++ } while $count < 26 * 26;
++ die "Can't find temporary file name starting 'tmp$$'";
+}
+
-+exit(0);
++# This is the temporary file for _fresh_perl
++my $tmpfile = tempfile();
++
++#
++# _fresh_perl
++#
++# The $resolve must be a subref that tests the first argument
++# for success, or returns the definition of success (e.g. the
++# expected scalar) if given no arguments.
++#
++
++sub _fresh_perl {
++ my($prog, $resolve, $runperl_args, $name) = @_;
++
++ # Given the choice of the mis-parsable {}
++ # (we want an anon hash, but a borked lexer might think that it's a block)
++ # or relying on taking a reference to a lexical
++ # (\ might be mis-parsed, and the reference counting on the pad may go
++ # awry)
++ # it feels like the least-worse thing is to assume that auto-vivification
++ # works. At least, this is only going to be a run-time failure, so won't
++ # affect tests using this file but not this function.
++ $runperl_args->{progfile} = $tmpfile;
++ $runperl_args->{stderr} = 1;
++
++ open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
++
++ # VMS adjustments
++ if( $^O eq 'VMS' ) {
++ $prog =~ s#/dev/null#NL:#;
++
++ # VMS file locking
++ $prog =~ s{if \(-e _ and -f _ and -r _\)}
++ {if (-e _ and -f _)}
++ }
+
-+# EOF
-diff -up perl-5.10.0/ext/threads/shared/t/cond.t.shared perl-5.10.0/ext/threads/shared/t/cond.t
---- perl-5.10.0/ext/threads/shared/t/cond.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/cond.t 2010-09-07 08:35:16.195632627 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -282,4 +278,6 @@ $Base++;
- $Base += 4;
- }
-
-+exit(0);
++ print TEST $prog;
++ close TEST or die "Cannot close $tmpfile: $!";
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/disabled.t.shared perl-5.10.0/ext/threads/shared/t/disabled.t
---- perl-5.10.0/ext/threads/shared/t/disabled.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/disabled.t 2010-09-07 08:35:16.196633017 +0200
-@@ -1,18 +1,6 @@
- use strict;
- use warnings;
-
--BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
-- use Config;
-- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-- exit(0);
-- }
--}
--
- use Test;
- plan tests => 31;
-
-@@ -59,4 +47,6 @@ foreach my $func (qw(cond_wait cond_sign
- ok( "@array", "1 2 3 4" );
- }
-
-+exit(0);
++ my $results = runperl(%$runperl_args);
++ my $status = $?;
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/hv_refs.t.shared perl-5.10.0/ext/threads/shared/t/hv_refs.t
---- perl-5.10.0/ext/threads/shared/t/hv_refs.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/hv_refs.t 2010-09-07 08:35:16.196633017 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -110,4 +106,6 @@ ok(10, keys %foo == 0, "And make sure we
- ok(19, is_shared($foo), "Check for sharing");
- ok(20, is_shared(%foo), "Check for sharing");
-
-+exit(0);
++ # Clean up the results into something a bit more predictable.
++ $results =~ s/\n+$//;
++ $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g;
++ $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g;
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/hv_simple.t.shared perl-5.10.0/ext/threads/shared/t/hv_simple.t
---- perl-5.10.0/ext/threads/shared/t/hv_simple.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/hv_simple.t 2010-09-07 08:35:16.197631382 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -77,4 +73,6 @@ ok(15, keys %hash == 0, "Check clear");
-
- ok(16, is_shared(%hash), "Check for sharing");
-
-+exit(0);
++ # bison says 'parse error' instead of 'syntax error',
++ # various yaccs may or may not capitalize 'syntax'.
++ $results =~ s/^(syntax|parse) error/syntax error/mig;
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/no_share.t.shared perl-5.10.0/ext/threads/shared/t/no_share.t
---- perl-5.10.0/ext/threads/shared/t/no_share.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/no_share.t 2010-09-07 08:35:16.198641759 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -61,4 +57,6 @@ ok(5, $test eq "bar" || $test eq 'baz',
-
- ok(6, ! is_shared($test), "Check for sharing");
-
-+exit(0);
++ if ($^O eq 'VMS') {
++ # some tests will trigger VMS messages that won't be expected
++ $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/object.t.shared perl-5.10.0/ext/threads/shared/t/object.t
---- perl-5.10.0/ext/threads/shared/t/object.t.shared 2010-09-07 08:35:16.199642219 +0200
-+++ perl-5.10.0/ext/threads/shared/t/object.t 2010-09-07 08:35:16.199642219 +0200
-@@ -0,0 +1,179 @@
-+use strict;
-+use warnings;
++ # pipes double these sometimes
++ $results =~ s/\n\n/\n/g;
++ }
+
-+BEGIN {
-+ use Config;
-+ if (! $Config{'useithreads'}) {
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
-+ exit(0);
++ my $pass = $resolve->($results);
++ unless ($pass) {
++ _diag "# PROG: \n$prog\n";
++ _diag "# EXPECTED:\n", $resolve->(), "\n";
++ _diag "# GOT:\n$results\n";
++ _diag "# STATUS: $status\n";
+ }
-+ if ($] < 5.010) {
-+ print("1..0 # SKIP Needs Perl 5.10.0 or later\n");
-+ exit(0);
++
++ # Use the first line of the program as a name if none was given
++ unless( $name ) {
++ ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
++ $name = $name . '...' if length $first_line > length $name;
+ }
++
++ _ok($pass, _where(), "fresh_perl - $name");
+}
+
-+use ExtUtils::testlib;
++#
++# fresh_perl_is
++#
++# Combination of run_perl() and is().
++#
+
-+BEGIN {
-+ $| = 1;
-+ print("1..28\n"); ### Number of tests that will be run ###
-+};
++sub fresh_perl_is {
++ my($prog, $expected, $runperl_args, $name) = @_;
+
-+use threads;
-+use threads::shared;
++ # _fresh_perl() is going to clip the trailing newlines off the result.
++ # This will make it so the test author doesn't have to know that.
++ $expected =~ s/\n+$//;
+
-+my $TEST;
-+BEGIN {
-+ share($TEST);
-+ $TEST = 1;
++ local $Level = 2;
++ _fresh_perl($prog,
++ sub { @_ ? $_[0] eq $expected : $expected },
++ $runperl_args, $name);
+}
+
-+sub ok {
-+ my ($ok, $name) = @_;
++#
++# fresh_perl_like
++#
++# Combination of run_perl() and like().
++#
++
++sub fresh_perl_like {
++ my($prog, $expected, $runperl_args, $name) = @_;
++ local $Level = 2;
++ _fresh_perl($prog,
++ sub { @_ ? $_[0] =~ $expected : $expected },
++ $runperl_args, $name);
++}
+
-+ lock($TEST);
-+ my $id = $TEST++;
++sub can_ok ($@) {
++ my($proto, @methods) = @_;
++ my $class = ref $proto || $proto;
+
-+ # You have to do it this way or VMS will get confused.
-+ if ($ok) {
-+ print("ok $id - $name\n");
-+ } else {
-+ print("not ok $id - $name\n");
-+ printf("# Failed test at line %d\n", (caller)[2]);
++ unless( @methods ) {
++ return _ok( 0, _where(), "$class->can(...)" );
+ }
+
-+ return ($ok);
++ my @nok = ();
++ foreach my $method (@methods) {
++ local($!, $@); # don't interfere with caller's $@
++ # eval sometimes resets $!
++ eval { $proto->can($method) } || push @nok, $method;
++ }
++
++ my $name;
++ $name = @methods == 1 ? "$class->can('$methods[0]')"
++ : "$class->can(...)";
++
++ _ok( !@nok, _where(), $name );
+}
+
-+ok(1, 'Loaded');
+
-+### Start of Testing ###
++# Call $class->new( @$args ); and run the result through isa_ok.
++# See Test::More::new_ok
++sub new_ok {
++ my($class, $args, $obj_name) = @_;
++ $args ||= [];
++ $object_name = "The object" unless defined $obj_name;
+
-+{ package Jar;
-+ my @jar :shared;
++ local $Level = $Level + 1;
+
-+ sub new
-+ {
-+ bless(&threads::shared::share({}), shift);
-+ }
++ my $obj;
++ my $ok = eval { $obj = $class->new(@$args); 1 };
++ my $error = $@;
+
-+ sub store
-+ {
-+ my ($self, $cookie) = @_;
-+ push(@jar, $cookie);
-+ return $jar[-1]; # Results in destruction of proxy object
++ if($ok) {
++ isa_ok($obj, $class, $object_name);
+ }
-+
-+ sub peek
-+ {
-+ return $jar[-1];
++ else {
++ ok( 0, "new() died" );
++ diag("Error was: $@");
+ }
+
-+ sub fetch
-+ {
-+ pop(@jar);
-+ }
++ return $obj;
++
+}
+
-+{ package Cookie;
+
-+ sub new
-+ {
-+ my $self = bless(&threads::shared::share({}), shift);
-+ $self->{'type'} = shift;
-+ return $self;
-+ }
++sub isa_ok ($$;$) {
++ my($object, $class, $obj_name) = @_;
+
-+ sub DESTROY
-+ {
-+ delete(shift->{'type'});
++ my $diag;
++ $obj_name = 'The object' unless defined $obj_name;
++ my $name = "$obj_name isa $class";
++ if( !defined $object ) {
++ $diag = "$obj_name isn't defined";
++ }
++ elsif( !ref $object ) {
++ $diag = "$obj_name isn't a reference";
++ }
++ else {
++ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
++ local($@, $!); # eval sometimes resets $!
++ my $rslt = eval { $object->isa($class) };
++ if( $@ ) {
++ if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
++ if( !UNIVERSAL::isa($object, $class) ) {
++ my $ref = ref $object;
++ $diag = "$obj_name isn't a '$class' it's a '$ref'";
++ }
++ } else {
++ die <<WHOA;
++WHOA! I tried to call ->isa on your object and got some weird error.
++This should never happen. Please contact the author immediately.
++Here's the error.
++$@
++WHOA
++ }
++ }
++ elsif( !$rslt ) {
++ my $ref = ref $object;
++ $diag = "$obj_name isn't a '$class' it's a '$ref'";
++ }
+ }
++
++ _ok( !$diag, _where(), $name );
+}
+
-+my $C1 = 'chocolate chip';
-+my $C2 = 'oatmeal raisin';
-+my $C3 = 'vanilla wafer';
++# Set a watchdog to timeout the entire test file
++# NOTE: If the test file uses 'threads', then call the watchdog() function
++# _AFTER_ the 'threads' module is loaded.
++sub watchdog ($;$)
++{
++ my $timeout = shift;
++ my $method = shift || "";
++ my $timeout_msg = 'Test process timed out - terminating';
+
-+my $cookie = Cookie->new($C1);
-+ok($cookie->{'type'} eq $C1, 'Have cookie');
++ # Valgrind slows perl way down so give it more time before dying.
++ $timeout *= 10 if $ENV{PERL_VALGRIND};
+
-+my $jar = Jar->new();
-+$jar->store($cookie);
++ my $pid_to_kill = $$; # PID for this process
+
-+ok($cookie->{'type'} eq $C1, 'Still have cookie');
-+ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
-+ok($cookie->{'type'} eq $C1, 'Still have cookie');
++ if ($method eq "alarm") {
++ goto WATCHDOG_VIA_ALARM;
++ }
+
-+threads->create(sub {
-+ ok($cookie->{'type'} eq $C1, 'Have cookie in thread');
-+ ok($jar->peek()->{'type'} eq $C1, 'Still have cookie in thread');
-+ ok($cookie->{'type'} eq $C1, 'Still have cookie in thread');
++ # shut up use only once warning
++ my $threads_on = $threads::threads && $threads::threads;
++
++ # Don't use a watchdog process if 'threads' is loaded -
++ # use a watchdog thread instead
++ if (!$threads_on) {
++
++ # On Windows and VMS, try launching a watchdog process
++ # using system(1, ...) (see perlport.pod)
++ if (($^O eq 'MSWin32') || ($^O eq 'VMS')) {
++ # On Windows, try to get the 'real' PID
++ if ($^O eq 'MSWin32') {
++ eval { require Win32; };
++ if (defined(&Win32::GetCurrentProcessId)) {
++ $pid_to_kill = Win32::GetCurrentProcessId();
++ }
++ }
+
-+ $jar->store(Cookie->new($C2));
-+ ok($jar->peek()->{'type'} eq $C2, 'Added cookie in thread');
-+})->join();
++ # If we still have a fake PID, we can't use this method at all
++ return if ($pid_to_kill <= 0);
++
++ # Launch watchdog process
++ my $watchdog;
++ eval {
++ local $SIG{'__WARN__'} = sub {
++ _diag("Watchdog warning: $_[0]");
++ };
++ my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
++ my $cmd = _create_runperl( prog => "sleep($timeout);" .
++ "warn qq/# $timeout_msg" . '\n/;' .
++ "kill($sig, $pid_to_kill);");
++ $watchdog = system(1, $cmd);
++ };
++ if ($@ || ($watchdog <= 0)) {
++ _diag('Failed to start watchdog');
++ _diag($@) if $@;
++ undef($watchdog);
++ return;
++ }
+
-+ok($cookie->{'type'} eq $C1, 'Still have original cookie after thread');
-+ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
++ # Add END block to parent to terminate and
++ # clean up watchdog process
++ eval "END { local \$! = 0; local \$? = 0;
++ wait() if kill('KILL', $watchdog); };";
++ return;
++ }
+
-+$cookie = $jar->fetch();
-+ok($cookie->{'type'} eq $C2, 'Fetched cookie from jar');
-+ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
++ # Try using fork() to generate a watchdog process
++ my $watchdog;
++ eval { $watchdog = fork() };
++ if (defined($watchdog)) {
++ if ($watchdog) { # Parent process
++ # Add END block to parent to terminate and
++ # clean up watchdog process
++ eval "END { local \$! = 0; local \$? = 0;
++ wait() if kill('KILL', $watchdog); };";
++ return;
++ }
+
-+$cookie = $jar->fetch();
-+ok($cookie->{'type'} eq $C1, 'Fetched cookie from jar');
-+undef($cookie);
++ ### Watchdog process code
+
-+share($cookie);
-+$cookie = $jar->store(Cookie->new($C3));
-+ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
-+ok($cookie->{'type'} eq $C3, 'Have cookie');
++ # Load POSIX if available
++ eval { require POSIX; };
+
-+threads->create(sub {
-+ ok($cookie->{'type'} eq $C3, 'Have cookie in thread');
-+ $cookie = Cookie->new($C1);
-+ ok($cookie->{'type'} eq $C1, 'Change cookie in thread');
-+ ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
-+})->join();
++ # Execute the timeout
++ sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073
++ sleep(2);
++
++ # Kill test process if still running
++ if (kill(0, $pid_to_kill)) {
++ _diag($timeout_msg);
++ kill('KILL', $pid_to_kill);
++ }
++
++ # Don't execute END block (added at beginning of this file)
++ $NO_ENDING = 1;
++
++ # Terminate ourself (i.e., the watchdog)
++ POSIX::_exit(1) if (defined(&POSIX::_exit));
++ exit(1);
++ }
++
++ # fork() failed - fall through and try using a thread
++ }
++
++ # Use a watchdog thread because either 'threads' is loaded,
++ # or fork() failed
++ if (eval 'require threads; 1') {
++ threads->create(sub {
++ # Load POSIX if available
++ eval { require POSIX; };
++
++ # Execute the timeout
++ my $time_left = $timeout;
++ do {
++ $time_left = $time_left - sleep($time_left);
++ } while ($time_left > 0);
++
++ # Kill the parent (and ourself)
++ select(STDERR); $| = 1;
++ _diag($timeout_msg);
++ POSIX::_exit(1) if (defined(&POSIX::_exit));
++ my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
++ kill($sig, $pid_to_kill);
++ })->detach();
++ return;
++ }
++
++ # If everything above fails, then just use an alarm timeout
++WATCHDOG_VIA_ALARM:
++ if (eval { alarm($timeout); 1; }) {
++ # Load POSIX if available
++ eval { require POSIX; };
++
++ # Alarm handler will do the actual 'killing'
++ $SIG{'ALRM'} = sub {
++ select(STDERR); $| = 1;
++ _diag($timeout_msg);
++ POSIX::_exit(1) if (defined(&POSIX::_exit));
++ my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
++ kill($sig, $pid_to_kill);
++ };
++ }
++}
++
++my $cp_0037 = # EBCDIC code page 0037
++ '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x25\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' .
++ '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' .
++ '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' .
++ '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBA\xE0\xBB\xB0\x6D' .
++ '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' .
++ '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' .
++ '\x20\x21\x22\x23\x24\x15\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' .
++ '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' .
++ '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBD\xB4\x9A\x8A\x5F\xCA\xAF\xBC' .
++ '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' .
++ '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' .
++ '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xAD\xAE\x59' .
++ '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' .
++ '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF';
++
++my $cp_1047 = # EBCDIC code page 1047
++ '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' .
++ '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' .
++ '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' .
++ '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xAD\xE0\xBD\x5F\x6D' .
++ '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' .
++ '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' .
++ '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' .
++ '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' .
++ '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBB\xB4\x9A\x8A\xB0\xCA\xAF\xBC' .
++ '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' .
++ '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' .
++ '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xBA\xAE\x59' .
++ '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' .
++ '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF';
++
++my $cp_bc = # EBCDIC code page POSiX-BC
++ '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' .
++ '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' .
++ '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' .
++ '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBB\xBC\xBD\x6A\x6D' .
++ '\x4A\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' .
++ '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xFB\x4F\xFD\xFF\x07' .
++ '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' .
++ '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\x5F' .
++ '\x41\xAA\xB0\xB1\x9F\xB2\xD0\xB5\x79\xB4\x9A\x8A\xBA\xCA\xAF\xA1' .
++ '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' .
++ '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' .
++ '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xE0\xFE\xDD\xFC\xAD\xAE\x59' .
++ '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' .
++ '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xC0\xDE\xDB\xDC\x8D\x8E\xDF';
++
++my $straight = # Avoid ranges
++ '\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F' .
++ '\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F' .
++ '\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F' .
++ '\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F' .
++ '\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F' .
++ '\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F' .
++ '\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F' .
++ '\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F' .
++ '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F' .
++ '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F' .
++ '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF' .
++ '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF' .
++ '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF' .
++ '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF' .
++ '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' .
++ '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF';
++
++# The following 2 functions allow tests to work on both EBCDIC and
++# ASCII-ish platforms. They convert string scalars between the native
++# character set and the set of 256 characters which is usually called
++# Latin1.
++#
++# These routines don't work on UTF-EBCDIC and UTF-8.
++
++sub native_to_latin1($) {
++ my $string = shift;
++
++ return $string if ord('^') == 94; # ASCII, Latin1
++ my $cp;
++ if (ord('^') == 95) { # EBCDIC 1047
++ $cp = \$cp_1047;
++ }
++ elsif (ord('^') == 106) { # EBCDIC POSIX-BC
++ $cp = \$cp_bc;
++ }
++ elsif (ord('^') == 176) { # EBCDIC 037 */
++ $cp = \$cp_0037;
++ }
++ else {
++ die "Unknown native character set";
++ }
++
++ eval '$string =~ tr/' . $$cp . '/' . $straight . '/';
++ return $string;
++}
+
-+ok($cookie->{'type'} eq $C1, 'Have changed cookie after thread');
-+ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
-+undef($cookie);
-+ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
-+$cookie = $jar->fetch();
-+ok($cookie->{'type'} eq $C3, 'Fetched cookie from jar');
++sub latin1_to_native($) {
++ my $string = shift;
+
-+{ package Foo;
++ return $string if ord('^') == 94; # ASCII, Latin1
++ my $cp;
++ if (ord('^') == 95) { # EBCDIC 1047
++ $cp = \$cp_1047;
++ }
++ elsif (ord('^') == 106) { # EBCDIC POSIX-BC
++ $cp = \$cp_bc;
++ }
++ elsif (ord('^') == 176) { # EBCDIC 037 */
++ $cp = \$cp_0037;
++ }
++ else {
++ die "Unknown native character set";
++ }
+
-+ my $ID = 1;
-+ threads::shared::share($ID);
++ eval '$string =~ tr/' . $straight . '/' . $$cp . '/';
++ return $string;
++}
+
-+ sub new
-+ {
-+ # Anonymous scalar with an internal ID
-+ my $obj = \do{ my $scalar = $ID++; };
-+ threads::shared::share($obj); # Make it shared
-+ return (bless($obj, 'Foo')); # Make it an object
++1;
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/utf8.t perl-5.10.0/ext/threads/shared/t/utf8.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/utf8.t 1970-01-01 01:00:00.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/utf8.t 2009-03-26 15:44:29.000000000 +0100
+@@ -0,0 +1,96 @@
++use strict;
++use warnings;
++
++BEGIN {
++ use Config;
++ if (! $Config{'useithreads'}) {
++ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
++ exit(0);
+ }
+}
+
-+my $obj :shared;
-+$obj = Foo->new();
-+ok($$obj == 1, "Main: Object ID $$obj");
++use ExtUtils::testlib;
+
-+threads->create( sub {
-+ ok($$obj == 1, "Thread: Object ID $$obj");
++my $TEST = 1;
+
-+ $$obj = 10;
-+ ok($$obj == 10, "Thread: Changed object ID $$obj");
++sub is {
++ my ($got, $exp, $name) = @_;
+
-+ $obj = Foo->new();
-+ ok($$obj == 2, "Thread: New object ID $$obj");
-+ } )->join();
++ my $ok = ($got eq $exp);
+
-+ok($$obj == 2, "Main: New object ID $$obj # TODO - should be 2");
++ # You have to do it this way or VMS will get confused.
++ if ($ok) {
++ print("ok $TEST - $name\n");
++ } else {
++ print("not ok $TEST - $name\n");
++ printf("# Failed test at line %d\n", (caller)[2]);
++ print("# Got: $got\n");
++ print("# Expected: $exp\n");
++ }
+
-+exit(0);
++ $TEST++;
+
-+# EOF
-diff -up perl-5.10.0/ext/threads/shared/t/shared_attr.t.shared perl-5.10.0/ext/threads/shared/t/shared_attr.t
---- perl-5.10.0/ext/threads/shared/t/shared_attr.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/shared_attr.t 2010-09-07 08:35:16.200633181 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -78,4 +74,6 @@ for(1..10) {
- ok($test_count++, $str1 eq $str2, 'contents');
- }
-
-+exit(0);
++ return ($ok);
++}
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/stress.t.shared perl-5.10.0/ext/threads/shared/t/stress.t
---- perl-5.10.0/ext/threads/shared/t/stress.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/stress.t 2010-09-07 08:35:16.201641951 +0200
-@@ -2,17 +2,13 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- if ($^O eq 'hpux' && $Config{osvers} <= 10.20) {
-- print("1..0 # Skip: Broken under HP-UX 10.20\n");
-+ print("1..0 # SKIP Broken under HP-UX 10.20\n");
- exit(0);
- }
- }
-@@ -38,16 +34,17 @@ use threads::shared;
- {
- my $cnt = 50;
-
-- my $TIMEOUT = 30;
-+ my $TIMEOUT = 60;
-
- my $mutex = 1;
- share($mutex);
-
- my @threads;
-- for (1..$cnt) {
-+ for (reverse(1..$cnt)) {
- $threads[$_] = threads->create(sub {
- my $tnum = shift;
- my $timeout = time() + $TIMEOUT;
-+ threads->yield();
-
- # Randomize the amount of work the thread does
- my $sum;
-@@ -79,42 +76,54 @@ use threads::shared;
- # Gather thread results
- my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0);
- for (1..$cnt) {
-- my $rc = $threads[$_]->join();
-- if (! $rc) {
-+ if (! $threads[$_]) {
- $failures++;
-- } elsif ($rc =~ /^timed out/) {
-- $timeouts++;
-- } elsif ($rc eq 'okay') {
-- $okay++;
- } else {
-- $unknown++;
-- print("# Unknown error: $rc\n");
-+ my $rc = $threads[$_]->join();
-+ if (! $rc) {
-+ $failures++;
-+ } elsif ($rc =~ /^timed out/) {
-+ $timeouts++;
-+ } elsif ($rc eq 'okay') {
-+ $okay++;
-+ } else {
-+ $unknown++;
-+ print(STDERR "# Unknown error: $rc\n");
-+ }
- }
- }
-+ if ($failures) {
-+ # Most likely due to running out of memory
-+ print(STDERR "# Warning: $failures threads failed\n");
-+ print(STDERR "# Note: errno 12 = ENOMEM\n");
-+ $cnt -= $failures;
-+ }
-
-- if ($failures || $unknown || (($okay + $timeouts) != $cnt)) {
-- print('not ok 1');
-- my $too_few = $cnt - ($okay + $failures + $timeouts + $unknown);
-- print(" - $too_few too few threads reported") if $too_few;
-- print(" - $failures threads failed") if $failures;
-- print(" - $unknown unknown errors") if $unknown;
-- print(" - $timeouts threads timed out") if $timeouts;
-- print("\n");
-+ if ($unknown || (($okay + $timeouts) != $cnt)) {
-+ print("not ok 1\n");
-+ my $too_few = $cnt - ($okay + $timeouts + $unknown);
-+ print(STDERR "# Test failed:\n");
-+ print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
-+ print(STDERR "#\t$unknown unknown errors\n") if $unknown;
-+ print(STDERR "#\t$timeouts threads timed out\n") if $timeouts;
-
- } elsif ($timeouts) {
- # Frequently fails under MSWin32 due to deadlocking bug in Windows
- # hence test is TODO under MSWin32
- # http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
- # http://support.microsoft.com/kb/175332
-- print('not ok 1');
-- print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
-- print(" - $timeouts threads timed out\n");
-+ if ($^O eq 'MSWin32') {
-+ print("not ok 1 # TODO - not reliable under MSWin32\n")
-+ } else {
-+ print("not ok 1\n");
-+ print(STDERR "# Test failed: $timeouts threads timed out\n");
-+ }
-
- } else {
-- print('ok 1');
-- print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
-- print("\n");
-+ print("ok 1\n");
- }
- }
-
-+exit(0);
++BEGIN {
++ $| = 1;
++ print("1..12\n"); ### Number of tests that will be run ###
++};
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/sv_refs.t.shared perl-5.10.0/ext/threads/shared/t/sv_refs.t
---- perl-5.10.0/ext/threads/shared/t/sv_refs.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/sv_refs.t 2010-09-07 08:35:16.202640246 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -31,7 +27,7 @@ sub ok {
-
- BEGIN {
- $| = 1;
-- print("1..11\n"); ### Number of tests that will be run ###
-+ print("1..21\n"); ### Number of tests that will be run ###
- };
-
- use threads;
-@@ -74,4 +70,32 @@ ok(10,$t1 eq 'bar',"Check that assign to
-
- ok(11, is_shared($foo), "Check for sharing");
-
-+{
-+ # Circular references with 3 shared scalars
-+ my $x : shared;
-+ my $y : shared;
-+ my $z : shared;
++use threads;
++use threads::shared;
+
-+ $x = \$y;
-+ $y = \$z;
-+ $z = \$x;
-+ ok(12, ref($x) eq 'REF', '$x ref type');
-+ ok(13, ref($y) eq 'REF', '$y ref type');
-+ ok(14, ref($z) eq 'REF', '$z ref type');
++### Start of Testing ###
+
-+ my @q :shared = ($x);
-+ ok(15, ref($q[0]) eq 'REF', '$q[0] ref type');
++binmode STDOUT, ":utf8";
+
-+ my $w = $q[0];
-+ ok(16, ref($w) eq 'REF', '$w ref type');
-+ ok(17, ref($$w) eq 'REF', '$$w ref type');
-+ ok(18, ref($$$w) eq 'REF', '$$$w ref type');
-+ ok(19, ref($$$$w) eq 'REF', '$$$$w ref type');
++my $plain = 'foo';
++my $utf8 = "\x{123}\x{84}\x{20F}\x{2C1}";
++my $code = \&is;
+
-+ ok(20, is_shared($x) == is_shared($w), '_id($x) == _id($w)');
-+ ok(21, is_shared($w) == is_shared($$$$w), '_id($w) == _id($$$$w)');
++my %a :shared;
++$a{$plain} = $plain;
++$a{$utf8} = $utf8;
++$a{$code} = 'code';
++
++is(exists($a{$plain}), 1, 'Found plain key in shared hash');
++is(exists($a{$utf8}), 1, 'Found UTF-8 key in shared hash');
++is(exists($a{$code}), 1, 'Found code ref key in shared hash');
++
++while (my ($key, $value) = each (%a)) {
++ if ($key eq $plain) {
++ is($key, $plain, 'Plain key in shared hash');
++ } elsif ($key eq $utf8) {
++ is($key, $utf8, 'UTF-8 key in shared hash');
++ } elsif ($key eq "$code") {
++ is($key, "$code", 'Code ref key in shared hash');
++ } else {
++ is($key, "???", 'Bad key');
++ }
+}
+
-+exit(0);
++my $a = &share({});
++$$a{$plain} = $plain;
++$$a{$utf8} = $utf8;
++$$a{$code} = 'code';
++
++is(exists($$a{$plain}), 1, 'Found plain key in shared hash ref');
++is(exists($$a{$utf8}), 1, 'Found UTF-8 key in shared hash ref');
++is(exists($$a{$code}), 1, 'Found code ref key in shared hash ref');
++
++while (my ($key, $value) = each (%$a)) {
++ if ($key eq $plain) {
++ is($key, $plain, 'Plain key in shared hash ref');
++ } elsif ($key eq $utf8) {
++ is($key, $utf8, 'UTF-8 key in shared hash ref');
++ } elsif ($key eq "$code") {
++ is($key, "$code", 'Code ref key in shared hash ref');
++ } else {
++ is($key, "???", 'Bad key');
++ }
++}
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/sv_simple.t.shared perl-5.10.0/ext/threads/shared/t/sv_simple.t
---- perl-5.10.0/ext/threads/shared/t/sv_simple.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/sv_simple.t 2010-09-07 08:35:16.203631557 +0200
-@@ -2,13 +2,9 @@ use strict;
- use warnings;
-
- BEGIN {
-- if ($ENV{'PERL_CORE'}){
-- chdir 't';
-- unshift @INC, '../lib';
-- }
- use Config;
- if (! $Config{'useithreads'}) {
-- print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
-+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
- exit(0);
- }
- }
-@@ -63,4 +59,6 @@ ok(10, !defined($test), "Check undef val
-
- ok(11, is_shared($test), "Check for sharing");
-
+exit(0);
+
- # EOF
-diff -up perl-5.10.0/ext/threads/shared/t/waithires.t.shared perl-5.10.0/ext/threads/shared/t/waithires.t
---- perl-5.10.0/ext/threads/shared/t/waithires.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/waithires.t 2010-09-07 08:35:16.205631429 +0200
-@@ -2,31 +2,26 @@ use strict;
++# EOF
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/waithires.t perl-5.10.0/ext/threads/shared/t/waithires.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/waithires.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/waithires.t 2009-10-16 18:41:50.000000000 +0200
+@@ -2,31 +2,26 @@
use warnings;
BEGIN {
@@ -1557,7 +10044,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/waithires.t.shared perl-5.10.0/ext/thr
+ # Import test.pl into its own package
+ {
+ package Test;
-+ require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
++ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
}
+
use Config;
@@ -1588,7 +10075,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/waithires.t.shared perl-5.10.0/ext/thr
# You have to do it this way or VMS will get confused.
if ($ok) {
-@@ -47,8 +42,10 @@ BEGIN {
+@@ -47,8 +42,10 @@
use threads;
use threads::shared;
@@ -1601,7 +10088,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/waithires.t.shared perl-5.10.0/ext/thr
### Start of Testing ###
-@@ -65,149 +62,110 @@ $Base++;
+@@ -65,149 +62,110 @@
# and consider upgrading their glibc.
@@ -1838,7 +10325,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/waithires.t.shared perl-5.10.0/ext/thr
} # -- SYNCH_SHARED block
-@@ -215,107 +173,107 @@ SYNC_SHARED: {
+@@ -215,107 +173,107 @@
# same as above, but with references to lock and cond vars
SYNCH_REFS: {
@@ -2032,10 +10519,10 @@ diff -up perl-5.10.0/ext/threads/shared/t/waithires.t.shared perl-5.10.0/ext/thr
+exit(0);
+
# EOF
-diff -up perl-5.10.0/ext/threads/shared/t/wait.t.shared perl-5.10.0/ext/threads/shared/t/wait.t
---- perl-5.10.0/ext/threads/shared/t/wait.t.shared 2007-12-18 11:47:07.000000000 +0100
-+++ perl-5.10.0/ext/threads/shared/t/wait.t 2010-09-07 08:35:16.207631092 +0200
-@@ -2,23 +2,22 @@ use strict;
+diff -urN perl-5.10.0/ext/threads/shared/t.oldsharet/wait.t perl-5.10.0/ext/threads/shared/t/wait.t
+--- perl-5.10.0/ext/threads/shared/t.oldsharet/wait.t 2007-12-18 11:47:07.000000000 +0100
++++ perl-5.10.0/ext/threads/shared/t/wait.t 2009-10-16 18:41:47.000000000 +0200
+@@ -2,23 +2,22 @@
use warnings;
BEGIN {
@@ -2045,7 +10532,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/wait.t.shared perl-5.10.0/ext/threads/
+ # Import test.pl into its own package
+ {
+ package Test;
-+ require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
++ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
}
+
use Config;
@@ -2065,7 +10552,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/wait.t.shared perl-5.10.0/ext/threads/
# You have to do it this way or VMS will get confused.
if ($ok) {
-@@ -38,8 +37,11 @@ BEGIN {
+@@ -38,8 +37,11 @@
use threads;
use threads::shared;
@@ -2079,7 +10566,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/wait.t.shared perl-5.10.0/ext/threads/
### Start of Testing ###
-@@ -56,174 +58,147 @@ $Base++;
+@@ -56,174 +58,147 @@
# and consider upgrading their glibc.
@@ -2374,7 +10861,7 @@ diff -up perl-5.10.0/ext/threads/shared/t/wait.t.shared perl-5.10.0/ext/threads/
} # -- SYNCH_SHARED block
-@@ -231,123 +206,136 @@ SYNC_SHARED: {
+@@ -231,123 +206,136 @@
# same as above, but with references to lock and cond vars
SYNCH_REFS: {
@@ -2611,52 +11098,3 @@ diff -up perl-5.10.0/ext/threads/shared/t/wait.t.shared perl-5.10.0/ext/threads/
+exit(0);
+
# EOF
-diff -up perl-5.10.0/MANIFEST.shared perl-5.10.0/MANIFEST
---- perl-5.10.0/MANIFEST.shared 2010-09-07 08:35:16.136654173 +0200
-+++ perl-5.10.0/MANIFEST 2010-09-07 08:36:40.562882613 +0200
-@@ -1169,17 +1169,16 @@ ext/threads/shared/t/0nothread.t Tests f
- ext/threads/shared/t/av_refs.t Tests for arrays containing references
- ext/threads/shared/t/av_simple.t Tests for basic shared array functionality.
- ext/threads/shared/t/blessed.t Test blessed shared variables
-+ext/threads/shared/t/clone.t Test
-+ext/threads/shared/t/object.t Test
- ext/threads/shared/t/cond.t Test condition variables
- ext/threads/shared/t/disabled.t Test threads::shared when threads are disabled.
- ext/threads/shared/t/hv_refs.t Test shared hashes containing references
--ext/threads/shared/t/hv_simple.t Tests for basic shared hash functionality.
- ext/threads/shared/t/no_share.t Tests for disabled share on variables.
- ext/threads/shared/t/shared_attr.t Test :shared attribute
- ext/threads/shared/t/stress.t Stress test
- ext/threads/shared/t/sv_refs.t thread shared variables
- ext/threads/shared/t/sv_simple.t thread shared variables
--ext/threads/shared/t/waithires.t Test sub-second cond_timedwait
--ext/threads/shared/t/wait.t Test cond_wait and cond_timedwait
- ext/threads/t/basic.t ithreads
- ext/threads/t/blocks.t Test threads in special blocks
- ext/threads/t/context.t Explicit thread context
-@@ -1201,7 +1200,6 @@ ext/threads/t/state.t Tests state metho
- ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument.
- ext/threads/t/stress_re.t Test with multiple threads, string cv argument and regexes.
- ext/threads/t/stress_string.t Test with multiple threads, string cv argument.
--ext/threads/t/thread.t General ithread tests from thr5005
- ext/Time/HiRes/Changes Time::HiRes extension
- ext/Time/HiRes/fallback/const-c.inc Time::HiRes extension
- ext/Time/HiRes/fallback/const-xs.inc Time::HiRes extension
-@@ -2816,10 +2814,16 @@ lib/Text/TabsWrap/t/wrap.t See if Text::
- lib/Text/Wrap.pm Paragraph formatter
- lib/Thread.pm Thread extensions frontend
- lib/Thread/Queue.pm Threadsafe queue
--lib/Thread/Queue.t See if threadsafe queue works
- lib/Thread/Semaphore.pm Threadsafe semaphore
- lib/Thread/Semaphore.t See if threadsafe semaphore works
- lib/Thread.t Thread extensions frontend tests
-+lib/Thread/Queue/t/01_basic.t Test
-+lib/Thread/Queue/t/03_peek.t Test
-+lib/Thread/Queue/t/04_errs.t Test
-+lib/Thread/Queue/t/05_extract.t Test
-+lib/Thread/Queue/t/06_insert.t Test
-+lib/Thread/Queue/t/07_lock.t Test
-+lib/Thread/Queue/t/08_nothreads.t Test
- lib/Tie/Array.pm Base class for tied arrays
- lib/Tie/Array/push.t Test for Tie::Array
- lib/Tie/Array/splice.t Test for Tie::Array::SPLICE
diff --git a/perl.spec b/perl.spec
index 1c01047..33eb938 100644
--- a/perl.spec
+++ b/perl.spec
@@ -7,7 +7,7 @@
Name: perl
Version: %{perl_version}
-Release: 95%{?dist}
+Release: 96%{?dist}
Epoch: %{perl_epoch}
Summary: Practical Extraction and Report Language
Group: Development/Languages
@@ -262,10 +262,14 @@ Patch125: perl-update-IO-Compress-Zlib.patch
%define IO_Compress_Zlib_version 2.015
Patch126: perl-update-Safe.patch
%define Safe_version 2.27
-Patch127: perl-update-threadsshared.patch
-%define threadsshared_version 1.29
-Patch128: perl-update-Thread-Queue.patch
+Patch127: perl-update-thread.patch
+%define thread_version 1.79
+Patch128: perl-update-threadsshared.patch
+%define threadsshared_version 1.34
+Patch129: perl-update-Thread-Queue.patch
%define ThreadQueue_version 2.11
+# change MANIFEST at last
+Patch130: manifest.patch
# Fedora uses links instead of lynx
# patches File-Fetch and CPAN
@@ -276,7 +280,7 @@ Patch202: perl-5.10.1-unpack-didn-t-handle-scalar-context.patch
# Do not throw ../lib from @lib. Fixed in Test-Harness-3.17.
Patch203: perl-Test-Harness-3.16-fix_taint_test.patch
-BuildRoot: %(mktemp -ud %{_tmppath}/%{name}-%{version}-%{release}-XXXXXX)
+##BuildRoot: %(mktemp -ud %{_tmppath}/%{name}-%{version}-%{release}-XXXXXX)
BuildRequires: tcsh, dos2unix, man, groff
BuildRequires: gdbm-devel, db4-devel, zlib-devel
# For tests
@@ -1064,8 +1068,10 @@ touch t/Module_Pluggable/lib/Zot/.Zork.pm
%patch124 -p1
%patch125 -p1
%patch126 -p1
-%patch127 -p1
-%patch128 -p1
+%patch127 -p1 -b .newthread
+%patch128 -p1 -E -b .newshare
+%patch129 -p1
+%patch130 -p1 -b .newmanifest
%patch201 -p1
%patch202 -p1
@@ -1356,8 +1362,10 @@ perl -x patchlevel.h \
'Fedora Patch124: Update IO::Compress::Base to %{IO_Compress_Base_version}' \
'Fedora Patch125: Update IO::Compress::Zlib to %{IO_Compress_Zlib_version}' \
'Fedora Patch126: Update Safe to %{Safe_version}' \
- 'Fedora Patch127: Update threads::shared to %{threadsshared_version}'\
- 'Fedora Patch128: Update Thread::Queue to %{ThreadQueue_version}'\
+ 'Fedora Patch127: Update threads to %{thread_version} '\
+ 'Fedora Patch128: Update threads::shared to %{threadsshared_version}'\
+ 'Fedora Patch129: Update Thread::Queue to %{ThreadQueue_version}'\
+ 'Fedora Patch130: Fix files in MANIFEST '\
'Fedora Patch201: Fedora uses links instead of lynx' \
'Fedora Patch202: RT#73814 - unpack scalar context correctly ' \
'Fedora Patch203: Fix taint.t test in Test::Harness ' \
@@ -1986,6 +1994,10 @@ TMPDIR="$PWD/tmp" make test
# Old changelog entries are preserved in CVS.
%changelog
+* Tue Oct 11 2010 Marcela Mašláňová <mmaslano at redhat.com> - 4:5.10.0-96
+- update of threads::shared and threads, which should fix failure of
+ threads in previous update
+
* Tue Sep 7 2010 Marcela Mašláňová <mmaslano at redhat.com> - 4:5.10.0-95
- update thread modules - Thread::Queue, threads::shared, which also fix
627192
More information about the scm-commits
mailing list