summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLorry Tar Creator <lorry-tar-importer@lorry>2013-07-16 16:17:11 +0000
committerLorry Tar Creator <lorry-tar-importer@lorry>2013-07-16 16:17:11 +0000
commitfff2e7a8ec398e4c5229fb61b1107cffda28aabd (patch)
treeb936d2a5f64761b3aa0edc8881af6f07e7680276
downloadPackage-Stash-XS-tarball-fff2e7a8ec398e4c5229fb61b1107cffda28aabd.tar.gz
Package-Stash-XS-0.28HEADPackage-Stash-XS-0.28master
Diffstat
-rw-r--r--Changes108
-rw-r--r--LICENSE379
-rw-r--r--MANIFEST39
-rw-r--r--META.json315
-rw-r--r--META.yml229
-rw-r--r--Makefile.PL78
-rw-r--r--README13
-rw-r--r--XS.xs993
-rw-r--r--dist.ini25
-rw-r--r--lib/Package/Stash/XS.pm111
-rw-r--r--ppport.h7258
-rw-r--r--t/00-compile.t74
-rw-r--r--t/addsub.t46
-rw-r--r--t/anon-basic.t403
-rw-r--r--t/anon.t49
-rw-r--r--t/bare-anon-basic.t397
-rw-r--r--t/bare-anon.t62
-rw-r--r--t/basic.t448
-rw-r--r--t/compile-time.t9
-rw-r--r--t/edge-cases.t113
-rw-r--r--t/extension.t76
-rw-r--r--t/get.t186
-rw-r--r--t/io.t51
-rw-r--r--t/isa.t49
-rw-r--r--t/lib/CompileTime.pm15
-rw-r--r--t/lib/Package/Stash.pm19
-rw-r--r--t/magic.t80
-rw-r--r--t/paamayim_nekdotayim.t28
-rw-r--r--t/scalar-values.t53
-rw-r--r--t/stash-deletion.t24
-rw-r--r--t/synopsis.t19
-rw-r--r--t/warnings.t22
-rw-r--r--typemap18
-rw-r--r--xt/author/leaks-debug.t230
-rw-r--r--xt/author/leaks.t228
-rw-r--r--xt/release/eol.t8
-rw-r--r--xt/release/no-tabs.t8
-rw-r--r--xt/release/pod-coverage.t13
-rw-r--r--xt/release/pod-syntax.t7
39 files changed, 12283 insertions, 0 deletions
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..4081e1d
--- /dev/null
+++ b/Changes
@@ -0,0 +1,108 @@
+Revision history for Package-Stash-XS
+
+0.28 2013-07-16
+ - fix test issue (Graham Knop)
+
+0.27 2013-07-15
+ - handle magic more correctly in add_symbol and get_or_add_symbol
+
+0.26 2013-01-04
+ - internal refactorings to support Package::Anon stashes - this should
+ work now
+
+0.25 2011-09-06
+ - fix compilation on perl 5.8 (RT#70762)
+
+0.24 2011-09-05
+ - invalid package names (for instance, Foo:Bar) are not allowed
+ - invalid stash entry names (anything containing ::) are not allowed
+
+0.23 2011-08-08
+ - fix the test for scalar values, again (t0m, rafl)
+ - disallow assigning globrefs to scalar glob slots (this doesn't actually
+ make any sense)
+
+0.22 2011-03-04
+ - make the namespace cache lazy and weak, in case the stash is deleted
+ - but, this doesn't work on 5.8, so disable the namespace caching
+ entirely there
+
+0.21 2011-01-25
+ - make the leak tests author-only, since some smokers run release tests
+ - fix some xs forward compat stuff (Dave Mitchell)
+
+0.20 2011-01-11
+ - lower perl prereq to 5.8.1 (ribasushi)
+ - make the leak tests release-only, since they keep randomly failing on
+ platforms i don't have access to. people are encouraged to submit
+ patches for these if they are affected.
+
+0.19 2011-01-05
+ - actually fix scalar initial value validity test
+
+0.18 2011-01-05
+ - more correct validity test for scalars (rafl, Roland van Ipenburg)
+
+0.17 2010-11-16
+ - bah, get rid of extra junk in the tarball
+
+0.16-TRIAL 2010-11-16
+ - fix some issues in the undocumented-but-still-maybe-used-some-places
+ hashref api - if you don't know what this is, good!
+
+0.15-TRIAL 2010-11-16
+ - split the XS implementation out into its own dist, which will be used
+ as a backend for Package::Stash if possible
+
+0.14-TRIAL 2010-11-14
+ - complete rewrite in C, for speed (this includes the vivification
+ changes from earlier). should be entirely backwards compatible
+ otherwise (in terms of documented api anyway).
+
+0.13 2010-10-31
+ - revert the vivification changes for now, to get an actual release out
+ with Test::Fatal
+
+0.12-TRIAL 2010-10-27
+ - actually include the conflict stuff in the release (bah)
+
+0.11-TRIAL 2010-10-27
+ - conflict on mx-role-withoverloading too
+
+0.10-TRIAL 2010-10-27
+ - only do the weird ISA special-casing on perl versions where it's broken
+
+0.09-TRIAL 2010-10-27
+ - clean up the vivication code a lot, make it behave more sanely
+ - use Test::Fatal instead of Test::Exception (Justin Hunter)
+
+0.08 2010-09-18
+ - oops, accidentally included some experimental changes in that last
+ release, that break things
+
+0.07 2010-09-18
+ - non-dev release
+
+0.06-TRIAL 2010-08-26
+ - re-enable the caching of the stash, since I can't reproduce the bug
+ at all
+
+0.05 2010-06-15
+ - bump Test::More requirement for done_testing
+
+ - update packaging stuff
+
+0.04 2010-06-13
+ - get_package_symbol now doesn't autovivify stash entries. A new method
+ get_or_add_package_symbol can now be used for that behavior.
+
+ - Update %DB::sub on add_package_symbol (Tim Bunce).
+
+0.03 2010-05-14
+ - Rename from Stash::Manip to Package::Stash
+
+0.02 2010-05-13
+ - Need to dep on Test::Exception
+
+0.01 2010-05-12
+ - Initial release
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f252766
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,379 @@
+This software is copyright (c) 2013 by Jesse Luehrs.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+Terms of the Perl programming language system itself
+
+a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+b) the "Artistic License"
+
+--- The GNU General Public License, Version 1, February 1989 ---
+
+This software is Copyright (c) 2013 by Jesse Luehrs.
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 1, February 1989
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
+--- The Artistic License 1.0 ---
+
+This software is Copyright (c) 2013 by Jesse Luehrs.
+
+This is free software, licensed under:
+
+ The Artistic License 1.0
+
+The Artistic License
+
+Preamble
+
+The intent of this document is to state the conditions under which a Package
+may be copied, such that the Copyright Holder maintains some semblance of
+artistic control over the development of the package, while giving the users of
+the package the right to use and distribute the Package in a more-or-less
+customary fashion, plus the right to make reasonable modifications.
+
+Definitions:
+
+ - "Package" refers to the collection of files distributed by the Copyright
+ Holder, and derivatives of that collection of files created through
+ textual modification.
+ - "Standard Version" refers to such a Package if it has not been modified,
+ or has been modified in accordance with the wishes of the Copyright
+ Holder.
+ - "Copyright Holder" is whoever is named in the copyright or copyrights for
+ the package.
+ - "You" is you, if you're thinking about copying or distributing this Package.
+ - "Reasonable copying fee" is whatever you can justify on the basis of media
+ cost, duplication charges, time of people involved, and so on. (You will
+ not be required to justify it to the Copyright Holder, but only to the
+ computing community at large as a market that must bear the fee.)
+ - "Freely Available" means that no fee is charged for the item itself, though
+ there may be fees involved in handling the item. It also means that
+ recipients of the item may redistribute it under the same conditions they
+ received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications derived
+from the Public Domain or from the Copyright Holder. A Package modified in such
+a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided that
+you insert a prominent notice in each changed file stating how and when you
+changed that file, and provided that you do at least ONE of the following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or an
+ equivalent medium, or placing the modifications on a major archive site
+ such as ftp.uu.net, or by allowing the Copyright Holder to include your
+ modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict with
+ standard executables, which must also be provided, and provide a separate
+ manual page for each non-standard executable that clearly documents how it
+ differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or executable
+form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where to
+ get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of the Package
+ with your modifications.
+
+ c) accompany any non-standard executables with their corresponding Standard
+ Version executables, giving the non-standard executables non-standard
+ names, and clearly documenting the differences in manual pages (or
+ equivalent), together with instructions on where to get the Standard
+ Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this Package. You
+may not charge a fee for this Package itself. However, you may distribute this
+Package in aggregate with other (possibly commercial) programs as part of a
+larger (possibly commercial) software distribution provided that you do not
+advertise this Package as a product of your own.
+
+6. The scripts and library files supplied as input to or produced as output
+from the programs of this Package do not automatically fall under the copyright
+of this Package, but belong to whomever generated them, and may be sold
+commercially, and may be aggregated with this Package.
+
+7. C or perl subroutines supplied by you and linked into this Package shall not
+be considered part of this Package.
+
+8. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+The End
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..1409393
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,39 @@
+Changes
+LICENSE
+MANIFEST
+META.json
+META.yml
+Makefile.PL
+README
+XS.xs
+dist.ini
+lib/Package/Stash/XS.pm
+ppport.h
+t/00-compile.t
+t/addsub.t
+t/anon-basic.t
+t/anon.t
+t/bare-anon-basic.t
+t/bare-anon.t
+t/basic.t
+t/compile-time.t
+t/edge-cases.t
+t/extension.t
+t/get.t
+t/io.t
+t/isa.t
+t/lib/CompileTime.pm
+t/lib/Package/Stash.pm
+t/magic.t
+t/paamayim_nekdotayim.t
+t/scalar-values.t
+t/stash-deletion.t
+t/synopsis.t
+t/warnings.t
+typemap
+xt/author/leaks-debug.t
+xt/author/leaks.t
+xt/release/eol.t
+xt/release/no-tabs.t
+xt/release/pod-coverage.t
+xt/release/pod-syntax.t
diff --git a/META.json b/META.json
new file mode 100644
index 0000000..1cd4bb4
--- /dev/null
+++ b/META.json
@@ -0,0 +1,315 @@
+{
+ "abstract" : "faster and more correct implementation of the Package::Stash API",
+ "author" : [
+ "Jesse Luehrs <doy@tozt.net>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.120921",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Package-Stash-XS",
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.30"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Pod::Coverage::TrustPod" : "0",
+ "Test::LeakTrace" : "0",
+ "Test::Pod" : "1.41",
+ "Test::Pod::Coverage" : "1.08"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "XSLoader" : "0",
+ "perl" : "5.008001",
+ "strict" : "0",
+ "warnings" : "0"
+ }
+ },
+ "test" : {
+ "requires" : {
+ "B" : "0",
+ "File::Find" : "0",
+ "File::Temp" : "0",
+ "Scalar::Util" : "0",
+ "Symbol" : "0",
+ "Test::Fatal" : "0",
+ "Test::More" : "0.88",
+ "Test::Requires" : "0",
+ "base" : "0",
+ "constant" : "0"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/doy/package-stash-xs/issues"
+ },
+ "homepage" : "http://metacpan.org/release/Package-Stash-XS",
+ "repository" : {
+ "type" : "git",
+ "url" : "git://github.com/doy/package-stash-xs.git",
+ "web" : "https://github.com/doy/package-stash-xs"
+ }
+ },
+ "version" : "0.28",
+ "x_Dist_Zilla" : {
+ "perl" : {
+ "version" : "5.018000"
+ },
+ "plugins" : [
+ {
+ "class" : "Dist::Zilla::Plugin::Prereqs",
+ "config" : {
+ "Dist::Zilla::Plugin::Prereqs" : {
+ "phase" : "test",
+ "type" : "requires"
+ }
+ },
+ "name" : "@DOY/TestMoreDoneTesting",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::GatherDir",
+ "name" : "@DOY/GatherDir",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PruneCruft",
+ "name" : "@DOY/PruneCruft",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ManifestSkip",
+ "name" : "@DOY/ManifestSkip",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaYAML",
+ "name" : "@DOY/MetaYAML",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::License",
+ "name" : "@DOY/License",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Readme",
+ "name" : "@DOY/Readme",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::RunExtraTests",
+ "name" : "@DOY/RunExtraTests",
+ "version" : "0.011"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ExecDir",
+ "name" : "@DOY/ExecDir",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ShareDir",
+ "name" : "@DOY/ShareDir",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MakeMaker",
+ "name" : "@DOY/MakeMaker",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Manifest",
+ "name" : "@DOY/Manifest",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::TestRelease",
+ "name" : "@DOY/TestRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ConfirmRelease",
+ "name" : "@DOY/ConfirmRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaConfig",
+ "name" : "@DOY/MetaConfig",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaJSON",
+ "name" : "@DOY/MetaJSON",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::NextRelease",
+ "name" : "@DOY/NextRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
+ "name" : "@DOY/CheckChangesHasContent",
+ "version" : "0.006"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PkgVersion",
+ "name" : "@DOY/PkgVersion",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Authority",
+ "name" : "@DOY/Authority",
+ "version" : "1.006"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodCoverageTests",
+ "name" : "@DOY/PodCoverageTests",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
+ "name" : "@DOY/PodSyntaxTests",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::NoTabsTests",
+ "name" : "@DOY/NoTabsTests",
+ "version" : "0.01"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::EOLTests",
+ "name" : "@DOY/EOLTests",
+ "version" : "0.02"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::Compile",
+ "name" : "@DOY/Test::Compile",
+ "version" : "2.002"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Metadata",
+ "name" : "@DOY/Metadata",
+ "version" : "3.03"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaResources",
+ "name" : "@DOY/MetaResources",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Git::Check",
+ "name" : "@DOY/Git::Check",
+ "version" : "2.013"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Git::Commit",
+ "name" : "@DOY/Git::Commit",
+ "version" : "2.013"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Git::Tag",
+ "name" : "@DOY/Git::Tag",
+ "version" : "2.013"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Git::NextVersion",
+ "name" : "@DOY/Git::NextVersion",
+ "version" : "2.013"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodWeaver",
+ "name" : "@DOY/PodWeaver",
+ "version" : "3.101641"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::UploadToCPAN",
+ "name" : "@DOY/UploadToCPAN",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::AutoPrereqs",
+ "name" : "AutoPrereqs",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Prereqs",
+ "config" : {
+ "Dist::Zilla::Plugin::Prereqs" : {
+ "phase" : "develop",
+ "type" : "requires"
+ }
+ },
+ "name" : "DevelopRequires",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PruneFiles",
+ "name" : "PruneFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ContributorsFromGit",
+ "name" : "ContributorsFromGit",
+ "version" : "0.006"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":InstallModules",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":IncModules",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":TestFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":ExecFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":ShareFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":MainModule",
+ "version" : "4.300034"
+ }
+ ],
+ "zilla" : {
+ "class" : "Dist::Zilla::Dist::Builder",
+ "config" : {
+ "is_trial" : "0"
+ },
+ "version" : "4.300034"
+ }
+ },
+ "x_authority" : "cpan:DOY",
+ "x_contributors" : [
+ "Dave Rolsky <autarch@urth.org>",
+ "Florian Ragwitz <rafl@debian.org>",
+ "Justin Hunter <justin.d.hunter@gmail.com>",
+ "Tim Bunce <Tim.Bunce@pobox.com>"
+ ]
+}
+
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..73cb6e0
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,229 @@
+---
+abstract: 'faster and more correct implementation of the Package::Stash API'
+author:
+ - 'Jesse Luehrs <doy@tozt.net>'
+build_requires:
+ B: 0
+ File::Find: 0
+ File::Temp: 0
+ Scalar::Util: 0
+ Symbol: 0
+ Test::Fatal: 0
+ Test::More: 0.88
+ Test::Requires: 0
+ base: 0
+ constant: 0
+configure_requires:
+ ExtUtils::MakeMaker: 6.30
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.120921'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Package-Stash-XS
+requires:
+ XSLoader: 0
+ perl: 5.008001
+ strict: 0
+ warnings: 0
+resources:
+ bugtracker: https://github.com/doy/package-stash-xs/issues
+ homepage: http://metacpan.org/release/Package-Stash-XS
+ repository: git://github.com/doy/package-stash-xs.git
+version: 0.28
+x_Dist_Zilla:
+ perl:
+ version: 5.018000
+ plugins:
+ -
+ class: Dist::Zilla::Plugin::Prereqs
+ config:
+ Dist::Zilla::Plugin::Prereqs:
+ phase: test
+ type: requires
+ name: '@DOY/TestMoreDoneTesting'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::GatherDir
+ name: '@DOY/GatherDir'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::PruneCruft
+ name: '@DOY/PruneCruft'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ManifestSkip
+ name: '@DOY/ManifestSkip'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaYAML
+ name: '@DOY/MetaYAML'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::License
+ name: '@DOY/License'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Readme
+ name: '@DOY/Readme'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::RunExtraTests
+ name: '@DOY/RunExtraTests'
+ version: 0.011
+ -
+ class: Dist::Zilla::Plugin::ExecDir
+ name: '@DOY/ExecDir'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ShareDir
+ name: '@DOY/ShareDir'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MakeMaker
+ name: '@DOY/MakeMaker'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Manifest
+ name: '@DOY/Manifest'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::TestRelease
+ name: '@DOY/TestRelease'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ConfirmRelease
+ name: '@DOY/ConfirmRelease'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaConfig
+ name: '@DOY/MetaConfig'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaJSON
+ name: '@DOY/MetaJSON'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::NextRelease
+ name: '@DOY/NextRelease'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::CheckChangesHasContent
+ name: '@DOY/CheckChangesHasContent'
+ version: 0.006
+ -
+ class: Dist::Zilla::Plugin::PkgVersion
+ name: '@DOY/PkgVersion'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Authority
+ name: '@DOY/Authority'
+ version: 1.006
+ -
+ class: Dist::Zilla::Plugin::PodCoverageTests
+ name: '@DOY/PodCoverageTests'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::PodSyntaxTests
+ name: '@DOY/PodSyntaxTests'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::NoTabsTests
+ name: '@DOY/NoTabsTests'
+ version: 0.01
+ -
+ class: Dist::Zilla::Plugin::EOLTests
+ name: '@DOY/EOLTests'
+ version: 0.02
+ -
+ class: Dist::Zilla::Plugin::Test::Compile
+ name: '@DOY/Test::Compile'
+ version: 2.002
+ -
+ class: Dist::Zilla::Plugin::Metadata
+ name: '@DOY/Metadata'
+ version: 3.03
+ -
+ class: Dist::Zilla::Plugin::MetaResources
+ name: '@DOY/MetaResources'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Git::Check
+ name: '@DOY/Git::Check'
+ version: 2.013
+ -
+ class: Dist::Zilla::Plugin::Git::Commit
+ name: '@DOY/Git::Commit'
+ version: 2.013
+ -
+ class: Dist::Zilla::Plugin::Git::Tag
+ name: '@DOY/Git::Tag'
+ version: 2.013
+ -
+ class: Dist::Zilla::Plugin::Git::NextVersion
+ name: '@DOY/Git::NextVersion'
+ version: 2.013
+ -
+ class: Dist::Zilla::Plugin::PodWeaver
+ name: '@DOY/PodWeaver'
+ version: 3.101641
+ -
+ class: Dist::Zilla::Plugin::UploadToCPAN
+ name: '@DOY/UploadToCPAN'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::AutoPrereqs
+ name: AutoPrereqs
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Prereqs
+ config:
+ Dist::Zilla::Plugin::Prereqs:
+ phase: develop
+ type: requires
+ name: DevelopRequires
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::PruneFiles
+ name: PruneFiles
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ContributorsFromGit
+ name: ContributorsFromGit
+ version: 0.006
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':InstallModules'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':IncModules'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':TestFiles'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':ExecFiles'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':ShareFiles'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':MainModule'
+ version: 4.300034
+ zilla:
+ class: Dist::Zilla::Dist::Builder
+ config:
+ is_trial: 0
+ version: 4.300034
+x_authority: cpan:DOY
+x_contributors:
+ - 'Dave Rolsky <autarch@urth.org>'
+ - 'Florian Ragwitz <rafl@debian.org>'
+ - 'Justin Hunter <justin.d.hunter@gmail.com>'
+ - 'Tim Bunce <Tim.Bunce@pobox.com>'
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..f291f33
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,78 @@
+
+use strict;
+use warnings;
+
+use 5.008001;
+
+use ExtUtils::MakeMaker 6.30;
+
+
+
+my %WriteMakefileArgs = (
+ "ABSTRACT" => "faster and more correct implementation of the Package::Stash API",
+ "AUTHOR" => "Jesse Luehrs <doy\@tozt.net>",
+ "BUILD_REQUIRES" => {},
+ "CONFIGURE_REQUIRES" => {
+ "ExtUtils::MakeMaker" => "6.30"
+ },
+ "DISTNAME" => "Package-Stash-XS",
+ "EXE_FILES" => [],
+ "LICENSE" => "perl",
+ "NAME" => "Package::Stash::XS",
+ "PREREQ_PM" => {
+ "XSLoader" => 0,
+ "strict" => 0,
+ "warnings" => 0
+ },
+ "TEST_REQUIRES" => {
+ "B" => 0,
+ "File::Find" => 0,
+ "File::Temp" => 0,
+ "Scalar::Util" => 0,
+ "Symbol" => 0,
+ "Test::Fatal" => 0,
+ "Test::More" => "0.88",
+ "Test::Requires" => 0,
+ "base" => 0,
+ "constant" => 0
+ },
+ "VERSION" => "0.28",
+ "test" => {
+ "TESTS" => "t/*.t"
+ }
+);
+
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) {
+ my $tr = delete $WriteMakefileArgs{TEST_REQUIRES};
+ my $br = $WriteMakefileArgs{BUILD_REQUIRES};
+ for my $mod ( keys %$tr ) {
+ if ( exists $br->{$mod} ) {
+ $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod};
+ }
+ else {
+ $br->{$mod} = $tr->{$mod};
+ }
+ }
+}
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) {
+ my $br = delete $WriteMakefileArgs{BUILD_REQUIRES};
+ my $pp = $WriteMakefileArgs{PREREQ_PM};
+ for my $mod ( keys %$br ) {
+ if ( exists $pp->{$mod} ) {
+ $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod};
+ }
+ else {
+ $pp->{$mod} = $br->{$mod};
+ }
+ }
+}
+
+delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
+ unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
+
+WriteMakefile(%WriteMakefileArgs);
+
+
+
diff --git a/README b/README
new file mode 100644
index 0000000..c751e31
--- /dev/null
+++ b/README
@@ -0,0 +1,13 @@
+
+
+This archive contains the distribution Package-Stash-XS,
+version 0.28:
+
+ faster and more correct implementation of the Package::Stash API
+
+This software is copyright (c) 2013 by Jesse Luehrs.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+
diff --git a/XS.xs b/XS.xs
new file mode 100644
index 0000000..d7f6c9a
--- /dev/null
+++ b/XS.xs
@@ -0,0 +1,993 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "ppport.h"
+
+#ifndef gv_fetchsv
+#define gv_fetchsv(n,f,t) gv_fetchpv(SvPV_nolen(n), f, t)
+#endif
+
+#ifndef mro_method_changed_in
+#define mro_method_changed_in(x) PL_sub_generation++
+#endif
+
+#ifndef HvENAME
+#define HvENAME HvNAME
+#endif
+
+#ifndef hv_name_set
+#define hv_name_set(stash, name, namelen, flags) \
+ (HvNAME(stash) = savepvn(name, namelen))
+#endif
+
+#ifdef newSVhek
+#define newSVhe(he) newSVhek(HeKEY_hek(he))
+#else
+#define newSVhe(he) newSVpv(HePV(he, PL_na), 0)
+#endif
+
+#ifndef GvCV_set
+#define GvCV_set(gv, cv) (GvCV(gv) = (CV*)(cv))
+#endif
+
+#ifndef MUTABLE_PTR
+#define MUTABLE_PTR(p) ((void *) (p))
+#endif
+
+#ifndef MUTABLE_SV
+#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
+#endif
+
+#ifndef SVT_SCALAR
+#define SVT_SCALAR(svt) (svt <= SVt_PVLV)
+#endif
+
+#ifndef SVT_ARRAY
+#define SVT_ARRAY(svt) (svt == SVt_PVAV)
+#endif
+
+#ifndef SVT_HASH
+#define SVT_HASH(svt) (svt == SVt_PVHV)
+#endif
+
+#ifndef SVT_CODE
+#define SVT_CODE(svt) (svt == SVt_PVCV)
+#endif
+
+#ifndef SVT_IO
+#define SVT_IO(svt) (svt == SVt_PVIO)
+#endif
+
+#ifndef SVT_FORMAT
+#define SVT_FORMAT(svt) (svt == SVt_PVFM)
+#endif
+
+/* HACK: scalar slots are always populated on perl < 5.10, so treat undef
+ * as nonexistent. this is consistent with the previous behavior of the pure
+ * perl version of this module (since this is the behavior that perl sees
+ * in all versions */
+#if PERL_VERSION < 10
+#define GvSVOK(g) (GvSV(g) && SvTYPE(GvSV(g)) != SVt_NULL)
+#else
+#define GvSVOK(g) GvSV(g)
+#endif
+
+#define GvAVOK(g) GvAV(g)
+#define GvHVOK(g) GvHV(g)
+#define GvCVOK(g) GvCVu(g) /* XXX: should this really be GvCVu? or GvCV? */
+#define GvIOOK(g) GvIO(g)
+
+/* see above - don't let scalar slots become unpopulated, this breaks
+ * assumptions in core */
+#if PERL_VERSION < 10
+#define GvSetSV(g,v) do { \
+ SV *_v = (SV*)(v); \
+ SvREFCNT_dec(GvSV(g)); \
+ if ((GvSV(g) = _v ? _v : newSV(0))) \
+ GvIMPORTED_SV_on(g); \
+} while (0)
+#else
+#define GvSetSV(g,v) do { \
+ SvREFCNT_dec(GvSV(g)); \
+ if ((GvSV(g) = (SV*)(v))) \
+ GvIMPORTED_SV_on(g); \
+} while (0)
+#endif
+
+#define GvSetAV(g,v) do { \
+ SvREFCNT_dec(GvAV(g)); \
+ if ((GvAV(g) = (AV*)(v))) \
+ GvIMPORTED_AV_on(g); \
+} while (0)
+#define GvSetHV(g,v) do { \
+ SvREFCNT_dec(GvHV(g)); \
+ if ((GvHV(g) = (HV*)(v))) \
+ GvIMPORTED_HV_on(g); \
+} while (0)
+#define GvSetCV(g,v) do { \
+ SvREFCNT_dec(GvCV(g)); \
+ if ((GvCV_set(g, (CV*)(v)))) { \
+ GvIMPORTED_CV_on(g); \
+ GvASSUMECV_on(g); \
+ } \
+ GvCVGEN(g) = 0; \
+ mro_method_changed_in(GvSTASH(g)); \
+} while (0)
+#define GvSetIO(g,v) do { \
+ SvREFCNT_dec(GvIO(g)); \
+ GvIOp(g) = (IO*)(v); \
+} while (0)
+
+typedef enum {
+ VAR_NONE = 0,
+ VAR_SCALAR,
+ VAR_ARRAY,
+ VAR_HASH,
+ VAR_CODE,
+ VAR_IO,
+ VAR_GLOB, /* TODO: unimplemented */
+ VAR_FORMAT /* TODO: unimplemented */
+} vartype_t;
+
+typedef struct {
+ vartype_t type;
+ SV *name;
+} varspec_t;
+
+static U32 name_hash, namespace_hash, type_hash;
+static SV *name_key, *namespace_key, *type_key;
+static REGEXP *valid_module_regex;
+
+static const char *vartype_to_string(vartype_t type)
+{
+ switch (type) {
+ case VAR_SCALAR:
+ return "SCALAR";
+ case VAR_ARRAY:
+ return "ARRAY";
+ case VAR_HASH:
+ return "HASH";
+ case VAR_CODE:
+ return "CODE";
+ case VAR_IO:
+ return "IO";
+ default:
+ return "unknown";
+ }
+}
+
+static I32 vartype_to_svtype(vartype_t type)
+{
+ switch (type) {
+ case VAR_SCALAR:
+ return SVt_PV; /* or whatever */
+ case VAR_ARRAY:
+ return SVt_PVAV;
+ case VAR_HASH:
+ return SVt_PVHV;
+ case VAR_CODE:
+ return SVt_PVCV;
+ case VAR_IO:
+ return SVt_PVIO;
+ default:
+ return SVt_NULL;
+ }
+}
+
+static vartype_t string_to_vartype(char *vartype)
+{
+ if (strEQ(vartype, "SCALAR")) {
+ return VAR_SCALAR;
+ }
+ else if (strEQ(vartype, "ARRAY")) {
+ return VAR_ARRAY;
+ }
+ else if (strEQ(vartype, "HASH")) {
+ return VAR_HASH;
+ }
+ else if (strEQ(vartype, "CODE")) {
+ return VAR_CODE;
+ }
+ else if (strEQ(vartype, "IO")) {
+ return VAR_IO;
+ }
+ else {
+ croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO', not '%s'", vartype);
+ }
+}
+
+static int _is_valid_module_name(SV *package)
+{
+ char *buf;
+ STRLEN len;
+ SV *sv;
+
+ buf = SvPV(package, len);
+
+ /* whee cargo cult */
+ sv = sv_newmortal();
+ sv_upgrade(sv, SVt_PV);
+ SvREADONLY_on(sv);
+ SvLEN(sv) = 0;
+ SvUTF8_on(sv);
+ SvPVX(sv) = buf;
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+
+ return pregexec(valid_module_regex, buf, buf + len, buf, 1, sv, 1);
+}
+
+static void _deconstruct_variable_name(SV *variable, varspec_t *varspec)
+{
+ char *varpv;
+
+ if (!SvCUR(variable))
+ croak("You must pass a variable name");
+
+ varspec->name = sv_2mortal(newSVsv(variable));
+
+ varpv = SvPV_nolen(varspec->name);
+ switch (varpv[0]) {
+ case '$':
+ varspec->type = VAR_SCALAR;
+ sv_chop(varspec->name, &varpv[1]);
+ break;
+ case '@':
+ varspec->type = VAR_ARRAY;
+ sv_chop(varspec->name, &varpv[1]);
+ break;
+ case '%':
+ varspec->type = VAR_HASH;
+ sv_chop(varspec->name, &varpv[1]);
+ break;
+ case '&':
+ varspec->type = VAR_CODE;
+ sv_chop(varspec->name, &varpv[1]);
+ break;
+ default:
+ varspec->type = VAR_IO;
+ break;
+ }
+}
+
+static void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
+{
+ HE *val;
+
+ val = hv_fetch_ent(variable, name_key, 0, name_hash);
+ if (!val)
+ croak("The 'name' key is required in variable specs");
+
+ varspec->name = sv_2mortal(newSVsv(HeVAL(val)));
+
+ val = hv_fetch_ent(variable, type_key, 0, type_hash);
+ if (!val)
+ croak("The 'type' key is required in variable specs");
+
+ varspec->type = string_to_vartype(SvPV_nolen(HeVAL(val)));
+}
+
+static void _check_varspec_is_valid(varspec_t *varspec)
+{
+ if (strstr(SvPV_nolen(varspec->name), "::")) {
+ croak("Variable names may not contain ::");
+ }
+}
+
+static int _valid_for_type(SV *value, vartype_t type)
+{
+ svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
+
+ switch (type) {
+ case VAR_SCALAR:
+ /* XXX is a glob a scalar? assigning a glob to the scalar slot seems
+ * to work here, but in pure perl i'm pretty sure it goes to the EGV
+ * slot, which seems more correct to me. just disable it for now
+ * i guess */
+ return SVT_SCALAR(sv_type) && sv_type != SVt_PVGV;
+ case VAR_ARRAY:
+ return SVT_ARRAY(sv_type);
+ case VAR_HASH:
+ return SVT_HASH(sv_type);
+ case VAR_CODE:
+ return SVT_CODE(sv_type);
+ case VAR_IO:
+ return SVT_IO(sv_type);
+ default:
+ return 0;
+ }
+}
+
+static HV *_get_namespace(SV *self)
+{
+ dSP;
+ SV *ret;
+
+ PUSHMARK(SP);
+ XPUSHs(self);
+ PUTBACK;
+
+ call_method("namespace", G_SCALAR);
+
+ SPAGAIN;
+ ret = POPs;
+ PUTBACK;
+
+ return (HV*)SvRV(ret);
+}
+
+static SV *_get_name(SV *self)
+{
+ dSP;
+ SV *ret;
+
+ PUSHMARK(SP);
+ XPUSHs(self);
+ PUTBACK;
+
+ call_method("name", G_SCALAR);
+
+ SPAGAIN;
+ ret = POPs;
+ PUTBACK;
+
+ return ret;
+}
+
+static void _real_gv_init(GV *gv, HV *stash, SV *name)
+{
+ char *name_pv;
+ STRLEN name_len;
+
+ name_pv = SvPV(name, name_len);
+ if (!HvENAME(stash)) {
+ hv_name_set(stash, "__ANON__", 8, 0);
+ }
+ gv_init(gv, stash, name_pv, name_len, 1);
+
+ /* XXX: copied and pasted from gv_fetchpvn_flags and such */
+ /* ignoring the stuff for CORE:: and main:: for now, and also
+ * ignoring the GvMULTI_on bits, since we pass 1 to gv_init above */
+ switch (name_pv[0]) {
+ case 'I':
+ if (strEQ(&name_pv[1], "SA")) {
+ AV *av;
+
+ av = GvAVn(gv);
+ sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
+ NULL, 0);
+ }
+ break;
+ case 'O':
+ if (strEQ(&name_pv[1], "VERLOAD")) {
+ HV *hv;
+
+ hv = GvHVn(gv);
+ hv_magic(hv, NULL, PERL_MAGIC_overload);
+ }
+ break;
+ default:
+ break;
+ }
+}
+
+static void _expand_glob(SV *self, SV *varname, HE *entry, HV *namespace,
+ int lval)
+{
+ GV *glob;
+
+ if (entry) {
+ glob = (GV*)HeVAL(entry);
+ if (isGV(glob)) {
+ croak("_expand_glob called on stash slot with expanded glob: %"SVf,
+ varname);
+ }
+ else {
+ SvREFCNT_inc(glob);
+ _real_gv_init(glob, namespace, varname);
+ if (HeVAL(entry)) {
+ SvREFCNT_dec(HeVAL(entry));
+ }
+ HeVAL(entry) = (SV*)glob;
+ }
+ }
+ else {
+ croak("_expand_glob called on nonexistent stash slot");
+ }
+}
+
+static SV *_undef_for_type(vartype_t type)
+{
+ switch (type) {
+ case VAR_SCALAR:
+ return newSV(0);
+ break;
+ case VAR_ARRAY:
+ return (SV*)newAV();
+ break;
+ case VAR_HASH:
+ return (SV*)newHV();
+ break;
+ case VAR_CODE:
+ croak("Don't know how to vivify CODE variables");
+ case VAR_IO:
+ return (SV*)newIO();
+ break;
+ default:
+ croak("Unknown type in vivification");
+ }
+}
+
+static void _add_symbol_entry(SV *self, varspec_t variable, SV *initial,
+ HE *entry, HV *namespace)
+{
+ GV *glob;
+ SV *val;
+
+ if (entry && isGV(HeVAL(entry))) {
+ glob = (GV*)HeVAL(entry);
+ }
+ else if (entry) {
+ glob = (GV*)newSV(0);
+ _real_gv_init(glob, namespace, variable.name);
+ if (HeVAL(entry)) {
+ SvREFCNT_dec(HeVAL(entry));
+ }
+ HeVAL(entry) = (SV*)glob;
+ }
+ else {
+ croak("invalid entry passed to _add_symbol_entry");
+ }
+
+ if (!initial) {
+ val = _undef_for_type(variable.type);
+ }
+ else if (SvROK(initial)) {
+ val = SvRV(initial);
+ SvREFCNT_inc_simple_void_NN(val);
+ }
+ else {
+ val = newSVsv(initial);
+ }
+
+ switch (variable.type) {
+ case VAR_SCALAR:
+ GvSetSV(glob, val);
+ break;
+ case VAR_ARRAY:
+ GvSetAV(glob, val);
+ break;
+ case VAR_HASH:
+ GvSetHV(glob, val);
+ break;
+ case VAR_CODE:
+ GvSetCV(glob, val);
+ break;
+ case VAR_IO:
+ GvSetIO(glob, val);
+ break;
+ default:
+ croak("Unknown variable type in add_symbol");
+ break;
+ }
+}
+
+static void _add_symbol(SV *self, varspec_t variable, SV *initial)
+{
+ HV *namespace;
+ HE *entry;
+
+ namespace = _get_namespace(self);
+ entry = hv_fetch_ent(namespace, variable.name, 1, 0);
+
+ _add_symbol_entry(self, variable, initial, entry, namespace);
+}
+
+static int _slot_exists(GV *glob, vartype_t type)
+{
+ switch (type) {
+ case VAR_SCALAR:
+ return GvSVOK(glob) ? 1 : 0;
+ break;
+ case VAR_ARRAY:
+ return GvAVOK(glob) ? 1 : 0;
+ break;
+ case VAR_HASH:
+ return GvHVOK(glob) ? 1 : 0;
+ break;
+ case VAR_CODE:
+ croak("Don't know how to vivify CODE variables");
+ case VAR_IO:
+ return GvIOOK(glob) ? 1 : 0;
+ break;
+ default:
+ croak("Unknown type in vivification");
+ }
+
+ return 0;
+}
+
+static SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
+{
+ HV *namespace;
+ HE *entry;
+ GV *glob;
+
+ namespace = _get_namespace(self);
+ entry = hv_fetch_ent(namespace, variable->name,
+ vivify && !hv_exists_ent(namespace, variable->name, 0),
+ 0);
+ if (!entry)
+ return NULL;
+
+ glob = (GV*)(HeVAL(entry));
+ if (!isGV(glob))
+ _expand_glob(self, variable->name, entry, namespace, vivify);
+
+ if (vivify && !_slot_exists(glob, variable->type)) {
+ _add_symbol_entry(self, *variable, NULL, entry, namespace);
+ }
+
+ switch (variable->type) {
+ case VAR_SCALAR:
+ return GvSV(glob);
+ case VAR_ARRAY:
+ return (SV*)GvAV(glob);
+ case VAR_HASH:
+ return (SV*)GvHV(glob);
+ case VAR_CODE:
+ return (SV*)GvCV(glob);
+ case VAR_IO:
+ return (SV*)GvIO(glob);
+ default:
+ return NULL;
+ }
+}
+
+MODULE = Package::Stash::XS PACKAGE = Package::Stash::XS
+
+PROTOTYPES: DISABLE
+
+SV*
+new(class, package)
+ SV *class
+ SV *package
+ PREINIT:
+ HV *instance;
+ CODE:
+ if (SvPOK(package)) {
+ if (!_is_valid_module_name(package))
+ croak("%s is not a module name", SvPV_nolen(package));
+
+ instance = newHV();
+
+ if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package), 0)) {
+ SvREFCNT_dec(package);
+ SvREFCNT_dec(instance);
+ croak("Couldn't initialize the 'name' key, hv_store failed");
+ }
+ }
+ else if (SvROK(package) && SvTYPE(SvRV(package)) == SVt_PVHV) {
+#if PERL_VERSION < 10
+ croak("The XS implementation of Package::Stash does not support "
+ "anonymous stashes before perl 5.10");
+#else
+ instance = newHV();
+
+ if (!hv_store(instance, "namespace", 9, SvREFCNT_inc_simple_NN(package), 0)) {
+ SvREFCNT_dec(package);
+ SvREFCNT_dec(instance);
+ croak("Couldn't initialize the 'namespace' key, hv_store failed");
+ }
+#endif
+ }
+ else {
+ croak("Package::Stash->new must be passed the name of the package to access");
+ }
+
+ RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
+ OUTPUT:
+ RETVAL
+
+SV*
+name(self)
+ SV *self
+ PREINIT:
+ HE *slot;
+ CODE:
+ if (!sv_isobject(self))
+ croak("Can't call name as a class method");
+ if (slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash)) {
+ RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
+ }
+ else {
+ croak("Can't get the name of an anonymous package");
+ }
+ OUTPUT:
+ RETVAL
+
+SV*
+namespace(self)
+ SV *self
+ PREINIT:
+ HE *slot;
+ SV *package_name;
+ CODE:
+ if (!sv_isobject(self))
+ croak("Can't call namespace as a class method");
+#if PERL_VERSION < 10
+ package_name = _get_name(self);
+ RETVAL = newRV_inc((SV*)gv_stashpv(SvPV_nolen(package_name), GV_ADD));
+#else
+ slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
+ if (slot) {
+ RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
+ }
+ else {
+ HV *namespace;
+ SV *nsref;
+
+ package_name = _get_name(self);
+ namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
+ nsref = newRV_inc((SV*)namespace);
+ sv_rvweaken(nsref);
+ if (!hv_store((HV*)SvRV(self), "namespace", 9, nsref, 0)) {
+ SvREFCNT_dec(nsref);
+ SvREFCNT_dec(self);
+ croak("Couldn't initialize the 'namespace' key, hv_store failed");
+ }
+ RETVAL = SvREFCNT_inc_simple_NN(nsref);
+ }
+#endif
+ OUTPUT:
+ RETVAL
+
+void
+add_symbol(self, variable, initial=NULL, ...)
+ SV *self
+ varspec_t variable
+ SV *initial
+ CODE:
+ if (initial && !_valid_for_type(initial, variable.type))
+ croak("%s is not of type %s",
+ SvPV_nolen(initial), vartype_to_string(variable.type));
+
+ if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
+ int i;
+ char *filename = NULL;
+ I32 first_line_num = -1, last_line_num = -1;
+ SV *dbval, *name;
+ HV *dbsub;
+
+ if ((items - 3) % 2)
+ croak("add_symbol: Odd number of elements in %%opts");
+
+ for (i = 3; i < items; i += 2) {
+ char *key;
+ key = SvPV_nolen(ST(i));
+ if (strEQ(key, "filename")) {
+ if (!SvPOK(ST(i + 1)))
+ croak("add_symbol: filename must be a string");
+ filename = SvPV_nolen(ST(i + 1));
+ }
+ else if (strEQ(key, "first_line_num")) {
+ if (!SvIOK(ST(i + 1)))
+ croak("add_symbol: first_line_num must be an integer");
+ first_line_num = SvIV(ST(i + 1));
+ }
+ else if (strEQ(key, "last_line_num")) {
+ if (!SvIOK(ST(i + 1)))
+ croak("add_symbol: last_line_num must be an integer");
+ last_line_num = SvIV(ST(i + 1));
+ }
+ }
+
+ if (!filename || first_line_num == -1) {
+ if (!filename)
+ filename = CopFILE(PL_curcop);
+ if (first_line_num == -1)
+ first_line_num = PL_curcop->cop_line;
+ }
+
+ if (last_line_num == -1)
+ last_line_num = first_line_num;
+
+ name = newSVsv(_get_name(self));
+ sv_catpvs(name, "::");
+ sv_catsv(name, variable.name);
+
+ /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
+ dbsub = get_hv("DB::sub", 1);
+ dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
+ if (!hv_store_ent(dbsub, name, dbval, 0)) {
+ warn("Failed to update $DB::sub for subroutine %s",
+ SvPV_nolen(name));
+ SvREFCNT_dec(dbval);
+ }
+
+ SvREFCNT_dec(name);
+ }
+
+ _add_symbol(self, variable, initial);
+
+void
+remove_glob(self, name)
+ SV *self
+ SV *name
+ CODE:
+ hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0);
+
+int
+has_symbol(self, variable)
+ SV *self
+ varspec_t variable
+ PREINIT:
+ HV *namespace;
+ HE *entry;
+ SV *val;
+ CODE:
+ namespace = _get_namespace(self);
+ entry = hv_fetch_ent(namespace, variable.name, 0, 0);
+ if (!entry)
+ XSRETURN_UNDEF;
+
+ val = HeVAL(entry);
+ if (isGV(val)) {
+ GV *glob = (GV*)val;
+ switch (variable.type) {
+ case VAR_SCALAR:
+ RETVAL = GvSVOK(glob) ? 1 : 0;
+ break;
+ case VAR_ARRAY:
+ RETVAL = GvAVOK(glob) ? 1 : 0;
+ break;
+ case VAR_HASH:
+ RETVAL = GvHVOK(glob) ? 1 : 0;
+ break;
+ case VAR_CODE:
+ RETVAL = GvCVOK(glob) ? 1 : 0;
+ break;
+ case VAR_IO:
+ RETVAL = GvIOOK(glob) ? 1 : 0;
+ break;
+ default:
+ croak("Unknown variable type in has_symbol");
+ }
+ }
+ else {
+ RETVAL = (variable.type == VAR_CODE);
+ }
+ OUTPUT:
+ RETVAL
+
+SV*
+get_symbol(self, variable)
+ SV *self
+ varspec_t variable
+ PREINIT:
+ SV *val;
+ CODE:
+ val = _get_symbol(self, &variable, 0);
+ if (!val)
+ XSRETURN_UNDEF;
+ RETVAL = newRV_inc(val);
+ OUTPUT:
+ RETVAL
+
+SV*
+get_or_add_symbol(self, variable)
+ SV *self
+ varspec_t variable
+ PREINIT:
+ SV *val;
+ CODE:
+ val = _get_symbol(self, &variable, 1);
+ if (!val)
+ XSRETURN_UNDEF;
+ RETVAL = newRV_inc(val);
+ OUTPUT:
+ RETVAL
+
+void
+remove_symbol(self, variable)
+ SV *self
+ varspec_t variable
+ PREINIT:
+ HV *namespace;
+ HE *entry;
+ SV *val;
+ CODE:
+ namespace = _get_namespace(self);
+ entry = hv_fetch_ent(namespace, variable.name, 0, 0);
+ if (!entry)
+ XSRETURN_EMPTY;
+
+ val = HeVAL(entry);
+ if (isGV(val)) {
+ GV *glob = (GV*)val;
+ switch (variable.type) {
+ case VAR_SCALAR:
+ GvSetSV(glob, NULL);
+ break;
+ case VAR_ARRAY:
+ GvSetAV(glob, NULL);
+ break;
+ case VAR_HASH:
+ GvSetHV(glob, NULL);
+ break;
+ case VAR_CODE:
+ GvSetCV(glob, NULL);
+ break;
+ case VAR_IO:
+ GvSetIO(glob, NULL);
+ break;
+ default:
+ croak("Unknown variable type in remove_symbol");
+ break;
+ }
+ }
+ else {
+ if (variable.type == VAR_CODE) {
+ hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
+ }
+ }
+
+void
+list_all_symbols(self, vartype=VAR_NONE)
+ SV *self
+ vartype_t vartype
+ PPCODE:
+ if (vartype == VAR_NONE) {
+ HV *namespace;
+ HE *entry;
+ int keys;
+
+ namespace = _get_namespace(self);
+ keys = hv_iterinit(namespace);
+ EXTEND(SP, keys);
+ while ((entry = hv_iternext(namespace))) {
+#if PERL_VERSION < 10
+ char *pv;
+ STRLEN len;
+ pv = HePV(entry, len);
+ if (strnEQ(entry, "::ISA::CACHE::", len)) {
+ continue;
+ }
+#endif
+ mPUSHs(newSVhe(entry));
+ }
+ }
+ else {
+ HV *namespace;
+ SV *val;
+ char *key;
+ I32 len;
+
+ namespace = _get_namespace(self);
+ hv_iterinit(namespace);
+ while ((val = hv_iternextsv(namespace, &key, &len))) {
+ GV *gv = (GV*)val;
+#if PERL_VERSION < 10
+ if (vartype == VAR_SCALAR && strnEQ(key, "::ISA::CACHE::", len)) {
+ continue;
+ }
+#endif
+ if (isGV(gv)) {
+ switch (vartype) {
+ case VAR_SCALAR:
+ if (GvSVOK(val))
+ mXPUSHp(key, len);
+ break;
+ case VAR_ARRAY:
+ if (GvAVOK(val))
+ mXPUSHp(key, len);
+ break;
+ case VAR_HASH:
+ if (GvHVOK(val))
+ mXPUSHp(key, len);
+ break;
+ case VAR_CODE:
+ if (GvCVOK(val))
+ mXPUSHp(key, len);
+ break;
+ case VAR_IO:
+ if (GvIOOK(val))
+ mXPUSHp(key, len);
+ break;
+ default:
+ croak("Unknown variable type in list_all_symbols");
+ }
+ }
+ else if (vartype == VAR_CODE) {
+ mXPUSHp(key, len);
+ }
+ }
+ }
+
+void
+get_all_symbols(self, vartype=VAR_NONE)
+ SV *self
+ vartype_t vartype
+ PREINIT:
+ HV *namespace, *ret;
+ HE *entry;
+ PPCODE:
+ namespace = _get_namespace(self);
+ ret = newHV();
+
+ hv_iterinit(namespace);
+ while ((entry = hv_iternext(namespace))) {
+ GV *gv = (GV*)hv_iterval(namespace, entry);
+ char *key;
+ I32 len;
+
+ key = hv_iterkey(entry, &len);
+#if PERL_VERSION < 10
+ if ((vartype == VAR_SCALAR || vartype == VAR_NONE)
+ && strnEQ(key, "::ISA::CACHE::", len)) {
+ continue;
+ }
+#endif
+
+ if (!isGV(gv)) {
+ SV *keysv = newSVpvn(key, len);
+ _expand_glob(self, keysv, entry, namespace, 0);
+ SvREFCNT_dec(keysv);
+ }
+
+ switch (vartype) {
+ case VAR_SCALAR:
+ if (GvSVOK(gv))
+ hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
+ break;
+ case VAR_ARRAY:
+ if (GvAVOK(gv))
+ hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
+ break;
+ case VAR_HASH:
+ if (GvHVOK(gv))
+ hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
+ break;
+ case VAR_CODE:
+ if (GvCVOK(gv))
+ hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
+ break;
+ case VAR_IO:
+ if (GvIOOK(gv))
+ hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
+ break;
+ case VAR_NONE:
+ hv_store(ret, key, len, SvREFCNT_inc_simple_NN((SV*)gv), 0);
+ break;
+ default:
+ croak("Unknown variable type in get_all_symbols");
+ }
+ }
+
+ mPUSHs(newRV_noinc((SV*)ret));
+
+BOOT:
+ {
+ const char *vmre = "\\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\\z";
+#if (PERL_VERSION < 9) || ((PERL_VERSION == 9) && (PERL_SUBVERSION < 5))
+ PMOP fakepmop;
+
+ fakepmop.op_pmflags = 0;
+ valid_module_regex = pregcomp(vmre, vmre + strlen(vmre), &fakepmop);
+#else
+ SV *re;
+
+ re = newSVpv(vmre, 0);
+ valid_module_regex = pregcomp(re, 0);
+#endif
+
+ name_key = newSVpvs("name");
+ PERL_HASH(name_hash, "name", 4);
+
+ namespace_key = newSVpvs("namespace");
+ PERL_HASH(namespace_hash, "namespace", 9);
+
+ type_key = newSVpvs("type");
+ PERL_HASH(type_hash, "type", 4);
+ }
diff --git a/dist.ini b/dist.ini
new file mode 100644
index 0000000..73ff99c
--- /dev/null
+++ b/dist.ini
@@ -0,0 +1,25 @@
+name = Package-Stash-XS
+author = Jesse Luehrs <doy@tozt.net>
+license = Perl_5
+copyright_holder = Jesse Luehrs
+
+[@DOY]
+:version = 0.11
+dist = Package-Stash-XS
+repository = github
+bugtracker_web = https://github.com/doy/package-stash-xs/issues
+bugtracker_mailto =
+
+[AutoPrereqs]
+skip = ^Variable::Magic$
+
+[Prereqs / DevelopRequires]
+Test::LeakTrace = 0
+
+; we maintain a Makefile.PL in the repository to be able to work without dzil,
+; but for the distribution we let dzil generate a Makefile.PL with the proper
+; dependencies and such
+[PruneFiles]
+filenames = Makefile.PL
+
+[ContributorsFromGit]
diff --git a/lib/Package/Stash/XS.pm b/lib/Package/Stash/XS.pm
new file mode 100644
index 0000000..71a86cb
--- /dev/null
+++ b/lib/Package/Stash/XS.pm
@@ -0,0 +1,111 @@
+package Package::Stash::XS;
+BEGIN {
+ $Package::Stash::XS::AUTHORITY = 'cpan:DOY';
+}
+{
+ $Package::Stash::XS::VERSION = '0.28';
+}
+use strict;
+use warnings;
+use 5.008001;
+# ABSTRACT: faster and more correct implementation of the Package::Stash API
+
+use XSLoader;
+XSLoader::load(
+ __PACKAGE__,
+ # we need to be careful not to touch $VERSION at compile time, otherwise
+ # DynaLoader will assume it's set and check against it, which will cause
+ # fail when being run in the checkout without dzil having set the actual
+ # $VERSION
+ exists $Package::Stash::XS::{VERSION}
+ ? ${ $Package::Stash::XS::{VERSION} } : (),
+);
+
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Package::Stash::XS - faster and more correct implementation of the Package::Stash API
+
+=head1 VERSION
+
+version 0.28
+
+=head1 SYNOPSIS
+
+ use Package::Stash;
+
+=head1 DESCRIPTION
+
+This is a backend for L<Package::Stash>, which provides the functionality in a
+way that's less buggy and much faster. It will be used by default if it's
+installed, and should be preferred in all environments with a compiler.
+
+=head1 BUGS
+
+No known bugs (but see the BUGS section in L<Package::Stash>).
+
+Please report any bugs to GitHub Issues at
+L<https://github.com/doy/package-stash-xs/issues>.
+
+=head1 SEE ALSO
+
+L<Package::Stash>
+
+=head1 SUPPORT
+
+You can find this documentation for this module with the perldoc command.
+
+ perldoc Package::Stash::XS
+
+You can also look for information at:
+
+=over 4
+
+=item * MetaCPAN
+
+L<https://metacpan.org/release/Package-Stash-XS>
+
+=item * Github
+
+L<https://github.com/doy/package-stash-xs>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash-XS>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Package-Stash-XS>
+
+=back
+
+=for Pod::Coverage add_symbol
+get_all_symbols
+get_or_add_symbol
+get_symbol
+has_symbol
+list_all_symbols
+name
+namespace
+new
+remove_glob
+remove_symbol
+
+=head1 AUTHOR
+
+Jesse Luehrs <doy@tozt.net>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2013 by Jesse Luehrs.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
diff --git a/ppport.h b/ppport.h
new file mode 100644
index 0000000..21b05c6
--- /dev/null
+++ b/ppport.h
@@ -0,0 +1,7258 @@
+#if 0
+<<'SKIP';
+#endif
+/*
+----------------------------------------------------------------------
+
+ ppport.h -- Perl/Pollution/Portability Version 3.20
+
+ Automatically created by Devel::PPPort running under perl 5.016000.
+
+ 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.20
+
+=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.11.5.
+
+=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-2010, 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.20;
+
+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|||
+BhkDISABLE||5.014000|
+BhkENABLE||5.014000|
+BhkENTRY_set||5.014000|
+BhkENTRY|||
+BhkFLAGS|||
+CALL_BLOCK_HOOKS|||
+CLASS|||n
+CPERLscope|5.005000||p
+CX_CURPAD_SAVE|||
+CX_CURPAD_SV|||
+CopFILEAV|5.006000||p
+CopFILEGV_set|5.006000||p
+CopFILEGV|5.006000||p
+CopFILESV|5.006000||p
+CopFILE_set|5.006000||p
+CopFILE|5.006000||p
+CopSTASHPV_set|5.006000||p
+CopSTASHPV|5.006000||p
+CopSTASH_eq|5.006000||p
+CopSTASH_set|5.006000||p
+CopSTASH|5.006000||p
+CopyD|5.009002||p
+Copy|||
+CvPADLIST|||
+CvSTASH|||
+CvWEAKOUTSIDE|||
+DEFSV_set|5.010001||p
+DEFSV|5.004050||p
+END_EXTERN_C|5.005000||p
+ENTER|||
+ERRSV|5.004050||p
+EXTEND|||
+EXTERN_C|5.005000||p
+F0convert|||n
+FREETMPS|||
+GIMME_V||5.004000|n
+GIMME|||n
+GROK_NUMERIC_RADIX|5.007002||p
+G_ARRAY|||
+G_DISCARD|||
+G_EVAL|||
+G_METHOD|5.006001||p
+G_NOARGS|||
+G_SCALAR|||
+G_VOID||5.004000|
+GetVars|||
+GvSVn|5.009003||p
+GvSV|||
+Gv_AMupdate||5.011000|
+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.010001|
+HeVAL||5.004000|
+HvENAME||5.013007|
+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|||
+LINKLIST||5.013006|
+LVRET|||
+MARK|||
+MULTICALL||5.014000|
+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|||
+OP_CLASS||5.013007|
+OP_DESC||5.007003|
+OP_NAME||5.007003|
+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.014000||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.014000||p
+PERL_MAGIC_isaelem|5.007002||p
+PERL_MAGIC_isa|5.007002||p
+PERL_MAGIC_mutex|5.014000||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.014000|
+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.014000||p
+PL_bufptr|5.014000||p
+PL_compiling|5.004050||p
+PL_copline|5.014000||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.014000||p
+PL_expect|5.014000||p
+PL_hexdigit|5.005000||p
+PL_hints|5.005000||p
+PL_in_my_stash|5.014000||p
+PL_in_my|5.014000||p
+PL_keyword_plugin||5.011002|
+PL_last_in_gv|||n
+PL_laststatval|5.005000||p
+PL_lex_state|5.014000||p
+PL_lex_stuff|5.014000||p
+PL_linestr|5.014000||p
+PL_modglobal||5.005000|n
+PL_na|5.004050||pn
+PL_no_modify|5.006000||p
+PL_ofsgv|||n
+PL_opfreehook||5.011000|n
+PL_parser|5.009005|5.009005|p
+PL_peepp||5.007003|n
+PL_perl_destruct_level|5.004050||p
+PL_perldb|5.004050||p
+PL_ppaddr|5.006000||p
+PL_rpeepp||5.013005|n
+PL_rsfp_filters|5.014000||p
+PL_rsfp|5.014000||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.014000||p
+POP_MULTICALL||5.014000|
+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.014000|
+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_nomg||5.013002|
+SvNV_set|||
+SvNVx|||
+SvNV|||
+SvOK|||
+SvOOK_offset||5.011000|
+SvOOK|||
+SvPOK_off|||
+SvPOK_only_UTF8||5.006000|
+SvPOK_only|||
+SvPOK_on|||
+SvPOKp|||
+SvPOK|||
+SvPVX_const|5.009003||p
+SvPVX_mutable|5.009003||p
+SvPVX|||
+SvPV_const|5.009003||p
+SvPV_flags_const_nolen|5.009003||p
+SvPV_flags_const|5.009003||p
+SvPV_flags_mutable|5.009003||p
+SvPV_flags|5.007002||p
+SvPV_force_flags_mutable|5.009003||p
+SvPV_force_flags_nolen|5.009003||p
+SvPV_force_flags|5.007002||p
+SvPV_force_mutable|5.009003||p
+SvPV_force_nolen|5.009003||p
+SvPV_force_nomg_nolen|5.009003||p
+SvPV_force_nomg|5.007002||p
+SvPV_force|||p
+SvPV_mutable|5.009003||p
+SvPV_nolen_const|5.009003||p
+SvPV_nolen|5.006000||p
+SvPV_nomg_const_nolen|5.009003||p
+SvPV_nomg_const|5.009003||p
+SvPV_nomg_nolen||5.013007|
+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_nomg||5.013006|
+SvTRUE|||
+SvTYPE|||
+SvUNLOCK||5.007003|
+SvUOK|5.007001|5.006000|p
+SvUPGRADE|||
+SvUTF8_off||5.006000|
+SvUTF8_on||5.006000|
+SvUTF8||5.006000|
+SvUVXx|5.004000||p
+SvUVX|5.004000||p
+SvUV_nomg|5.009001||p
+SvUV_set|5.009003||p
+SvUVx|5.004000||p
+SvUV|5.004000||p
+SvVOK||5.008001|
+SvVSTRING_mg|5.009004||p
+THIS|||n
+UNDERBAR|5.009002||p
+UTF8_MAXBYTES|5.009002||p
+UVSIZE|5.006000||p
+UVTYPE|5.006000||p
+UVXf|5.007001||p
+UVof|5.006000||p
+UVuf|5.006000||p
+UVxf|5.006000||p
+WARN_ALL|5.006000||p
+WARN_AMBIGUOUS|5.006000||p
+WARN_ASSERTIONS|5.014000||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_APIVERSION_BOOTCHECK||5.013004|
+XS_VERSION_BOOTCHECK|||
+XS_VERSION|||
+XSprePUSH|5.006000||p
+XS|||
+XopDISABLE||5.014000|
+XopENABLE||5.014000|
+XopENTRY_set||5.014000|
+XopENTRY||5.014000|
+XopFLAGS||5.013007|
+ZeroD|5.009002||p
+Zero|||
+_aMY_CXT|5.007003||p
+_append_range_to_invlist|||
+_new_invlist|||
+_pMY_CXT|5.007003||p
+_swash_inversion_hash|||
+_swash_to_invlist|||
+aMY_CXT_|5.007003||p
+aMY_CXT|5.007003||p
+aTHXR_|5.014000||p
+aTHXR|5.014000||p
+aTHX_|5.006000||p
+aTHX|5.006000||p
+add_alternate|||
+add_cp_to_invlist|||
+add_data|||n
+add_range_to_invlist|||
+add_utf16_textfilter|||
+addmad|||
+allocmy|||
+amagic_call|||
+amagic_cmp_locale|||
+amagic_cmp|||
+amagic_deref_call||5.013007|
+amagic_i_ncmp|||
+amagic_ncmp|||
+anonymise_cv_maybe|||
+any_dup|||
+ao|||
+append_madprops|||
+apply_attrs_my|||
+apply_attrs_string||5.006001|
+apply_attrs|||
+apply|||
+assert_uft8_cache_coherent|||
+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|||
+blockhook_register||5.013003|
+boolSV|5.004000||p
+boot_core_PerlIO|||
+boot_core_UNIVERSAL|||
+boot_core_mro|||
+bytes_cmp_utf8||5.013007|
+bytes_from_utf8||5.007001|
+bytes_to_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
+caller_cx||5.013005|
+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|||
+check_utf8_print|||
+checkcomma|||
+checkposixcc|||
+ckWARN|5.006000||p
+ck_entersub_args_list||5.013006|
+ck_entersub_args_proto_or_list||5.013006|
+ck_entersub_args_proto||5.013006|
+ck_warner_d||5.011001|v
+ck_warner||5.011001|v
+ckwarn_common|||
+ckwarn_d||5.009003|
+ckwarn||5.009003|
+cl_and|||n
+cl_anything|||n
+cl_init|||n
+cl_is_anything|||n
+cl_or|||n
+clear_placeholders|||
+clone_params_del|||n
+clone_params_new|||n
+closest_cop|||
+convert|||
+cop_free|||
+cop_hints_2hv||5.013007|
+cop_hints_fetch_pvn||5.013007|
+cop_hints_fetch_pvs||5.013007|
+cop_hints_fetch_pv||5.013007|
+cop_hints_fetch_sv||5.013007|
+cophh_2hv||5.013007|
+cophh_copy||5.013007|
+cophh_delete_pvn||5.013007|
+cophh_delete_pvs||5.013007|
+cophh_delete_pv||5.013007|
+cophh_delete_sv||5.013007|
+cophh_fetch_pvn||5.013007|
+cophh_fetch_pvs||5.013007|
+cophh_fetch_pv||5.013007|
+cophh_fetch_sv||5.013007|
+cophh_free||5.013007|
+cophh_new_empty||5.014000|
+cophh_store_pvn||5.013007|
+cophh_store_pvs||5.013007|
+cophh_store_pv||5.013007|
+cophh_store_sv||5.013007|
+cr_textfilter|||
+create_eval_scope|||
+croak_no_modify||5.013003|
+croak_nocontext|||vn
+croak_sv||5.013001|
+croak_xs_usage||5.010001|
+croak|||v
+csighandler||5.009003|n
+curmad|||
+curse|||
+custom_op_desc||5.007003|
+custom_op_name||5.007003|
+custom_op_register||5.013007|
+custom_op_xop||5.013007|
+cv_ckproto_len|||
+cv_clone|||
+cv_const_sv||5.004000|
+cv_dump|||
+cv_get_call_checker||5.013006|
+cv_set_call_checker||5.013006|
+cv_undef|||
+cvgv_set|||
+cvstash_set|||
+cx_dump||5.005000|
+cx_dup|||
+cxinc|||
+dAXMARK|5.009003||p
+dAX|5.007002||p
+dITEMS|5.007002||p
+dMARK|||
+dMULTICALL||5.009003|
+dMY_CXT_SV|5.007003||p
+dMY_CXT|5.007003||p
+dNOOP|5.006000||p
+dORIGMARK|||
+dSP|||
+dTHR|5.004050||p
+dTHXR|5.014000||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|n
+deprecate_commaless_var_list|||
+despatch_signals||5.007001|
+destroy_matcher|||
+die_nocontext|||vn
+die_sv||5.013001|
+die_unwind|||
+die|||v
+dirp_dup|||
+div128|||
+djSP|||
+do_aexec5|||
+do_aexec|||
+do_aspawn|||
+do_binmode||5.004050|
+do_chomp|||
+do_close|||
+do_delete_local|||
+do_dump_pad|||
+do_eof|||
+do_exec3|||
+do_execfree|||
+do_exec|||
+do_gv_dump||5.006000|
+do_gvgv_dump||5.006000|
+do_hv_dump||5.006000|
+do_ipcctl|||
+do_ipcget|||
+do_join|||
+do_magic_dump||5.006000|
+do_msgrcv|||
+do_msgsnd|||
+do_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_perl|||
+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_perl|||
+dump_packsubs||5.006000|
+dump_sub_perl|||
+dump_sub||5.006000|
+dump_sv_child|||
+dump_trie_interim_list|||
+dump_trie_interim_table|||
+dump_trie|||
+dump_vindent||5.006000|
+dumpuntil|||
+dup_attrlist|||
+emulate_cop_io|||
+eval_pv|5.006000||p
+eval_sv|5.006000||p
+exec_failed|||
+expect_number|||
+fbm_compile||5.005000|
+fbm_instr||5.005000|
+feature_is_enabled|||
+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_rundefsv||5.013002|
+find_script|||
+find_uninit_var|||
+first_symbol|||n
+foldEQ_latin1||5.013008|n
+foldEQ_locale||5.013002|n
+foldEQ_utf8_flags||5.013010|
+foldEQ_utf8||5.013002|
+foldEQ||5.013002|n
+fold_constants|||
+forbid_setid|||
+force_ident|||
+force_list|||
+force_next|||
+force_strict_version|||
+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_aux_mg|||
+get_av|5.006000||p
+get_context||5.006000|n
+get_cvn_flags|5.009005||p
+get_cvs|5.011000||p
+get_cv|5.006000||p
+get_db_sub|||
+get_debug_opts|||
+get_hash_seed|||
+get_hv|5.006000||p
+get_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_bslash_c|||
+grok_bslash_o|||
+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_add_by_type||5.011000|
+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||p
+gv_fullname3||5.004000|
+gv_fullname4||5.006001|
+gv_fullname|||
+gv_get_super_pkg|||
+gv_handler||5.007001|
+gv_init_sv|||
+gv_init|||
+gv_magicalize_isa|||
+gv_magicalize_overload|||
+gv_name_set||5.009004|
+gv_stashpvn|5.004000||p
+gv_stashpvs|5.009003||p
+gv_stashpv|||
+gv_stashsv|||
+gv_try_downgrade|||
+he_dup|||
+hek_dup|||
+hfreeentries|||
+hsplit|||
+hv_assert|||
+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||5.009004|
+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_ename_add|||
+hv_ename_delete|||
+hv_exists_ent||5.004000|
+hv_exists|||
+hv_fetch_ent||5.004000|
+hv_fetchs|5.009003||p
+hv_fetch|||
+hv_fill||5.013002|
+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_flags|||
+hv_undef|||
+ibcmp_locale||5.004000|
+ibcmp_utf8||5.007003|
+ibcmp|||
+incline|||
+incpush_if_exists|||
+incpush_use_sep|||
+incpush|||
+ingroup|||
+init_argv_symbols|||
+init_dbargs|||
+init_debugger|||
+init_global_struct|||
+init_i18nl10n||5.006000|
+init_i18nl14n||5.006000|
+init_ids|||
+init_interp|||
+init_main_stash|||
+init_perllib|||
+init_postdump_symbols|||
+init_predump_symbols|||
+init_stacks||5.005000|
+init_tm||5.007002|
+instr|||n
+intro_my|||
+intuit_method|||
+intuit_more|||
+invert|||
+invlist_array|||
+invlist_destroy|||
+invlist_extend|||
+invlist_intersection|||
+invlist_len|||
+invlist_max|||
+invlist_set_array|||
+invlist_set_len|||
+invlist_set_max|||
+invlist_trim|||
+invlist_union|||
+invoke_exception_hook|||
+io_close|||
+isALNUMC|5.006000||p
+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|||
+isOCTAL||5.013005|
+isPRINT|5.004000||p
+isPSXSPC|5.006001||p
+isPUNCT|5.006000||p
+isSPACE|||
+isUPPER|||
+isWORDCHAR||5.013006|
+isXDIGIT|5.006000||p
+is_an_int|||
+is_ascii_string||5.011000|n
+is_gv_magical_sv|||
+is_handle_constructor|||n
+is_inplace_av|||
+is_list_assignment|||
+is_lvalue_sub||5.007001|
+is_uni_alnum_lc||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_X_LVT|||
+is_utf8_X_LV_LVT_V|||
+is_utf8_X_LV|||
+is_utf8_X_L|||
+is_utf8_X_T|||
+is_utf8_X_V|||
+is_utf8_X_begin|||
+is_utf8_X_extend|||
+is_utf8_X_non_hangul|||
+is_utf8_X_prepend|||
+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|n
+is_utf8_cntrl||5.006000|
+is_utf8_common|||
+is_utf8_digit||5.006000|
+is_utf8_graph||5.006000|
+is_utf8_idcont||5.008000|
+is_utf8_idfirst||5.006000|
+is_utf8_lower||5.006000|
+is_utf8_mark||5.006000|
+is_utf8_perl_space||5.011001|
+is_utf8_perl_word||5.011001|
+is_utf8_posix_digit||5.011001|
+is_utf8_print||5.006000|
+is_utf8_punct||5.006000|
+is_utf8_space||5.006000|
+is_utf8_string_loclen||5.009003|n
+is_utf8_string_loc||5.008001|n
+is_utf8_string||5.006001|n
+is_utf8_upper||5.006000|
+is_utf8_xdigit||5.006000|
+is_utf8_xidcont||5.013010|
+is_utf8_xidfirst||5.013010|
+isa_lookup|||
+items|||n
+ix|||n
+jmaybe|||
+join_exact|||
+keyword_plugin_standard|||
+keyword|||
+leave_scope|||
+lex_bufutf8||5.011002|
+lex_discard_to||5.011002|
+lex_grow_linestr||5.011002|
+lex_next_chunk||5.011002|
+lex_peek_unichar||5.011002|
+lex_read_space||5.011002|
+lex_read_to||5.011002|
+lex_read_unichar||5.011002|
+lex_start||5.009005|
+lex_stuff_pvn||5.011002|
+lex_stuff_pvs||5.013005|
+lex_stuff_pv||5.013006|
+lex_stuff_sv||5.011002|
+lex_unstuff||5.011002|
+listkids|||
+list|||
+load_module_nocontext|||vn
+load_module|5.006000||pv
+localize|||
+looks_like_bool|||
+looks_like_number|||
+lop|||
+mPUSHi|5.009002||p
+mPUSHn|5.009002||p
+mPUSHp|5.009002||p
+mPUSHs|5.010001||p
+mPUSHu|5.009002||p
+mXPUSHi|5.009002||p
+mXPUSHn|5.009002||p
+mXPUSHp|5.009002||p
+mXPUSHs|5.010001||p
+mXPUSHu|5.009002||p
+mad_free|||
+madlex|||
+madparse|||
+magic_clear_all_env|||
+magic_clearenv|||
+magic_clearhints|||
+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_methcall1|||
+magic_methcall|||v
+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|||
+memEQs|5.009005||p
+memEQ|5.004000||p
+memNEs|5.009005||p
+memNE|5.004000||p
+mem_collxfrm|||
+mem_log_common|||n
+mess_alloc|||
+mess_nocontext|||vn
+mess_sv||5.013001|
+mess||5.006000|v
+method_common|||
+mfree||5.007002|n
+mg_clear|||
+mg_copy|||
+mg_dup|||
+mg_findext||5.013008|
+mg_find|||
+mg_free_type||5.013006|
+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_clean_isarev|||
+mro_gather_and_rename|||
+mro_get_from_name||5.010001|
+mro_get_linear_isa_dfs|||
+mro_get_linear_isa||5.009005|
+mro_get_private_data||5.010001|
+mro_isa_changed_in|||
+mro_meta_dup|||
+mro_meta_init|||
+mro_method_changed_in||5.009005|
+mro_package_moved|||
+mro_register||5.010001|
+mro_set_mro||5.010001|
+mro_set_private_data||5.010001|
+mul128|||
+mulexp10|||n
+munge_qwlist_to_paren_list|||
+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_flags|||
+my_lstat||5.014000|
+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_flags|||
+my_stat||5.014000|
+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||5.013007|
+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|||
+newSVpv_share||5.013006|
+newSVpvf_nocontext|||vn
+newSVpvf||5.004000|v
+newSVpvn_flags|5.010001||p
+newSVpvn_share|5.007001||p
+newSVpvn_utf8|5.010001||p
+newSVpvn|5.004050||p
+newSVpvs_flags|5.010001||p
+newSVpvs_share|5.009003||p
+newSVpvs|5.009003||p
+newSVpv|||
+newSVrv|||
+newSVsv|||
+newSVuv|5.006000||p
+newSV|||
+newTOKEN|||
+newUNOP|||
+newWHENOP||5.009003|
+newWHILEOP||5.013007|
+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|||n
+no_bareword_allowed|||
+no_fh_allowed|||
+no_op|||
+not_a_number|||
+nothreadhook||5.008000|
+nuke_stacks|||
+num_overflow|||n
+oopsAV|||
+oopsHV|||
+op_append_elem||5.013006|
+op_append_list||5.013006|
+op_clear|||
+op_const_sv|||
+op_contextualize||5.013006|
+op_dump||5.006000|
+op_free|||
+op_getmad_weak|||
+op_getmad|||
+op_linklist||5.013006|
+op_lvalue||5.013007|
+op_null||5.007002|
+op_prepend_elem||5.013006|
+op_refcnt_dec|||
+op_refcnt_inc|||
+op_refcnt_lock||5.009002|
+op_refcnt_unlock||5.009002|
+op_scope||5.013007|
+op_xmldump|||
+open_script|||
+opt_scalarhv|||
+pMY_CXT_|5.007003||p
+pMY_CXT|5.007003||p
+pTHX_|5.006000||p
+pTHX|5.006000||p
+packWARN|5.007003||p
+pack_cat||5.007003|
+pack_rec|||
+package_version|||
+package|||
+packlist||5.008001|
+pad_add_anon|||
+pad_add_name_sv|||
+pad_add_name|||
+pad_alloc|||
+pad_block_start|||
+pad_check_dup|||
+pad_compname_type|||
+pad_findlex|||
+pad_findmy||5.011002|
+pad_fixup_inner_anons|||
+pad_free|||
+pad_leavemy|||
+pad_new|||
+pad_peg|||n
+pad_push|||
+pad_reset|||
+pad_setsv|||
+pad_sv|||
+pad_swipe|||
+pad_tidy|||
+padlist_dup|||
+parse_arithexpr||5.013008|
+parse_barestmt||5.013007|
+parse_block||5.013007|
+parse_body|||
+parse_fullexpr||5.013008|
+parse_fullstmt||5.013005|
+parse_label||5.013007|
+parse_listexpr||5.013008|
+parse_stmtseq||5.013006|
+parse_termexpr||5.013008|
+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|||
+pmop_dump||5.006000|
+pmop_xmldump|||
+pmruntime|||
+pmtrans|||
+pop_scope|||
+populate_isa|||v
+pregcomp||5.009005|
+pregexec|||
+pregfree2||5.011000|
+pregfree|||
+prepend_madprops|||
+prescan_version||5.011004|
+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_pvn|||
+refcounted_he_fetch_pvs|||
+refcounted_he_fetch_pv|||
+refcounted_he_fetch_sv|||
+refcounted_he_free|||
+refcounted_he_inc|||
+refcounted_he_new_pvn|||
+refcounted_he_new_pvs|||
+refcounted_he_new_pv|||
+refcounted_he_new_sv|||
+refcounted_he_value|||
+refkids|||
+refto|||
+ref||5.014000|
+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|||
+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|||n
+report_evil_fh|||
+report_uninit|||
+report_wrongway_fh|||
+require_pv||5.006000|
+require_tie_mod|||
+restore_magic|||
+rninstr|||n
+rpeep|||
+rsignal_restore|||
+rsignal_save|||
+rsignal_state||5.004000|
+rsignal||5.004000|
+run_body|||
+run_user_filter|||
+runops_debug||5.005000|
+runops_standard||5.005000|
+rv2cv_op_cv||5.013006|
+rvpv_dup|||
+rxres_free|||
+rxres_restore|||
+rxres_save|||
+safesyscalloc||5.006000|n
+safesysfree||5.006000|n
+safesysmalloc||5.006000|n
+safesysrealloc||5.006000|n
+same_dirent|||
+save_I16||5.004000|
+save_I32|||
+save_I8||5.006000|
+save_adelete||5.011000|
+save_aelem_flags||5.011000|
+save_aelem||5.004050|
+save_alloc||5.006000|
+save_aptr|||
+save_ary|||
+save_bool||5.008001|
+save_clearsv|||
+save_delete|||
+save_destructor_x||5.006000|
+save_destructor||5.006000|
+save_freeop|||
+save_freepv|||
+save_freesv|||
+save_generic_pvref||5.006001|
+save_generic_svref||5.005030|
+save_gp||5.004000|
+save_hash|||
+save_hdelete||5.011000|
+save_hek_flags|||n
+save_helem_flags||5.011000|
+save_helem||5.004050|
+save_hints||5.010001|
+save_hptr|||
+save_int|||
+save_item|||
+save_iv||5.005000|
+save_lines|||
+save_list|||
+save_long|||
+save_magic|||
+save_mortalizesv||5.007001|
+save_nogv|||
+save_op||5.005000|
+save_padsv_and_mortalize||5.010001|
+save_pptr|||
+save_pushi32ptr||5.010001|
+save_pushptri32ptr|||
+save_pushptrptr||5.010001|
+save_pushptr||5.010001|
+save_re_context||5.006000|
+save_scalar_at|||
+save_scalar|||
+save_set_svflags||5.009000|
+save_shared_pvref||5.007003|
+save_sptr|||
+save_svref|||
+save_vptr||5.006000|
+savepvn|||
+savepvs||5.009003|
+savepv|||
+savesharedpvn||5.009005|
+savesharedpvs||5.013006|
+savesharedpv||5.007003|
+savesharedsvpv||5.013006|
+savestack_grow_cnt||5.008001|
+savestack_grow|||
+savesvpv||5.009002|
+sawparens|||
+scalar_mod_type|||n
+scalarboolean|||
+scalarkids|||
+scalarseq|||
+scalarvoid|||
+scalar|||
+scan_bin||5.006000|
+scan_commit|||
+scan_const|||
+scan_formline|||
+scan_heredoc|||
+scan_hex|||
+scan_ident|||
+scan_inputsymbol|||
+scan_num||5.007001|
+scan_oct|||
+scan_pat|||
+scan_str|||
+scan_subst|||
+scan_trans|||
+scan_version||5.009001|
+scan_vstring||5.009005|
+scan_word|||
+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|
+set_regclass_bit_fold|||
+set_regclass_bit|||
+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.014000|
+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_flags||5.013006|
+sv_2bool|||
+sv_2cv|||
+sv_2io|||
+sv_2iuv_common|||
+sv_2iuv_non_preserve|||
+sv_2iv_flags||5.009001|
+sv_2iv|||
+sv_2mortal|||
+sv_2num|||
+sv_2nv_flags||5.013001|
+sv_2pv_flags|5.007002||p
+sv_2pv_nolen|5.006000||p
+sv_2pvbyte_nolen|5.006000||p
+sv_2pvbyte|5.006000||p
+sv_2pvutf8_nolen||5.006000|
+sv_2pvutf8||5.006000|
+sv_2pv|||
+sv_2uv_flags||5.009001|
+sv_2uv|5.004000||p
+sv_add_arena|||
+sv_add_backref|||
+sv_backoff|||
+sv_bless|||
+sv_cat_decode||5.008001|
+sv_catpv_flags||5.013006|
+sv_catpv_mg|5.004050||p
+sv_catpv_nomg||5.013006|
+sv_catpvf_mg_nocontext|||pvn
+sv_catpvf_mg|5.006000|5.004000|pv
+sv_catpvf_nocontext|||vn
+sv_catpvf||5.004000|v
+sv_catpvn_flags||5.007002|
+sv_catpvn_mg|5.004050||p
+sv_catpvn_nomg|5.007002||p
+sv_catpvn|||
+sv_catpvs_flags||5.013006|
+sv_catpvs_mg||5.013006|
+sv_catpvs_nomg||5.013006|
+sv_catpvs|5.009003||p
+sv_catpv|||
+sv_catsv_flags||5.007002|
+sv_catsv_mg|5.004050||p
+sv_catsv_nomg|5.007002||p
+sv_catsv|||
+sv_catxmlpvn|||
+sv_catxmlpv|||
+sv_catxmlsv|||
+sv_chop|||
+sv_clean_all|||
+sv_clean_objs|||
+sv_clear|||
+sv_cmp_flags||5.013006|
+sv_cmp_locale_flags||5.013006|
+sv_cmp_locale||5.004000|
+sv_cmp|||
+sv_collxfrm_flags||5.013006|
+sv_collxfrm|||
+sv_compile_2op_is_broken|||
+sv_compile_2op||5.008001|
+sv_copypv||5.007003|
+sv_dec_nomg||5.013002|
+sv_dec|||
+sv_del_backref|||
+sv_derived_from||5.004000|
+sv_destroyable||5.010000|
+sv_does||5.009004|
+sv_dump|||
+sv_dup_common|||
+sv_dup_inc_multiple|||
+sv_dup_inc|||
+sv_dup|||
+sv_eq_flags||5.013006|
+sv_eq|||
+sv_exp_grow|||
+sv_force_normal_flags||5.007001|
+sv_force_normal||5.006000|
+sv_free2|||
+sv_free_arenas|||
+sv_free|||
+sv_gets||5.004000|
+sv_grow|||
+sv_i_ncmp|||
+sv_inc_nomg||5.013002|
+sv_inc|||
+sv_insert_flags||5.010001|
+sv_insert|||
+sv_isa|||
+sv_isobject|||
+sv_iv||5.005000|
+sv_kill_backrefs|||
+sv_len_utf8||5.006000|
+sv_len|||
+sv_magic_portable|5.014000|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_flags||5.011005|
+sv_pos_u2b_forwards|||n
+sv_pos_u2b_midway|||n
+sv_pos_u2b||5.006000|
+sv_pvbyten_force||5.006000|
+sv_pvbyten||5.006000|
+sv_pvbyte||5.006000|
+sv_pvn_force_flags|5.007002||p
+sv_pvn_force|||
+sv_pvn_nomg|5.007003|5.005000|p
+sv_pvn||5.005000|
+sv_pvutf8n_force||5.006000|
+sv_pvutf8n||5.006000|
+sv_pvutf8||5.006000|
+sv_pv||5.006000|
+sv_recode_to_utf8||5.007003|
+sv_reftype|||
+sv_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_mg||5.013006|
+sv_setpvs|5.009004||p
+sv_setpv|||
+sv_setref_iv|||
+sv_setref_nv|||
+sv_setref_pvn|||
+sv_setref_pvs||5.013006|
+sv_setref_pv|||
+sv_setref_uv||5.007001|
+sv_setsv_cow|||
+sv_setsv_flags||5.007002|
+sv_setsv_mg|5.004050||p
+sv_setsv_nomg|5.007002||p
+sv_setsv|||
+sv_setuv_mg|5.004050||p
+sv_setuv|5.004000||p
+sv_tainted||5.004000|
+sv_taint||5.004000|
+sv_true||5.005000|
+sv_unglob|||
+sv_uni_display||5.007003|
+sv_unmagicext||5.013008|
+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|||
+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|||
+tied_method|||v
+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|||
+try_amagic_bin|||
+try_amagic_un|||
+uiv_2buf|||n
+unlnk|||
+unpack_rec|||
+unpack_str||5.007003|
+unpackstring||5.008001|
+unreferenced_to_tmp_stack|||
+unshare_hek_or_pvn|||
+unshare_hek|||
+unsharepvn||5.004000|
+unwind_handler_stack|||
+update_debugger_info|||
+upg_version||5.009005|
+usage|||
+utf16_textfilter|||
+utf16_to_utf8_reversed||5.006001|
+utf16_to_utf8||5.006001|
+utf8_distance||5.006000|
+utf8_hop||5.006000|
+utf8_length||5.007001|
+utf8_mg_len_cache_update|||
+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|
+vform||5.006000|
+visit|||
+vivify_defelem|||
+vivify_ref|||
+vload_module|5.006000||p
+vmess||5.006000|
+vnewSVpvf|5.006000|5.004000|p
+vnormal||5.009002|
+vnumify||5.009000|
+vstringify||5.009000|
+vverify||5.009003|
+vwarner||5.006000|
+vwarn||5.006000|
+wait4pid|||
+warn_nocontext|||vn
+warn_sv||5.013001|
+warner_nocontext|||vn
+warner|5.006000|5.004000|pv
+warn|||v
+watch|||
+whichsig|||
+with_queued_errors|||
+write_no_mem|||
+write_to_stderr|||
+xmldump_all_perl|||
+xmldump_all|||
+xmldump_attr|||
+xmldump_eval|||
+xmldump_form|||
+xmldump_indent|||v
+xmldump_packsubs_perl|||
+xmldump_packsubs|||
+xmldump_sub_perl|||
+xmldump_sub|||
+xmldump_vindent|||
+xs_apiversion_bootcheck|||
+xs_version_bootcheck|||
+yyerror|||
+yylex|||
+yyparse|||
+yyunlex|||
+yywarn|||
+);
+
+if (exists $opt{'list-unsupported'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{todo};
+ print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
+ }
+ exit 0;
+}
+
+# Scan for possible replacement candidates
+
+my(%replace, %need, %hints, %warnings, %depends);
+my $replace = 0;
+my($hint, $define, $function);
+
+sub find_api
+{
+ my $code = shift;
+ $code =~ s{
+ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
+ | "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
+ grep { exists $API{$_} } $code =~ /(\w+)/mg;
+}
+
+while (<DATA>) {
+ if ($hint) {
+ my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
+ if (m{^\s*\*\s(.*?)\s*$}) {
+ for (@{$hint->[1]}) {
+ $h->{$_} ||= ''; # suppress warning with older perls
+ $h->{$_} .= "$1\n";
+ }
+ }
+ else { undef $hint }
+ }
+
+ $hint = [$1, [split /,?\s+/, $2]]
+ if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
+
+ if ($define) {
+ if ($define->[1] =~ /\\$/) {
+ $define->[1] .= $_;
+ }
+ else {
+ if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
+ my @n = find_api($define->[1]);
+ push @{$depends{$define->[0]}}, @n if @n
+ }
+ undef $define;
+ }
+ }
+
+ $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
+
+ if ($function) {
+ if (/^}/) {
+ if (exists $API{$function->[0]}) {
+ my @n = find_api($function->[1]);
+ push @{$depends{$function->[0]}}, @n if @n
+ }
+ undef $function;
+ }
+ else {
+ $function->[1] .= $_;
+ }
+ }
+
+ $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
+
+ $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
+ $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
+ $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
+ $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
+
+ if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
+ my @deps = map { s/\s+//g; $_ } split /,/, $3;
+ my $d;
+ for $d (map { s/\s+//g; $_ } split /,/, $1) {
+ push @{$depends{$d}}, @deps;
+ }
+ }
+
+ $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
+}
+
+for (values %depends) {
+ my %s;
+ $_ = [sort grep !$s{$_}++, @$_];
+}
+
+if (exists $opt{'api-info'}) {
+ my $f;
+ my $count = 0;
+ my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $f =~ /$match/;
+ print "\n=== $f ===\n\n";
+ my $info = 0;
+ if ($API{$f}{base} || $API{$f}{todo}) {
+ my $base = format_version($API{$f}{base} || $API{$f}{todo});
+ print "Supported at least starting from perl-$base.\n";
+ $info++;
+ }
+ if ($API{$f}{provided}) {
+ my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
+ print "Support by $ppport provided back to perl-$todo.\n";
+ print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
+ print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
+ print "\n$hints{$f}" if exists $hints{$f};
+ print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
+ $info++;
+ }
+ print "No portability information available.\n" unless $info;
+ $count++;
+ }
+ $count or print "Found no API matching '$opt{'api-info'}'.";
+ print "\n";
+ exit 0;
+}
+
+if (exists $opt{'list-provided'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{provided};
+ my @flags;
+ push @flags, 'explicit' if exists $need{$f};
+ push @flags, 'depend' if exists $depends{$f};
+ push @flags, 'hint' if exists $hints{$f};
+ push @flags, 'warning' if exists $warnings{$f};
+ my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
+ print "$f$flags\n";
+ }
+ exit 0;
+}
+
+my @files;
+my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
+my $srcext = join '|', map { quotemeta $_ } @srcext;
+
+if (@ARGV) {
+ my %seen;
+ for (@ARGV) {
+ if (-e) {
+ if (-f) {
+ push @files, $_ unless $seen{$_}++;
+ }
+ else { warn "'$_' is not a file.\n" }
+ }
+ else {
+ my @new = grep { -f } glob $_
+ or warn "'$_' does not exist.\n";
+ push @files, grep { !$seen{$_}++ } @new;
+ }
+ }
+}
+else {
+ eval {
+ require File::Find;
+ File::Find::find(sub {
+ $File::Find::name =~ /($srcext)$/i
+ and push @files, $File::Find::name;
+ }, '.');
+ };
+ if ($@) {
+ @files = map { glob "*$_" } @srcext;
+ }
+}
+
+if (!@ARGV || $opt{filter}) {
+ my(@in, @out);
+ my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
+ for (@files) {
+ my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
+ push @{ $out ? \@out : \@in }, $_;
+ }
+ if (@ARGV && @out) {
+ warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
+ }
+ @files = @in;
+}
+
+die "No input files given!\n" unless @files;
+
+my(%files, %global, %revreplace);
+%revreplace = reverse %replace;
+my $filename;
+my $patch_opened = 0;
+
+for $filename (@files) {
+ unless (open IN, "<$filename") {
+ warn "Unable to read from $filename: $!\n";
+ next;
+ }
+
+ info("Scanning $filename ...");
+
+ my $c = do { local $/; <IN> };
+ close IN;
+
+ my %file = (orig => $c, changes => 0);
+
+ # Temporarily remove C/XS comments and strings from the code
+ my @ccom;
+
+ $c =~ s{
+ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
+ | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
+ | ( ^$HS*\#[^\r\n]*
+ | "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*'
+ | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
+ }{ defined $2 and push @ccom, $2;
+ defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
+
+ $file{ccom} = \@ccom;
+ $file{code} = $c;
+ $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
+
+ my $func;
+
+ for $func (keys %API) {
+ my $match = $func;
+ $match .= "|$revreplace{$func}" if exists $revreplace{$func};
+ if ($c =~ /\b(?:Perl_)?($match)\b/) {
+ $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
+ $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
+ if (exists $API{$func}{provided}) {
+ $file{uses_provided}{$func}++;
+ if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
+ $file{uses}{$func}++;
+ my @deps = rec_depend($func);
+ if (@deps) {
+ $file{uses_deps}{$func} = \@deps;
+ for (@deps) {
+ $file{uses}{$_} = 0 unless exists $file{uses}{$_};
+ }
+ }
+ for ($func, @deps) {
+ $file{needs}{$_} = 'static' if exists $need{$_};
+ }
+ }
+ }
+ if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
+ if ($c =~ /\b$func\b/) {
+ $file{uses_todo}{$func}++;
+ }
+ }
+ }
+ }
+
+ while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
+ if (exists $need{$2}) {
+ $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
+ }
+ else { warning("Possibly wrong #define $1 in $filename") }
+ }
+
+ for (qw(uses needs uses_todo needed_global needed_static)) {
+ for $func (keys %{$file{$_}}) {
+ push @{$global{$_}{$func}}, $filename;
+ }
+ }
+
+ $files{$filename} = \%file;
+}
+
+# Globally resolve NEED_'s
+my $need;
+for $need (keys %{$global{needs}}) {
+ if (@{$global{needs}{$need}} > 1) {
+ my @targets = @{$global{needs}{$need}};
+ my @t = grep $files{$_}{needed_global}{$need}, @targets;
+ @targets = @t if @t;
+ @t = grep /\.xs$/i, @targets;
+ @targets = @t if @t;
+ my $target = shift @targets;
+ $files{$target}{needs}{$need} = 'global';
+ for (@{$global{needs}{$need}}) {
+ $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
+ }
+ }
+}
+
+for $filename (@files) {
+ exists $files{$filename} or next;
+
+ info("=== Analyzing $filename ===");
+
+ my %file = %{$files{$filename}};
+ my $func;
+ my $c = $file{code};
+ my $warnings = 0;
+
+ for $func (sort keys %{$file{uses_Perl}}) {
+ if ($API{$func}{varargs}) {
+ unless ($API{$func}{nothxarg}) {
+ my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
+ { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
+ if ($changes) {
+ warning("Doesn't pass interpreter argument aTHX to Perl_$func");
+ $file{changes} += $changes;
+ }
+ }
+ }
+ else {
+ warning("Uses Perl_$func instead of $func");
+ $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
+ {$func$1(}g);
+ }
+ }
+
+ for $func (sort keys %{$file{uses_replace}}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+
+ for $func (sort keys %{$file{uses_provided}}) {
+ if ($file{uses}{$func}) {
+ if (exists $file{uses_deps}{$func}) {
+ diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
+ }
+ else {
+ diag("Uses $func");
+ }
+ }
+ $warnings += hint($func);
+ }
+
+ unless ($opt{quiet}) {
+ for $func (sort keys %{$file{uses_todo}}) {
+ print "*** WARNING: Uses $func, which may not be portable below perl ",
+ format_version($API{$func}{todo}), ", even with '$ppport'\n";
+ $warnings++;
+ }
+ }
+
+ for $func (sort keys %{$file{needed_static}}) {
+ my $message = '';
+ if (not exists $file{uses}{$func}) {
+ $message = "No need to define NEED_$func if $func is never used";
+ }
+ elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
+ $message = "No need to define NEED_$func when already needed globally";
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
+ }
+ }
+
+ for $func (sort keys %{$file{needed_global}}) {
+ my $message = '';
+ if (not exists $global{uses}{$func}) {
+ $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
+ }
+ elsif (exists $file{needs}{$func}) {
+ if ($file{needs}{$func} eq 'extern') {
+ $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
+ }
+ elsif ($file{needs}{$func} eq 'static') {
+ $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
+ }
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
+ }
+ }
+
+ $file{needs_inc_ppport} = keys %{$file{uses}};
+
+ if ($file{needs_inc_ppport}) {
+ my $pp = '';
+
+ for $func (sort keys %{$file{needs}}) {
+ my $type = $file{needs}{$func};
+ next if $type eq 'extern';
+ my $suffix = $type eq 'global' ? '_GLOBAL' : '';
+ unless (exists $file{"needed_$type"}{$func}) {
+ if ($type eq 'global') {
+ diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
+ }
+ else {
+ diag("File needs $func, adding static request");
+ }
+ $pp .= "#define NEED_$func$suffix\n";
+ }
+ }
+
+ if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
+ $pp = '';
+ $file{changes}++;
+ }
+
+ unless ($file{has_inc_ppport}) {
+ diag("Needs to include '$ppport'");
+ $pp .= qq(#include "$ppport"\n)
+ }
+
+ if ($pp) {
+ $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
+ || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
+ || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
+ || ($c =~ s/^/$pp/);
+ }
+ }
+ else {
+ if ($file{has_inc_ppport}) {
+ diag("No need to include '$ppport'");
+ $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
+ }
+ }
+
+ # put back in our C comments
+ my $ix;
+ my $cppc = 0;
+ my @ccom = @{$file{ccom}};
+ for $ix (0 .. $#ccom) {
+ if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
+ $cppc++;
+ $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
+ }
+ else {
+ $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
+ }
+ }
+
+ if ($cppc) {
+ my $s = $cppc != 1 ? 's' : '';
+ warning("Uses $cppc C++ style comment$s, which is not portable");
+ }
+
+ my $s = $warnings != 1 ? 's' : '';
+ my $warn = $warnings ? " ($warnings warning$s)" : '';
+ info("Analysis completed$warn");
+
+ if ($file{changes}) {
+ if (exists $opt{copy}) {
+ my $newfile = "$filename$opt{copy}";
+ if (-e $newfile) {
+ error("'$newfile' already exists, refusing to write copy of '$filename'");
+ }
+ else {
+ local *F;
+ if (open F, ">$newfile") {
+ info("Writing copy of '$filename' with changes to '$newfile'");
+ print F $c;
+ close F;
+ }
+ else {
+ error("Cannot open '$newfile' for writing: $!");
+ }
+ }
+ }
+ elsif (exists $opt{patch} || $opt{changes}) {
+ if (exists $opt{patch}) {
+ unless ($patch_opened) {
+ if (open PATCH, ">$opt{patch}") {
+ $patch_opened = 1;
+ }
+ else {
+ error("Cannot open '$opt{patch}' for writing: $!");
+ delete $opt{patch};
+ $opt{changes} = 1;
+ goto fallback;
+ }
+ }
+ mydiff(\*PATCH, $filename, $c);
+ }
+ else {
+fallback:
+ info("Suggested changes:");
+ mydiff(\*STDOUT, $filename, $c);
+ }
+ }
+ else {
+ my $s = $file{changes} == 1 ? '' : 's';
+ info("$file{changes} potentially required change$s detected");
+ }
+ }
+ else {
+ info("Looks good");
+ }
+}
+
+close PATCH if $patch_opened;
+
+exit 0;
+
+
+sub try_use { eval "use @_;"; return $@ eq '' }
+
+sub mydiff
+{
+ local *F = shift;
+ my($file, $str) = @_;
+ my $diff;
+
+ if (exists $opt{diff}) {
+ $diff = run_diff($opt{diff}, $file, $str);
+ }
+
+ if (!defined $diff and try_use('Text::Diff')) {
+ $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
+ $diff = <<HEADER . $diff;
+--- $file
++++ $file.patched
+HEADER
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff -u', $file, $str);
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff', $file, $str);
+ }
+
+ if (!defined $diff) {
+ error("Cannot generate a diff. Please install Text::Diff or use --copy.");
+ return;
+ }
+
+ print F $diff;
+}
+
+sub run_diff
+{
+ my($prog, $file, $str) = @_;
+ my $tmp = 'dppptemp';
+ my $suf = 'aaa';
+ my $diff = '';
+ local *F;
+
+ while (-e "$tmp.$suf") { $suf++ }
+ $tmp = "$tmp.$suf";
+
+ if (open F, ">$tmp") {
+ print F $str;
+ close F;
+
+ if (open F, "$prog $file $tmp |") {
+ while (<F>) {
+ s/\Q$tmp\E/$file.patched/;
+ $diff .= $_;
+ }
+ close F;
+ unlink $tmp;
+ return $diff;
+ }
+
+ unlink $tmp;
+ }
+ else {
+ error("Cannot open '$tmp' for writing: $!");
+ }
+
+ return undef;
+}
+
+sub rec_depend
+{
+ my($func, $seen) = @_;
+ return () unless exists $depends{$func};
+ $seen = {%{$seen||{}}};
+ return () if $seen->{$func}++;
+ my %s;
+ grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
+}
+
+sub parse_version
+{
+ my $ver = shift;
+
+ if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
+ return ($1, $2, $3);
+ }
+ elsif ($ver !~ /^\d+\.[\d_]+$/) {
+ die "cannot parse version '$ver'\n";
+ }
+
+ $ver =~ s/_//g;
+ $ver =~ s/$/000000/;
+
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "cannot parse version '$ver'\n";
+ }
+ }
+
+ return ($r, $v, $s);
+}
+
+sub format_version
+{
+ my $ver = shift;
+
+ $ver =~ s/$/000000/;
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "invalid version '$ver'\n";
+ }
+ $s /= 10;
+
+ $ver = sprintf "%d.%03d", $r, $v;
+ $s > 0 and $ver .= sprintf "_%02d", $s;
+
+ return $ver;
+ }
+
+ return sprintf "%d.%d.%d", $r, $v, $s;
+}
+
+sub info
+{
+ $opt{quiet} and return;
+ print @_, "\n";
+}
+
+sub diag
+{
+ $opt{quiet} and return;
+ $opt{diag} and print @_, "\n";
+}
+
+sub warning
+{
+ $opt{quiet} and return;
+ print "*** ", @_, "\n";
+}
+
+sub error
+{
+ print "*** ERROR: ", @_, "\n";
+}
+
+my %given_hints;
+my %given_warnings;
+sub hint
+{
+ $opt{quiet} and return;
+ my $func = shift;
+ my $rv = 0;
+ if (exists $warnings{$func} && !$given_warnings{$func}++) {
+ my $warn = $warnings{$func};
+ $warn =~ s!^!*** !mg;
+ print "*** WARNING: $func\n", $warn;
+ $rv++;
+ }
+ if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
+ my $hint = $hints{$func};
+ $hint =~ s/^/ /mg;
+ print " --- hint for $func ---\n", $hint;
+ }
+ $rv;
+}
+
+sub usage
+{
+ my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
+ my %M = ( 'I' => '*' );
+ $usage =~ s/^\s*perl\s+\S+/$^X $0/;
+ $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
+
+ print <<ENDUSAGE;
+
+Usage: $usage
+
+See perldoc $0 for details.
+
+ENDUSAGE
+
+ exit 2;
+}
+
+sub strip
+{
+ my $self = do { local(@ARGV,$/)=($0); <> };
+ my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
+ $copy =~ s/^(?=\S+)/ /gms;
+ $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
+ $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
+if (\@ARGV && \$ARGV[0] eq '--unstrip') {
+ eval { require Devel::PPPort };
+ \$@ and die "Cannot require Devel::PPPort, please install.\\n";
+ if (eval \$Devel::PPPort::VERSION < $VERSION) {
+ die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
+ . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
+ . "Please install a newer version, or --unstrip will not work.\\n";
+ }
+ Devel::PPPort::WriteFile(\$0);
+ exit 0;
+}
+print <<END;
+
+Sorry, but this is a stripped version of \$0.
+
+To be able to use its original script and doc functionality,
+please try to regenerate this file using:
+
+ \$^X \$0 --unstrip
+
+END
+/ms;
+ my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
+ $c =~ s{
+ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
+ | ( "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*' )
+ | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
+ $c =~ s!\s+$!!mg;
+ $c =~ s!^$LF!!mg;
+ $c =~ s!^\s*#\s*!#!mg;
+ $c =~ s!^\s+!!mg;
+
+ open OUT, ">$0" or die "cannot strip $0: $!\n";
+ print OUT "$pl$c\n";
+
+ exit 0;
+}
+
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef DPPP_NAMESPACE
+# define DPPP_NAMESPACE DPPP_
+#endif
+
+#define DPPP_CAT2(x,y) CAT2(x,y)
+#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
+
+#ifndef PERL_REVISION
+# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
+#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION))
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+#ifndef dTHX
+# define dTHX dNOOP
+#endif
+
+#ifndef dTHXa
+# define dTHXa(x) dNOOP
+#endif
+#ifndef pTHX
+# define pTHX void
+#endif
+
+#ifndef pTHX_
+# define pTHX_
+#endif
+
+#ifndef aTHX
+# define aTHX
+#endif
+
+#ifndef aTHX_
+# define aTHX_
+#endif
+
+#if (PERL_BCDVERSION < 0x5006000)
+# ifdef USE_THREADS
+# define aTHXR thr
+# define aTHXR_ thr,
+# else
+# define aTHXR
+# define aTHXR_
+# endif
+# define dTHXR dTHR
+#else
+# define aTHXR aTHX
+# define aTHXR_ aTHX_
+# define dTHXR dTHX
+#endif
+#ifndef dTHXoa
+# define dTHXoa(x) dTHXa(x)
+#endif
+
+#ifdef I_LIMITS
+# include <limits.h>
+#endif
+
+#ifndef PERL_UCHAR_MIN
+# define PERL_UCHAR_MIN ((unsigned char)0)
+#endif
+
+#ifndef PERL_UCHAR_MAX
+# ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+# else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_USHORT_MIN
+# define PERL_USHORT_MIN ((unsigned short)0)
+#endif
+
+#ifndef PERL_USHORT_MAX
+# ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+# else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MAX
+# ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+# else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MIN
+# ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+# else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MAX
+# ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+# else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MIN
+# define PERL_UINT_MIN ((unsigned int)0)
+#endif
+
+#ifndef PERL_INT_MAX
+# ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+# else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_INT_MIN
+# ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+# else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MAX
+# ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+# else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MIN
+# define PERL_ULONG_MIN ((unsigned long)0L)
+#endif
+
+#ifndef PERL_LONG_MAX
+# ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+# else
+# ifdef MAXLONG
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_LONG_MIN
+# ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+# else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
+# ifndef PERL_UQUAD_MAX
+# ifdef ULONGLONG_MAX
+# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
+# else
+# ifdef MAXULONGLONG
+# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
+# else
+# define PERL_UQUAD_MAX (~(unsigned long long)0)
+# endif
+# endif
+# endif
+
+# ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN ((unsigned long long)0L)
+# endif
+
+# ifndef PERL_QUAD_MAX
+# ifdef LONGLONG_MAX
+# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
+# else
+# ifdef MAXLONGLONG
+# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
+# else
+# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
+# endif
+# endif
+# endif
+
+# ifndef PERL_QUAD_MIN
+# ifdef LONGLONG_MIN
+# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
+# else
+# ifdef MINLONGLONG
+# define PERL_QUAD_MIN ((long long)MINLONGLONG)
+# else
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+/* This is based on code from 5.003 perl.h */
+#ifdef HAS_QUAD
+# ifdef cray
+#ifndef IVTYPE
+# define IVTYPE int
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_INT_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_INT_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UINT_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UINT_MAX
+#endif
+
+# ifdef INTSIZE
+#ifndef IVSIZE
+# define IVSIZE INTSIZE
+#endif
+
+# endif
+# else
+# if defined(convex) || defined(uts)
+#ifndef IVTYPE
+# define IVTYPE long long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_QUAD_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_QUAD_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UQUAD_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UQUAD_MAX
+#endif
+
+# ifdef LONGLONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGLONGSIZE
+#endif
+
+# endif
+# else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+# ifdef LONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGSIZE
+#endif
+
+# endif
+# endif
+# endif
+#ifndef IVSIZE
+# define IVSIZE 8
+#endif
+
+#ifndef 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 memEQs
+# define memEQs(s1, l, s2) \
+ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1)))
+#endif
+
+#ifndef memNEs
+# define memNEs(s1, l, s2) !memEQs(s1, l, s2)
+#endif
+#ifndef MoveD
+# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifndef CopyD
+# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifdef HAS_MEMSET
+#ifndef ZeroD
+# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
+#endif
+
+#else
+#ifndef ZeroD
+# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
+#endif
+
+#endif
+#ifndef PoisonWith
+# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))
+#endif
+
+#ifndef PoisonNew
+# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
+#endif
+
+#ifndef PoisonFree
+# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
+#endif
+
+#ifndef Poison
+# define Poison(d,n,t) PoisonFree(d,n,t)
+#endif
+#ifndef Newx
+# define Newx(v,n,t) New(0,v,n,t)
+#endif
+
+#ifndef Newxc
+# define Newxc(v,n,t,c) Newc(0,v,n,t,c)
+#endif
+
+#ifndef Newxz
+# define Newxz(v,n,t) Newz(0,v,n,t)
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+
+#ifndef PERL_UNUSED_ARG
+# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
+# include <note.h>
+# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
+# else
+# define PERL_UNUSED_ARG(x) ((void)x)
+# endif
+#endif
+
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(x) ((void)x)
+#endif
+
+#ifndef PERL_UNUSED_CONTEXT
+# ifdef USE_ITHREADS
+# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
+# else
+# define PERL_UNUSED_CONTEXT
+# endif
+#endif
+#ifndef NOOP
+# define NOOP /*EMPTY*/(void)0
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+# else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+# endif
+#endif
+
+#ifndef PTR2ul
+# if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+# else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+# endif
+#endif
+#ifndef PTR2nat
+# define PTR2nat(p) (PTRV)(p)
+#endif
+
+#ifndef NUM2PTR
+# define NUM2PTR(any,d) (any)PTR2nat(d)
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(p) INT2PTR(IV,p)
+#endif
+
+#ifndef PTR2UV
+# define PTR2UV(p) INT2PTR(UV,p)
+#endif
+
+#ifndef PTR2NV
+# define PTR2NV(p) NUM2PTR(NV,p)
+#endif
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C extern
+#endif
+
+#if defined(PERL_GCC_PEDANTIC)
+# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
+# ifndef PERL_USE_GCC_BRACE_GROUPS
+# define PERL_USE_GCC_BRACE_GROUPS
+# endif
+#endif
+
+#undef STMT_START
+#undef STMT_END
+#ifdef PERL_USE_GCC_BRACE_GROUPS
+# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
+# define STMT_END )
+#else
+# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
+# define STMT_START if (1)
+# define STMT_END else (void)0
+# else
+# define STMT_START do
+# define STMT_END while (0)
+# endif
+#endif
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef DEFSV_set
+# define DEFSV_set(sv) (DEFSV = (sv))
+#endif
+
+/* Older perls (<=5.003) lack AvFILLp */
+#ifndef AvFILLp
+# define AvFILLp AvFILL
+#endif
+#ifndef ERRSV
+# define ERRSV get_sv("@",FALSE)
+#endif
+
+/* Hint: gv_stashpvn
+ * This function's backport doesn't support the length parameter, but
+ * rather ignores it. Portability can only be ensured if the length
+ * parameter is used for speed reasons, but the length can always be
+ * correctly computed from the string argument.
+ */
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
+#endif
+
+/* Replace: 1 */
+#ifndef get_cv
+# define get_cv perl_get_cv
+#endif
+
+#ifndef get_sv
+# define get_sv perl_get_sv
+#endif
+
+#ifndef get_av
+# define get_av perl_get_av
+#endif
+
+#ifndef get_hv
+# define get_hv perl_get_hv
+#endif
+
+/* Replace: 0 */
+#ifndef dUNDERBAR
+# define dUNDERBAR dNOOP
+#endif
+
+#ifndef UNDERBAR
+# define UNDERBAR DEFSV
+#endif
+#ifndef dAX
+# define dAX I32 ax = MARK - PL_stack_base + 1
+#endif
+
+#ifndef dITEMS
+# define dITEMS I32 items = SP - MARK
+#endif
+#ifndef dXSTARG
+# define dXSTARG SV * targ = sv_newmortal()
+#endif
+#ifndef dAXMARK
+# define dAXMARK I32 ax = POPMARK; \
+ register SV ** const mark = PL_stack_base + ax++
+#endif
+#ifndef XSprePUSH
+# define XSprePUSH (sp = PL_stack_base + ax - 1)
+#endif
+
+#if (PERL_BCDVERSION < 0x5005000)
+# undef XSRETURN
+# define XSRETURN(off) \
+ STMT_START { \
+ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
+ return; \
+ } STMT_END
+#endif
+#ifndef XSPROTO
+# define XSPROTO(name) void name(pTHX_ CV* cv)
+#endif
+
+#ifndef SVfARG
+# define SVfARG(p) ((void*)(p))
+#endif
+#ifndef PERL_ABS
+# define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
+#endif
+#ifndef dVAR
+# define dVAR dNOOP
+#endif
+#ifndef SVf
+# define SVf "_"
+#endif
+#ifndef UTF8_MAXBYTES
+# define UTF8_MAXBYTES UTF8_MAXLEN
+#endif
+#ifndef CPERLscope
+# define CPERLscope(x) x
+#endif
+#ifndef PERL_HASH
+# define PERL_HASH(hash,str,len) \
+ STMT_START { \
+ const char *s_PeRlHaSh = str; \
+ I32 i_PeRlHaSh = len; \
+ U32 hash_PeRlHaSh = 0; \
+ while (i_PeRlHaSh--) \
+ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
+ (hash) = hash_PeRlHaSh; \
+ } STMT_END
+#endif
+
+#ifndef PERLIO_FUNCS_DECL
+# ifdef PERLIO_FUNCS_CONST
+# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
+# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
+# else
+# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
+# define PERLIO_FUNCS_CAST(funcs) (funcs)
+# endif
+#endif
+
+/* provide these typedefs for older perls */
+#if (PERL_BCDVERSION < 0x5009003)
+
+# ifdef ARGSproto
+typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
+# else
+typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
+# endif
+
+typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
+
+#endif
+#ifndef isPSXSPC
+# define isPSXSPC(c) (isSPACE(c) || (c) == '\v')
+#endif
+
+#ifndef isBLANK
+# define isBLANK(c) ((c) == ' ' || (c) == '\t')
+#endif
+
+#ifdef EBCDIC
+#ifndef isALNUMC
+# define isALNUMC(c) isalnum(c)
+#endif
+
+#ifndef isASCII
+# define isASCII(c) isascii(c)
+#endif
+
+#ifndef isCNTRL
+# define isCNTRL(c) iscntrl(c)
+#endif
+
+#ifndef isGRAPH
+# define isGRAPH(c) isgraph(c)
+#endif
+
+#ifndef isPRINT
+# define isPRINT(c) isprint(c)
+#endif
+
+#ifndef isPUNCT
+# define isPUNCT(c) ispunct(c)
+#endif
+
+#ifndef isXDIGIT
+# define isXDIGIT(c) isxdigit(c)
+#endif
+
+#else
+# if (PERL_BCDVERSION < 0x5010000)
+/* Hint: isPRINT
+ * The implementation in older perl versions includes all of the
+ * isSPACE() characters, which is wrong. The version provided by
+ * Devel::PPPort always overrides a present buggy version.
+ */
+# undef isPRINT
+# endif
+#ifndef isALNUMC
+# define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
+#endif
+
+#ifndef isASCII
+# define isASCII(c) ((U8) (c) <= 127)
+#endif
+
+#ifndef isCNTRL
+# define isCNTRL(c) ((U8) (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
+
+/* Hint: newSVpvn_share
+ * The SVs created by this function only mimic the behaviour of
+ * shared PVs without really being shared. Only use if you know
+ * what you're doing.
+ */
+
+#ifndef newSVpvn_share
+
+#if defined(NEED_newSVpvn_share)
+static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
+static
+#else
+extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
+#endif
+
+#ifdef newSVpvn_share
+# undef newSVpvn_share
+#endif
+#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c)
+#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share)
+
+#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL)
+
+SV *
+DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash)
+{
+ SV *sv;
+ if (len < 0)
+ len = -len;
+ if (!hash)
+ PERL_HASH(hash, (char*) src, len);
+ sv = newSVpvn((char *) src, len);
+ sv_upgrade(sv, SVt_PVIV);
+ SvIVX(sv) = hash;
+ SvREADONLY_on(sv);
+ SvPOK_on(sv);
+ return sv;
+}
+
+#endif
+
+#endif
+#ifndef SvSHARED_HASH
+# define SvSHARED_HASH(sv) (0 + SvUVX(sv))
+#endif
+#ifndef HvNAME_get
+# define HvNAME_get(hv) HvNAME(hv)
+#endif
+#ifndef HvNAMELEN_get
+# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
+#endif
+#ifndef GvSVn
+# define GvSVn(gv) GvSV(gv)
+#endif
+
+#ifndef isGV_with_GP
+# define isGV_with_GP(gv) isGV(gv)
+#endif
+
+#ifndef gv_fetchpvn_flags
+# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
+#endif
+
+#ifndef gv_fetchsv
+# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt)
+#endif
+#ifndef get_cvn_flags
+# define get_cvn_flags(name, namelen, flags) get_cv(name, flags)
+#endif
+#ifndef WARN_ALL
+# define WARN_ALL 0
+#endif
+
+#ifndef WARN_CLOSURE
+# define WARN_CLOSURE 1
+#endif
+
+#ifndef WARN_DEPRECATED
+# define WARN_DEPRECATED 2
+#endif
+
+#ifndef WARN_EXITING
+# define WARN_EXITING 3
+#endif
+
+#ifndef WARN_GLOB
+# define WARN_GLOB 4
+#endif
+
+#ifndef WARN_IO
+# define WARN_IO 5
+#endif
+
+#ifndef WARN_CLOSED
+# define WARN_CLOSED 6
+#endif
+
+#ifndef WARN_EXEC
+# define WARN_EXEC 7
+#endif
+
+#ifndef WARN_LAYER
+# define WARN_LAYER 8
+#endif
+
+#ifndef WARN_NEWLINE
+# define WARN_NEWLINE 9
+#endif
+
+#ifndef WARN_PIPE
+# define WARN_PIPE 10
+#endif
+
+#ifndef WARN_UNOPENED
+# define WARN_UNOPENED 11
+#endif
+
+#ifndef WARN_MISC
+# define WARN_MISC 12
+#endif
+
+#ifndef WARN_NUMERIC
+# define WARN_NUMERIC 13
+#endif
+
+#ifndef WARN_ONCE
+# define WARN_ONCE 14
+#endif
+
+#ifndef WARN_OVERFLOW
+# define WARN_OVERFLOW 15
+#endif
+
+#ifndef WARN_PACK
+# define WARN_PACK 16
+#endif
+
+#ifndef WARN_PORTABLE
+# define WARN_PORTABLE 17
+#endif
+
+#ifndef WARN_RECURSION
+# define WARN_RECURSION 18
+#endif
+
+#ifndef WARN_REDEFINE
+# define WARN_REDEFINE 19
+#endif
+
+#ifndef WARN_REGEXP
+# define WARN_REGEXP 20
+#endif
+
+#ifndef WARN_SEVERE
+# define WARN_SEVERE 21
+#endif
+
+#ifndef WARN_DEBUGGING
+# define WARN_DEBUGGING 22
+#endif
+
+#ifndef WARN_INPLACE
+# define WARN_INPLACE 23
+#endif
+
+#ifndef WARN_INTERNAL
+# define WARN_INTERNAL 24
+#endif
+
+#ifndef WARN_MALLOC
+# define WARN_MALLOC 25
+#endif
+
+#ifndef WARN_SIGNAL
+# define WARN_SIGNAL 26
+#endif
+
+#ifndef WARN_SUBSTR
+# define WARN_SUBSTR 27
+#endif
+
+#ifndef WARN_SYNTAX
+# define WARN_SYNTAX 28
+#endif
+
+#ifndef WARN_AMBIGUOUS
+# define WARN_AMBIGUOUS 29
+#endif
+
+#ifndef WARN_BAREWORD
+# define WARN_BAREWORD 30
+#endif
+
+#ifndef WARN_DIGIT
+# define WARN_DIGIT 31
+#endif
+
+#ifndef WARN_PARENTHESIS
+# define WARN_PARENTHESIS 32
+#endif
+
+#ifndef WARN_PRECEDENCE
+# define WARN_PRECEDENCE 33
+#endif
+
+#ifndef WARN_PRINTF
+# define WARN_PRINTF 34
+#endif
+
+#ifndef WARN_PROTOTYPE
+# define WARN_PROTOTYPE 35
+#endif
+
+#ifndef WARN_QW
+# define WARN_QW 36
+#endif
+
+#ifndef WARN_RESERVED
+# define WARN_RESERVED 37
+#endif
+
+#ifndef WARN_SEMICOLON
+# define WARN_SEMICOLON 38
+#endif
+
+#ifndef WARN_TAINT
+# define WARN_TAINT 39
+#endif
+
+#ifndef WARN_THREADS
+# define WARN_THREADS 40
+#endif
+
+#ifndef WARN_UNINITIALIZED
+# define WARN_UNINITIALIZED 41
+#endif
+
+#ifndef WARN_UNPACK
+# define WARN_UNPACK 42
+#endif
+
+#ifndef WARN_UNTIE
+# define WARN_UNTIE 43
+#endif
+
+#ifndef WARN_UTF8
+# define WARN_UTF8 44
+#endif
+
+#ifndef WARN_VOID
+# define WARN_VOID 45
+#endif
+
+#ifndef WARN_ASSERTIONS
+# define WARN_ASSERTIONS 46
+#endif
+#ifndef packWARN
+# define packWARN(a) (a)
+#endif
+
+#ifndef ckWARN
+# ifdef G_WARN_ON
+# define ckWARN(a) (PL_dowarn & G_WARN_ON)
+# else
+# define ckWARN(a) PL_dowarn
+# endif
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner)
+#if defined(NEED_warner)
+static void DPPP_(my_warner)(U32 err, const char *pat, ...);
+static
+#else
+extern void DPPP_(my_warner)(U32 err, const char *pat, ...);
+#endif
+
+#define Perl_warner DPPP_(my_warner)
+
+#if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
+
+void
+DPPP_(my_warner)(U32 err, const char *pat, ...)
+{
+ SV *sv;
+ va_list args;
+
+ PERL_UNUSED_ARG(err);
+
+ va_start(args, pat);
+ sv = vnewSVpvf(pat, &args);
+ va_end(args);
+ sv_2mortal(sv);
+ warn("%s", SvPV_nolen(sv));
+}
+
+#define warner Perl_warner
+
+#define Perl_warner_nocontext Perl_warner
+
+#endif
+#endif
+
+/* concatenating with "" ensures that only literal strings are accepted as argument
+ * note that STR_WITH_LEN() can't be used as argument to macros or functions that
+ * under some configurations might be macros
+ */
+#ifndef STR_WITH_LEN
+# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
+#endif
+#ifndef newSVpvs
+# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1)
+#endif
+
+#ifndef newSVpvs_flags
+# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
+#endif
+
+#ifndef newSVpvs_share
+# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0)
+#endif
+
+#ifndef sv_catpvs
+# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1)
+#endif
+
+#ifndef sv_setpvs
+# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1)
+#endif
+
+#ifndef hv_fetchs
+# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval)
+#endif
+
+#ifndef hv_stores
+# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
+#endif
+#ifndef gv_fetchpvs
+# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
+#endif
+
+#ifndef gv_stashpvs
+# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
+#endif
+#ifndef get_cvs
+# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags)
+#endif
+#ifndef SvGETMAGIC
+# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#endif
+#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 --git a/t/00-compile.t b/t/00-compile.t
new file mode 100644
index 0000000..cc7ad81
--- /dev/null
+++ b/t/00-compile.t
@@ -0,0 +1,74 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+
+
+use File::Find;
+use File::Temp qw{ tempdir };
+
+my @modules;
+find(
+ sub {
+ return if $File::Find::name !~ /\.pm\z/;
+ my $found = $File::Find::name;
+ $found =~ s{^lib/}{};
+ $found =~ s{[/\\]}{::}g;
+ $found =~ s/\.pm$//;
+ # nothing to skip
+ push @modules, $found;
+ },
+ 'lib',
+);
+
+sub _find_scripts {
+ my $dir = shift @_;
+
+ my @found_scripts = ();
+ find(
+ sub {
+ return unless -f;
+ my $found = $File::Find::name;
+ # nothing to skip
+ open my $FH, '<', $_ or do {
+ note( "Unable to open $found in ( $! ), skipping" );
+ return;
+ };
+ my $shebang = <$FH>;
+ return unless $shebang =~ /^#!.*?\bperl\b\s*$/;
+ push @found_scripts, $found;
+ },
+ $dir,
+ );
+
+ return @found_scripts;
+}
+
+my @scripts;
+do { push @scripts, _find_scripts($_) if -d $_ }
+ for qw{ bin script scripts };
+
+my $plan = scalar(@modules) + scalar(@scripts);
+$plan ? (plan tests => $plan) : (plan skip_all => "no tests to run");
+
+{
+ # fake home for cpan-testers
+ # no fake requested ## local $ENV{HOME} = tempdir( CLEANUP => 1 );
+
+ like( qx{ $^X -Ilib -e "require $_; print '$_ ok'" }, qr/^\s*$_ ok/s, "$_ loaded ok" )
+ for sort @modules;
+
+ SKIP: {
+ eval "use Test::Script 1.05; 1;";
+ skip "Test::Script needed to test script compilation", scalar(@scripts) if $@;
+ foreach my $file ( @scripts ) {
+ my $script = $file;
+ $script =~ s!.*/!!;
+ script_compiles( $file, "$script script compiles" );
+ }
+ }
+
+}
diff --git a/t/addsub.t b/t/addsub.t
new file mode 100644
index 0000000..4889d59
--- /dev/null
+++ b/t/addsub.t
@@ -0,0 +1,46 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE
+
+use Package::Stash;
+
+my $foo_stash = Package::Stash->new('Foo');
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('&funk' => sub { "Foo::funk", __LINE__ });
+}, undef, '... created &Foo::funk successfully');
+
+ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
+
+{
+ no strict 'refs';
+ ok(defined &{'Foo::funk'}, '... our &funk exists');
+}
+
+is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function');
+
+my $line = (Foo->funk())[1];
+is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line,
+ '... got the right %DB::sub value for funk default args';
+
+$foo_stash->add_symbol(
+ '&dunk' => sub { "Foo::dunk" },
+ filename => "FileName",
+ first_line_num => 100,
+ last_line_num => 199
+);
+
+is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199,
+ '... got the right %DB::sub value for dunk with specified args';
+
+done_testing;
diff --git a/t/anon-basic.t b/t/anon-basic.t
new file mode 100644
index 0000000..32f5c9c
--- /dev/null
+++ b/t/anon-basic.t
@@ -0,0 +1,403 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+use Test::Requires 'Package::Anon';
+use Package::Stash;
+use Symbol;
+
+plan skip_all => "Anonymous stashes in PP need at least perl 5.14"
+ if $] < 5.014
+ && $Package::Stash::IMPLEMENTATION eq 'PP';
+
+my $Foo = Package::Anon->new('Foo');
+$Foo->{SOME_CONSTANT} = \1;
+
+# ----------------------------------------------------------------------
+## tests adding a HASH
+
+my $foo_stash = Package::Stash->new($Foo);
+ok(!defined($Foo->{foo}), '... the %foo slot has not been created yet');
+ok(!$foo_stash->has_symbol('%foo'), '... the object agrees');
+ok(!defined($Foo->{foo}), '... checking doesn\'t vivify');
+
+is(exception {
+ $foo_stash->add_symbol('%foo' => { one => 1 });
+}, undef, '... created %Foo::foo successfully');
+
+# ... scalar should NOT be created here
+
+ok(!$foo_stash->has_symbol('$foo'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@foo'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&foo'), '... CODE shouldnt have been created too');
+
+ok(defined($Foo->{foo}), '... the %foo slot was created successfully');
+ok($foo_stash->has_symbol('%foo'), '... the meta agrees');
+
+# check the value ...
+
+ok(exists $Foo->{foo}{one}, '... our %foo was initialized correctly');
+is($Foo->{foo}{one}, 1, '... our %foo was initialized correctly');
+
+my $foo = $foo_stash->get_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+# ... make sure changes propogate up
+
+$foo->{two} = 2;
+
+is(\%{ $Foo->{foo} }, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the metas');
+
+ok(exists ${ $Foo->{foo} }{two}, '... our %foo was updated correctly');
+is(${ $Foo->{foo} }{two}, 2, '... our %foo was updated correctly');
+
+# ----------------------------------------------------------------------
+## test adding an ARRAY
+
+ok(!defined($Foo->{bar}), '... the @bar slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully');
+
+ok(defined($Foo->{bar}), '... the @bar slot was created successfully');
+ok($foo_stash->has_symbol('@bar'), '... the meta agrees');
+
+# ... why does this not work ...
+
+ok(!$foo_stash->has_symbol('$bar'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%bar'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&bar'), '... CODE shouldnt have been created too');
+
+# check the value itself
+
+is(scalar @{ $Foo->{bar} }, 3, '... our @bar was initialized correctly');
+is($Foo->{bar}[1], 2, '... our @bar was initialized correctly');
+
+# ----------------------------------------------------------------------
+## test adding a SCALAR
+
+ok(!defined($Foo->{baz}), '... the $baz slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('$baz' => 10);
+}, undef, '... created $Foo::baz successfully');
+
+ok(defined($Foo->{baz}), '... the $baz slot was created successfully');
+ok($foo_stash->has_symbol('$baz'), '... the meta agrees');
+
+ok(!$foo_stash->has_symbol('@baz'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%baz'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&baz'), '... CODE shouldnt have been created too');
+
+is(${$foo_stash->get_symbol('$baz')}, 10, '... got the right value back');
+
+${ $Foo->{baz} } = 1;
+
+is(${ $Foo->{baz} }, 1, '... our $baz was assigned to correctly');
+is(${$foo_stash->get_symbol('$baz')}, 1, '... the meta agrees');
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo->{funk}), '... the &funk slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('&funk' => sub { "Foo::funk" });
+}, undef, '... created &Foo::funk successfully');
+
+ok(defined($Foo->{funk}), '... the &funk slot was created successfully');
+ok($foo_stash->has_symbol('&funk'), '... the meta agrees');
+
+ok(!$foo_stash->has_symbol('$funk'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@funk'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%funk'), '... HASH shouldnt have been created too');
+
+ok(defined &{ $Foo->{funk} }, '... our &funk exists');
+
+is($Foo->bless({})->funk(), 'Foo::funk', '... got the right value from the function');
+
+# ----------------------------------------------------------------------
+## test multiple slots in the glob
+
+my $ARRAY = [ 1, 2, 3 ];
+my $CODE = sub { "Foo::foo" };
+
+is(exception {
+ $foo_stash->add_symbol('@foo' => $ARRAY);
+}, undef, '... created @Foo::foo successfully');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot was added successfully');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+is(exception {
+ $foo_stash->add_symbol('&foo' => $CODE);
+}, undef, '... created &Foo::foo successfully');
+
+ok($foo_stash->has_symbol('&foo'), '... the meta agrees');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+
+is(exception {
+ $foo_stash->add_symbol('$foo' => 'Foo::foo');
+}, undef, '... created $Foo::foo successfully');
+
+ok($foo_stash->has_symbol('$foo'), '... the meta agrees');
+my $SCALAR = $foo_stash->get_symbol('$foo');
+is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
+
+is(${ $Foo->{foo} }, 'Foo::foo', '... got the right value from the scalar');
+
+is(exception {
+ $foo_stash->remove_symbol('%foo');
+}, undef, '... removed %Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('%foo'), '... the %foo slot was removed successfully');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('&foo'), '... the &foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+ok(!defined(*{ $Foo->{foo} }{HASH}), '... the %foo slot has been removed successfully');
+ok(defined(*{ $Foo->{foo} }{ARRAY}), '... the @foo slot has NOT been removed');
+ok(defined(*{ $Foo->{foo} }{CODE}), '... the &foo slot has NOT been removed');
+ok(defined(${ $Foo->{foo} }), '... the $foo slot has NOT been removed');
+
+is(exception {
+ $foo_stash->remove_symbol('&foo');
+}, undef, '... removed &Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer exists');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+ok(!defined(*{ $Foo->{foo} }{HASH}), '... the %foo slot has been removed successfully');
+ok(!defined(*{ $Foo->{foo} }{CODE}), '... the &foo slot has now been removed');
+ok(defined(*{ $Foo->{foo} }{ARRAY}), '... the @foo slot has NOT been removed');
+ok(defined(${ $Foo->{foo} }), '... the $foo slot has NOT been removed');
+
+is(exception {
+ $foo_stash->remove_symbol('$foo');
+}, undef, '... removed $Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+ok(!defined(*{ $Foo->{foo} }{HASH}), '... the %foo slot has been removed successfully');
+ok(!defined(*{ $Foo->{foo} }{CODE}), '... the &foo slot has now been removed');
+ok(!defined(${ $Foo->{foo} }), '... the $foo slot has now been removed');
+ok(defined(*{ $Foo->{foo} }{ARRAY}), '... the @foo slot has NOT been removed');
+
+{
+ my $syms = $foo_stash->get_all_symbols;
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+}
+
+{
+ my $syms = $foo_stash->get_all_symbols('CODE');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('CODE') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('&' . $symbol), '... got the right symbol');
+ }
+}
+
+{
+ $foo_stash->add_symbol('%bare');
+ ok(!$foo_stash->has_symbol('$bare'),
+ "add_symbol with single argument doesn't vivify scalar slot");
+}
+
+{
+ $foo_stash->add_symbol('%zork', {});
+
+ my $syms = $foo_stash->get_all_symbols('HASH');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('HASH') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('%' . $symbol), '... got the right symbol');
+ }
+
+ is_deeply(
+ $syms,
+ {
+ zork => *{ $Foo->{zork} }{HASH},
+ bare => *{ $Foo->{bare} }{HASH},
+ },
+ "got the right ones",
+ );
+}
+
+# check some errors
+
+like(exception {
+ $foo_stash->add_symbol('@bar', {})
+}, qr/HASH.*is not of type ARRAY/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('bar', [])
+}, qr/ARRAY.*is not of type IO/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('$bar', sub { })
+}, qr/CODE.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('$bar', *{ Symbol::geniosym() }{IO})
+}, qr/IO.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
+
+is_deeply([Package::Stash->new('Foo')->list_all_symbols], [],
+ "Foo:: isn't touched");
+
+# *{ $Quux->{foo} } = \23 doesn't work on 5.12 and lower, apparently
+my $Quux = Package::Anon->new('Quux');
+{
+ my $gv = Symbol::gensym;
+ *$gv = \23;
+ *$gv = ["bar"];
+ *$gv = { baz => 1 };
+ *$gv = sub { };
+ *$gv = *{ Symbol::geniosym() }{IO};
+ $Quux->{foo} = *$gv;
+}
+
+{
+ my $stash = Package::Stash->new($Quux);
+
+ my %expect = (
+ '$foo' => \23,
+ '@foo' => ["bar"],
+ '%foo' => { baz => 1 },
+ '&foo' => \&{ $Quux->{foo} },
+ 'foo' => *{ $Quux->{foo} }{IO},
+ );
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+
+ $stash->add_symbol('%bar' => {x => 42});
+
+ $expect{'%bar'} = {x => 42};
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+
+ $stash->add_symbol('%bar' => {x => 43});
+
+ $expect{'%bar'} = {x => 43};
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+}
+
+is_deeply([Package::Stash->new('Quux')->list_all_symbols], [],
+ "Quux:: isn't touched");
+
+my $Quuux = Package::Anon->new('Quuux');
+
+{
+ my $gv = Symbol::gensym;
+ *$gv = \(my $scalar);
+ *$gv = [];
+ $Quuux->{foo} = *$gv;
+}
+
+{
+ my $gv = Symbol::gensym;
+ *$gv = [];
+ $Quuux->{bar} = *$gv;
+}
+
+{
+ my $gv = Symbol::gensym;
+ *$gv = {};
+ *$gv = sub { };
+ $Quuux->{baz} = *$gv;
+}
+
+$Quuux->{quux} = \1;
+
+$Quuux->{quuux} = \[];
+
+$Quuux->{quuuux} = -1;
+
+{
+ my $quuux = Package::Stash->new($Quuux);
+ is_deeply(
+ # Package::Anon adds a couple methods
+ [grep { $_ ne 'isa' && $_ ne 'can' } sort $quuux->list_all_symbols],
+ [qw(bar baz foo quuuux quuux quux)],
+ "list_all_symbols",
+ );
+ { local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ is_deeply(
+ [sort $quuux->list_all_symbols('SCALAR')],
+ [qw(foo)],
+ "list_all_symbols SCALAR",
+ );
+ }
+ is_deeply(
+ [sort $quuux->list_all_symbols('ARRAY')],
+ [qw(bar foo)],
+ "list_all_symbols ARRAY",
+ );
+ is_deeply(
+ [sort $quuux->list_all_symbols('HASH')],
+ [qw(baz)],
+ "list_all_symbols HASH",
+ );
+ is_deeply(
+ # Package::Anon adds a couple methods
+ [grep { $_ ne 'isa' && $_ ne 'can' } sort $quuux->list_all_symbols('CODE')],
+ [qw(baz quuuux quuux quux)],
+ "list_all_symbols CODE",
+ );
+}
+
+is_deeply([Package::Stash->new('Quuux')->list_all_symbols], [],
+ "Quuux:: isn't touched");
+
+done_testing;
diff --git a/t/anon.t b/t/anon.t
new file mode 100644
index 0000000..8b7f7aa
--- /dev/null
+++ b/t/anon.t
@@ -0,0 +1,49 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+use lib 't/lib';
+
+use Test::Requires 'Package::Anon';
+
+use Package::Stash;
+use Symbol;
+
+plan skip_all => "Anonymous stashes in PP need at least perl 5.14"
+ if $] < 5.014
+ && $Package::Stash::IMPLEMENTATION eq 'PP';
+
+my $anon = Package::Anon->new;
+my $stash = Package::Stash->new($anon);
+my $obj = $anon->bless({});
+
+{
+ my $code = sub { 'FOO' };
+ $stash->add_symbol('&foo' => $code);
+ is($stash->get_symbol('&foo'), $code);
+ is($obj->foo, 'FOO');
+}
+
+{
+ $anon->{bar} = \123;
+
+ my $code = $stash->get_symbol('&bar');
+ is(ref($code), 'CODE');
+ is($code->(), 123);
+
+ is($obj->bar, 123);
+}
+
+{
+ $anon->{baz} = -1;
+
+ my $code = $stash->get_symbol('&baz');
+ is(ref($code), 'CODE');
+ like(
+ exception { $code->() },
+ qr/Undefined subroutine \&__ANON__::baz called/
+ );
+}
+
+done_testing;
diff --git a/t/bare-anon-basic.t b/t/bare-anon-basic.t
new file mode 100644
index 0000000..5bdb523
--- /dev/null
+++ b/t/bare-anon-basic.t
@@ -0,0 +1,397 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+use Package::Stash;
+use Symbol;
+
+plan skip_all => "Anonymous stashes in PP need at least perl 5.14"
+ if $] < 5.014
+ && $Package::Stash::IMPLEMENTATION eq 'PP';
+
+plan skip_all => "This isn't really going to work yet, probably";
+
+my $Foo = {};
+$Foo->{SOME_CONSTANT} = \1;
+
+# ----------------------------------------------------------------------
+## tests adding a HASH
+
+my $foo_stash = Package::Stash->new($Foo);
+ok(!defined($Foo->{foo}), '... the %foo slot has not been created yet');
+ok(!$foo_stash->has_symbol('%foo'), '... the object agrees');
+ok(!defined($Foo->{foo}), '... checking doesn\'t vivify');
+
+is(exception {
+ $foo_stash->add_symbol('%foo' => { one => 1 });
+}, undef, '... created %Foo::foo successfully');
+
+# ... scalar should NOT be created here
+
+ok(!$foo_stash->has_symbol('$foo'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@foo'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&foo'), '... CODE shouldnt have been created too');
+
+ok(defined($Foo->{foo}), '... the %foo slot was created successfully');
+ok($foo_stash->has_symbol('%foo'), '... the meta agrees');
+
+# check the value ...
+
+ok(exists $Foo->{foo}{one}, '... our %foo was initialized correctly');
+is($Foo->{foo}{one}, 1, '... our %foo was initialized correctly');
+
+my $foo = $foo_stash->get_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+# ... make sure changes propogate up
+
+$foo->{two} = 2;
+
+is(\%{ $Foo->{foo} }, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the metas');
+
+ok(exists ${ $Foo->{foo} }{two}, '... our %foo was updated correctly');
+is(${ $Foo->{foo} }{two}, 2, '... our %foo was updated correctly');
+
+# ----------------------------------------------------------------------
+## test adding an ARRAY
+
+ok(!defined($Foo->{bar}), '... the @bar slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully');
+
+ok(defined($Foo->{bar}), '... the @bar slot was created successfully');
+ok($foo_stash->has_symbol('@bar'), '... the meta agrees');
+
+# ... why does this not work ...
+
+ok(!$foo_stash->has_symbol('$bar'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%bar'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&bar'), '... CODE shouldnt have been created too');
+
+# check the value itself
+
+is(scalar @{ $Foo->{bar} }, 3, '... our @bar was initialized correctly');
+is($Foo->{bar}[1], 2, '... our @bar was initialized correctly');
+
+# ----------------------------------------------------------------------
+## test adding a SCALAR
+
+ok(!defined($Foo->{baz}), '... the $baz slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('$baz' => 10);
+}, undef, '... created $Foo::baz successfully');
+
+ok(defined($Foo->{baz}), '... the $baz slot was created successfully');
+ok($foo_stash->has_symbol('$baz'), '... the meta agrees');
+
+ok(!$foo_stash->has_symbol('@baz'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%baz'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&baz'), '... CODE shouldnt have been created too');
+
+is(${$foo_stash->get_symbol('$baz')}, 10, '... got the right value back');
+
+${ $Foo->{baz} } = 1;
+
+is(${ $Foo->{baz} }, 1, '... our $baz was assigned to correctly');
+is(${$foo_stash->get_symbol('$baz')}, 1, '... the meta agrees');
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo->{funk}), '... the &funk slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('&funk' => sub { "Foo::funk" });
+}, undef, '... created &Foo::funk successfully');
+
+ok(defined($Foo->{funk}), '... the &funk slot was created successfully');
+ok($foo_stash->has_symbol('&funk'), '... the meta agrees');
+
+ok(!$foo_stash->has_symbol('$funk'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@funk'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%funk'), '... HASH shouldnt have been created too');
+
+ok(defined &{ $Foo->{funk} }, '... our &funk exists');
+
+# can't bless things into hashrefs yet
+# is($Foo->bless({})->funk(), 'Foo::funk', '... got the right value from the function');
+
+# ----------------------------------------------------------------------
+## test multiple slots in the glob
+
+my $ARRAY = [ 1, 2, 3 ];
+my $CODE = sub { "Foo::foo" };
+
+is(exception {
+ $foo_stash->add_symbol('@foo' => $ARRAY);
+}, undef, '... created @Foo::foo successfully');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot was added successfully');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+is(exception {
+ $foo_stash->add_symbol('&foo' => $CODE);
+}, undef, '... created &Foo::foo successfully');
+
+ok($foo_stash->has_symbol('&foo'), '... the meta agrees');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+
+is(exception {
+ $foo_stash->add_symbol('$foo' => 'Foo::foo');
+}, undef, '... created $Foo::foo successfully');
+
+ok($foo_stash->has_symbol('$foo'), '... the meta agrees');
+my $SCALAR = $foo_stash->get_symbol('$foo');
+is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
+
+is(${ $Foo->{foo} }, 'Foo::foo', '... got the right value from the scalar');
+
+is(exception {
+ $foo_stash->remove_symbol('%foo');
+}, undef, '... removed %Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('%foo'), '... the %foo slot was removed successfully');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('&foo'), '... the &foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+ok(!defined(*{ $Foo->{foo} }{HASH}), '... the %foo slot has been removed successfully');
+ok(defined(*{ $Foo->{foo} }{ARRAY}), '... the @foo slot has NOT been removed');
+ok(defined(*{ $Foo->{foo} }{CODE}), '... the &foo slot has NOT been removed');
+ok(defined(${ $Foo->{foo} }), '... the $foo slot has NOT been removed');
+
+is(exception {
+ $foo_stash->remove_symbol('&foo');
+}, undef, '... removed &Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer exists');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+ok(!defined(*{ $Foo->{foo} }{HASH}), '... the %foo slot has been removed successfully');
+ok(!defined(*{ $Foo->{foo} }{CODE}), '... the &foo slot has now been removed');
+ok(defined(*{ $Foo->{foo} }{ARRAY}), '... the @foo slot has NOT been removed');
+ok(defined(${ $Foo->{foo} }), '... the $foo slot has NOT been removed');
+
+is(exception {
+ $foo_stash->remove_symbol('$foo');
+}, undef, '... removed $Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+ok(!defined(*{ $Foo->{foo} }{HASH}), '... the %foo slot has been removed successfully');
+ok(!defined(*{ $Foo->{foo} }{CODE}), '... the &foo slot has now been removed');
+ok(!defined(${ $Foo->{foo} }), '... the $foo slot has now been removed');
+ok(defined(*{ $Foo->{foo} }{ARRAY}), '... the @foo slot has NOT been removed');
+
+{
+ my $syms = $foo_stash->get_all_symbols;
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+}
+
+{
+ local $TODO = "can't inflate weird stash entries";
+
+ is(
+ exception {
+ my $syms = $foo_stash->get_all_symbols('CODE');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('CODE') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('&' . $symbol), '... got the right symbol');
+ }
+ },
+ undef
+ );
+}
+
+{
+ $foo_stash->add_symbol('%bare');
+ ok(!$foo_stash->has_symbol('$bare'),
+ "add_symbol with single argument doesn't vivify scalar slot");
+}
+
+{
+ $foo_stash->add_symbol('%zork', {});
+
+ my $syms = $foo_stash->get_all_symbols('HASH');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('HASH') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('%' . $symbol), '... got the right symbol');
+ }
+
+ is_deeply(
+ $syms,
+ {
+ zork => *{ $Foo->{zork} }{HASH},
+ bare => *{ $Foo->{bare} }{HASH},
+ },
+ "got the right ones",
+ );
+}
+
+# check some errors
+
+like(exception {
+ $foo_stash->add_symbol('@bar', {})
+}, qr/HASH.*is not of type ARRAY/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('bar', [])
+}, qr/ARRAY.*is not of type IO/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('$bar', sub { })
+}, qr/CODE.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('$bar', *{ Symbol::geniosym() }{IO})
+}, qr/IO.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
+
+is_deeply([Package::Stash->new('Foo')->list_all_symbols], [],
+ "Foo:: isn't touched");
+
+my $Quux = {};
+$Quux->{foo} = *{ Symbol::gensym() };
+*{ $Quux->{foo} } = \23;
+*{ $Quux->{foo} } = ["bar"];
+*{ $Quux->{foo} } = { baz => 1 };
+*{ $Quux->{foo} } = sub { };
+*{ $Quux->{foo} } = *{ Symbol::geniosym() }{IO};
+
+{
+ my $stash = Package::Stash->new($Quux);
+
+ my %expect = (
+ '$foo' => \23,
+ '@foo' => ["bar"],
+ '%foo' => { baz => 1 },
+ '&foo' => \&{ $Quux->{foo} },
+ 'foo' => *{ $Quux->{foo} }{IO},
+ );
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+
+ $stash->add_symbol('%bar' => {x => 42});
+
+ $expect{'%bar'} = {x => 42};
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+
+ $stash->add_symbol('%bar' => {x => 43});
+
+ $expect{'%bar'} = {x => 43};
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+}
+
+is_deeply([Package::Stash->new('Quux')->list_all_symbols], [],
+ "Quux:: isn't touched");
+
+my $Quuux = {};
+
+$Quuux->{foo} = *{ Symbol::gensym() };
+*{ $Quuux->{foo} } = \(my $scalar);
+*{ $Quuux->{foo} } = [];
+
+$Quuux->{bar} = *{ Symbol::gensym() };
+*{ $Quuux->{bar} } = [];
+
+$Quuux->{baz} = *{ Symbol::gensym() };
+*{ $Quuux->{baz} } = {};
+*{ $Quuux->{baz} } = sub { };
+
+$Quuux->{quux} = \1;
+
+$Quuux->{quuux} = \[];
+
+$Quuux->{quuuux} = -1;
+
+{
+ my $quuux = Package::Stash->new($Quuux);
+ is_deeply(
+ [sort $quuux->list_all_symbols],
+ [qw(bar baz foo quuuux quuux quux)],
+ "list_all_symbols",
+ );
+ { local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ is_deeply(
+ [sort $quuux->list_all_symbols('SCALAR')],
+ [qw(foo)],
+ "list_all_symbols SCALAR",
+ );
+ }
+ is_deeply(
+ [sort $quuux->list_all_symbols('ARRAY')],
+ [qw(bar foo)],
+ "list_all_symbols ARRAY",
+ );
+ is_deeply(
+ [sort $quuux->list_all_symbols('HASH')],
+ [qw(baz)],
+ "list_all_symbols HASH",
+ );
+ is_deeply(
+ [sort $quuux->list_all_symbols('CODE')],
+ [qw(baz quuuux quuux quux)],
+ "list_all_symbols CODE",
+ );
+}
+
+is_deeply([Package::Stash->new('Quuux')->list_all_symbols], [],
+ "Quuux:: isn't touched");
+
+done_testing;
diff --git a/t/bare-anon.t b/t/bare-anon.t
new file mode 100644
index 0000000..0ecb324
--- /dev/null
+++ b/t/bare-anon.t
@@ -0,0 +1,62 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+use lib 't/lib';
+
+use Package::Stash;
+use Symbol;
+
+plan skip_all => "Anonymous stashes in PP need at least perl 5.14"
+ if $] < 5.014
+ && $Package::Stash::IMPLEMENTATION eq 'PP';
+
+plan skip_all => "This isn't really going to work yet, probably";
+
+my $anon = {};
+my $stash = Package::Stash->new($anon);
+# no way to bless something into a hashref yet
+# my $obj = $anon->bless({});
+
+{
+ my $code = sub { 'FOO' };
+ $stash->add_symbol('&foo' => $code);
+ is($stash->get_symbol('&foo'), $code);
+ # is($obj->foo, 'FOO');
+}
+
+{
+ local $TODO = "can't inflate weird stash entries";
+ $anon->{bar} = \123;
+
+ is(
+ exception {
+ my $code = $stash->get_symbol('&bar');
+ is(ref($code), 'CODE');
+ is($code->(), 123);
+
+ # is($obj->bar, 123);
+ },
+ undef
+ );
+}
+
+{
+ local $TODO = "can't inflate weird stash entries";
+ $anon->{baz} = -1;
+
+ is(
+ exception {
+ my $code = $stash->get_symbol('&baz');
+ is(ref($code), 'CODE');
+ like(
+ exception { $code->() },
+ qr/Undefined subroutine \&__ANON__::baz called/
+ );
+ },
+ undef
+ );
+}
+
+done_testing;
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..286b707
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,448 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+use Package::Stash;
+
+like(exception { Package::Stash->name }, qr/Can't call name as a class method/,
+ q{... can't call name() as a class method});
+
+{
+ package Foo;
+
+ use constant SOME_CONSTANT => 1;
+}
+
+# ----------------------------------------------------------------------
+## tests adding a HASH
+
+my $foo_stash = Package::Stash->new('Foo');
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
+ok(!$foo_stash->has_symbol('%foo'), '... the object agrees');
+ok(!defined($Foo::{foo}), '... checking doesn\' vivify');
+
+is(exception {
+ $foo_stash->add_symbol('%foo' => { one => 1 });
+}, undef, '... created %Foo::foo successfully');
+
+# ... scalar should NOT be created here
+
+ok(!$foo_stash->has_symbol('$foo'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@foo'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&foo'), '... CODE shouldnt have been created too');
+
+ok(defined($Foo::{foo}), '... the %foo slot was created successfully');
+ok($foo_stash->has_symbol('%foo'), '... the meta agrees');
+
+# check the value ...
+
+{
+ no strict 'refs';
+ ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly');
+ is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly');
+}
+
+my $foo = $foo_stash->get_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+# ... make sure changes propogate up
+
+$foo->{two} = 2;
+
+{
+ no strict 'refs';
+ is(\%{'Foo::foo'}, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the metas');
+
+ ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
+ is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
+}
+
+# ----------------------------------------------------------------------
+## test adding an ARRAY
+
+ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully');
+
+ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
+ok($foo_stash->has_symbol('@bar'), '... the meta agrees');
+
+# ... why does this not work ...
+
+ok(!$foo_stash->has_symbol('$bar'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%bar'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&bar'), '... CODE shouldnt have been created too');
+
+# check the value itself
+
+{
+ no strict 'refs';
+ is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly');
+ is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly');
+}
+
+# ----------------------------------------------------------------------
+## test adding a SCALAR
+
+ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('$baz' => 10);
+}, undef, '... created $Foo::baz successfully');
+
+ok(defined($Foo::{baz}), '... the $baz slot was created successfully');
+ok($foo_stash->has_symbol('$baz'), '... the meta agrees');
+
+ok(!$foo_stash->has_symbol('@baz'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%baz'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&baz'), '... CODE shouldnt have been created too');
+
+is(${$foo_stash->get_symbol('$baz')}, 10, '... got the right value back');
+
+{
+ no strict 'refs';
+ ${'Foo::baz'} = 1;
+
+ is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
+ is(${$foo_stash->get_symbol('$baz')}, 1, '... the meta agrees');
+}
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('&funk' => sub { "Foo::funk" });
+}, undef, '... created &Foo::funk successfully');
+
+ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
+ok($foo_stash->has_symbol('&funk'), '... the meta agrees');
+
+ok(!$foo_stash->has_symbol('$funk'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@funk'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%funk'), '... HASH shouldnt have been created too');
+
+{
+ no strict 'refs';
+ ok(defined &{'Foo::funk'}, '... our &funk exists');
+}
+
+is(Foo->funk(), 'Foo::funk', '... got the right value from the function');
+
+# ----------------------------------------------------------------------
+## test multiple slots in the glob
+
+my $ARRAY = [ 1, 2, 3 ];
+my $CODE = sub { "Foo::foo" };
+
+is(exception {
+ $foo_stash->add_symbol('@foo' => $ARRAY);
+}, undef, '... created @Foo::foo successfully');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot was added successfully');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+is(exception {
+ $foo_stash->add_symbol('&foo' => $CODE);
+}, undef, '... created &Foo::foo successfully');
+
+ok($foo_stash->has_symbol('&foo'), '... the meta agrees');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+
+is(exception {
+ $foo_stash->add_symbol('$foo' => 'Foo::foo');
+}, undef, '... created $Foo::foo successfully');
+
+ok($foo_stash->has_symbol('$foo'), '... the meta agrees');
+my $SCALAR = $foo_stash->get_symbol('$foo');
+is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
+
+{
+ no strict 'refs';
+ is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar');
+}
+
+is(exception {
+ $foo_stash->remove_symbol('%foo');
+}, undef, '... removed %Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('%foo'), '... the %foo slot was removed successfully');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('&foo'), '... the &foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+}
+
+is(exception {
+ $foo_stash->remove_symbol('&foo');
+}, undef, '... removed &Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer exists');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+}
+
+is(exception {
+ $foo_stash->remove_symbol('$foo');
+}, undef, '... removed $Foo::foo successfully');
+
+ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists');
+
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+
+{
+ no strict 'refs';
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+}
+
+{
+ my $syms = $foo_stash->get_all_symbols;
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+}
+
+{
+ my $syms = $foo_stash->get_all_symbols('CODE');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('CODE') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('&' . $symbol), '... got the right symbol');
+ }
+}
+
+{
+ $foo_stash->add_symbol('%bare');
+ ok(!$foo_stash->has_symbol('$bare'),
+ "add_symbol with single argument doesn't vivify scalar slot");
+}
+
+{
+ $foo_stash->add_symbol('%zork', {});
+
+ my $syms = $foo_stash->get_all_symbols('HASH');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('HASH') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('%' . $symbol), '... got the right symbol');
+ }
+
+ is_deeply(
+ $syms,
+ {
+ zork => *{ $Foo::{zork} }{HASH},
+ bare => *{ $Foo::{bare} }{HASH},
+ },
+ "got the right ones",
+ );
+}
+
+# check some errors
+
+like(exception {
+ $foo_stash->add_symbol('@bar', {})
+}, qr/HASH.*is not of type ARRAY/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('bar', [])
+}, qr/ARRAY.*is not of type IO/, "can't initialize a slot with the wrong type of value");
+
+like(exception {
+ $foo_stash->add_symbol('$bar', sub { })
+}, qr/CODE.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
+
+{
+ package Bar;
+ open *foo, '<', $0;
+}
+
+like(exception {
+ $foo_stash->add_symbol('$bar', *Bar::foo{IO})
+}, qr/IO.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
+
+# check compile time manipulation
+
+{
+ package Baz;
+
+ our $foo = 23;
+ our @foo = "bar";
+ our %foo = (baz => 1);
+ sub foo { }
+ open *foo, '<', $0;
+ BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') }
+}
+
+{
+ my $stash = Package::Stash->new('Baz');
+ is(${ $stash->get_symbol('$foo') }, 23, "got \$foo");
+ is_deeply($stash->get_symbol('@foo'), ['bar'], "got \@foo");
+ is_deeply($stash->get_symbol('%foo'), {baz => 1}, "got \%foo");
+ ok(!$stash->has_symbol('&foo'), "got \&foo");
+ is($stash->get_symbol('foo'), *Baz::foo{IO}, "got foo");
+}
+
+{
+ package Quux;
+
+ our $foo = 23;
+ our @foo = "bar";
+ our %foo = (baz => 1);
+ sub foo { }
+ open *foo, '<', $0;
+}
+
+{
+ my $stash = Package::Stash->new('Quux');
+
+ my %expect = (
+ '$foo' => \23,
+ '@foo' => ["bar"],
+ '%foo' => { baz => 1 },
+ '&foo' => \&Quux::foo,
+ 'foo' => *Quux::foo{IO},
+ );
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+
+ $stash->add_symbol('%bar' => {x => 42});
+
+ $expect{'%bar'} = {x => 42};
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+
+ $stash->add_symbol('%bar' => {x => 43});
+
+ $expect{'%bar'} = {x => 43};
+
+ for my $sym ( sort keys %expect ) {
+ is_deeply(
+ $stash->get_symbol($sym),
+ $expect{$sym},
+ "got expected value for $sym"
+ );
+ }
+}
+
+{
+ package Quuux;
+ our $foo;
+ our @foo;
+ our @bar;
+ our %baz;
+ sub baz { }
+ use constant quux => 1;
+ use constant quuux => [];
+ sub quuuux;
+}
+
+{
+ my $quuux = Package::Stash->new('Quuux');
+ is_deeply(
+ [sort $quuux->list_all_symbols],
+ [qw(BEGIN bar baz foo quuuux quuux quux)],
+ "list_all_symbols",
+ );
+ { local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ is_deeply(
+ [sort $quuux->list_all_symbols('SCALAR')],
+ [qw(foo)],
+ "list_all_symbols SCALAR",
+ );
+ }
+ is_deeply(
+ [sort $quuux->list_all_symbols('ARRAY')],
+ [qw(bar foo)],
+ "list_all_symbols ARRAY",
+ );
+ is_deeply(
+ [sort $quuux->list_all_symbols('HASH')],
+ [qw(baz)],
+ "list_all_symbols HASH",
+ );
+ is_deeply(
+ [sort $quuux->list_all_symbols('CODE')],
+ [qw(baz quuuux quuux quux)],
+ "list_all_symbols CODE",
+ );
+}
+
+for my $package ('Foo:Bar', 'Foo/Bar', 'Foo Bar', 'Foo:::Bar', '') {
+ like(
+ exception { Package::Stash->new($package) },
+ qr/^$package is not a module name/,
+ "$package is not a module name"
+ );
+}
+
+like(
+ exception { Package::Stash->new([]) },
+ qr/^Package::Stash->new must be passed the name of the package to access/,
+ "module name must be a string"
+);
+
+like(
+ exception { Package::Stash->new(undef) },
+ qr/^Package::Stash->new must be passed the name of the package to access/,
+ "module name must be a string"
+);
+
+done_testing;
diff --git a/t/compile-time.t b/t/compile-time.t
new file mode 100644
index 0000000..90debf2
--- /dev/null
+++ b/t/compile-time.t
@@ -0,0 +1,9 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use_ok('CompileTime');
+
+done_testing;
diff --git a/t/edge-cases.t b/t/edge-cases.t
new file mode 100644
index 0000000..58c5dc8
--- /dev/null
+++ b/t/edge-cases.t
@@ -0,0 +1,113 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+use Package::Stash;
+
+{
+ package Foo;
+ use constant FOO => 1;
+ use constant BAR => \1;
+ use constant BAZ => [];
+ use constant QUUX => {};
+ use constant QUUUX => sub { };
+ sub normal { }
+ sub stub;
+ sub normal_with_proto () { }
+ sub stub_with_proto ();
+
+ our $SCALAR;
+ our $SCALAR_WITH_VALUE = 1;
+ our @ARRAY;
+ our %HASH;
+}
+
+my $stash = Package::Stash->new('Foo');
+{ local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ok($stash->has_symbol('$SCALAR'), '$SCALAR');
+}
+ok($stash->has_symbol('$SCALAR_WITH_VALUE'), '$SCALAR_WITH_VALUE');
+ok($stash->has_symbol('@ARRAY'), '@ARRAY');
+ok($stash->has_symbol('%HASH'), '%HASH');
+is_deeply(
+ [sort $stash->list_all_symbols('CODE')],
+ [qw(BAR BAZ FOO QUUUX QUUX normal normal_with_proto stub stub_with_proto)],
+ "can see all code symbols"
+);
+
+$stash->add_symbol('%added', {});
+ok(!$stash->has_symbol('$added'), '$added');
+ok(!$stash->has_symbol('@added'), '@added');
+ok($stash->has_symbol('%added'), '%added');
+
+my $constant = $stash->get_symbol('&FOO');
+is(ref($constant), 'CODE', "expanded a constant into a coderef");
+
+# ensure get doesn't prevent subsequent vivification (not sure what the deal
+# was here)
+is(ref($stash->get_symbol('$glob')), '', "nothing yet");
+is(ref($stash->get_or_add_symbol('$glob')), 'SCALAR', "got an empty scalar");
+
+SKIP: {
+ skip "PP doesn't support anon stashes before 5.14", 4
+ if $] < 5.014 && $Package::Stash::IMPLEMENTATION eq 'PP';
+ skip "XS doesn't support anon stashes before 5.10", 4
+ if $] < 5.010 && $Package::Stash::IMPLEMENTATION eq 'XS';
+ local $TODO = "don't know how to properly inflate a stash entry in PP"
+ if $Package::Stash::IMPLEMENTATION eq 'PP';
+
+ my $anon = {}; # not using Package::Anon
+ $anon->{foo} = -1; # stub
+ $anon->{bar} = '$&'; # stub with prototype
+ $anon->{baz} = \"foo"; # constant
+
+ my $stash = Package::Stash->new($anon);
+ is(
+ exception {
+ is(ref($stash->get_symbol('&foo')), 'CODE',
+ "stub expanded into a glob");
+ is(ref($stash->get_symbol('&bar')), 'CODE',
+ "stub with prototype expanded into a glob");
+ is(ref($stash->get_symbol('&baz')), 'CODE',
+ "constant expanded into a glob");
+ },
+ undef,
+ "can call get_symbol on weird stash entries"
+ );
+}
+
+{
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+ my $stash = Package::Stash->new('Bar');
+ $stash->add_symbol('&foo' => sub { });
+ $stash->add_symbol('&foo' => sub { });
+ is($warning, undef, "no redefinition warnings");
+}
+
+{
+ local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ my $stash = Package::Stash->new('Baz');
+ $stash->add_symbol('$baz', \undef);
+ ok($stash->has_symbol('$baz'), "immortal scalars are also visible");
+}
+
+{
+ {
+ package HasISA::Super;
+ package HasISA;
+ our @ISA = ('HasISA::Super');
+ }
+ ok(HasISA->isa('HasISA::Super'));
+ my $stash = Package::Stash->new('HasISA');
+ is_deeply([$stash->list_all_symbols('SCALAR')], []);
+}
+
+done_testing;
diff --git a/t/extension.t b/t/extension.t
new file mode 100644
index 0000000..f8e4752
--- /dev/null
+++ b/t/extension.t
@@ -0,0 +1,76 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+{
+ package My::Package::Stash;
+ use strict;
+ use warnings;
+
+ use base 'Package::Stash';
+
+ use Symbol 'gensym';
+
+ sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->{namespace} = {};
+ return $self;
+ }
+
+ sub namespace { shift->{namespace} }
+
+ sub add_symbol {
+ my ($self, $variable, $initial_value) = @_;
+
+ (my $name = $variable) =~ s/^[\$\@\%\&]//;
+
+ my $glob = gensym();
+ *{$glob} = $initial_value if defined $initial_value;
+ $self->namespace->{$name} = *{$glob};
+ }
+}
+
+# No actually package Foo exists :)
+my $foo_stash = My::Package::Stash->new('Foo');
+
+isa_ok($foo_stash, 'My::Package::Stash');
+isa_ok($foo_stash, 'Package::Stash');
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
+ok(!$foo_stash->has_symbol('%foo'), '... the foo_stash agrees');
+
+is(exception {
+ $foo_stash->add_symbol('%foo' => { one => 1 });
+}, undef, '... the %foo symbol is created succcessfully');
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package');
+ok($foo_stash->has_symbol('%foo'), '... the foo_stash agrees');
+
+my $foo = $foo_stash->get_symbol('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+$foo->{two} = 2;
+
+is($foo, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the foo_stashs');
+
+ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully');
+
+ok(!defined($Foo::{bar}), '... the @bar slot has still not been created');
+
+ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet');
+
+is(exception {
+ $foo_stash->add_symbol('%baz');
+}, undef, '... created %Foo::baz successfully');
+
+ok(!defined($Foo::{baz}), '... the %baz slot has still not been created');
+
+done_testing;
diff --git a/t/get.t b/t/get.t
new file mode 100644
index 0000000..4f0eb6a
--- /dev/null
+++ b/t/get.t
@@ -0,0 +1,186 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use Package::Stash;
+use Scalar::Util;
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Hash');
+ my $val = $stash->get_symbol('%foo');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ %Hash::foo;
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Hash');
+ my $val = $stash->get_symbol('%foo');
+ is(ref($val), 'HASH', "got something");
+ $val->{bar} = 1;
+ is_deeply($stash->get_symbol('%foo'), {bar => 1},
+ "got the right variable");
+ is_deeply(\%Hash::foo, {bar => 1},
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Array');
+ my $val = $stash->get_symbol('@foo');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ @Array::foo;
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Array');
+ my $val = $stash->get_symbol('@foo');
+ is(ref($val), 'ARRAY', "got something");
+ push @$val, 1;
+ is_deeply($stash->get_symbol('@foo'), [1],
+ "got the right variable");
+ is_deeply(\@Array::foo, [1],
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Scalar');
+ my $val = $stash->get_symbol('$foo');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ $Scalar::foo;
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Scalar');
+ my $val = $stash->get_symbol('$foo');
+ is(ref($val), 'SCALAR', "got something");
+ $$val = 1;
+ is_deeply($stash->get_symbol('$foo'), \1,
+ "got the right variable");
+ is($Scalar::foo, 1,
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Code');
+ my $val = $stash->get_symbol('&foo');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ sub Code::foo { }
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Code');
+ my $val = $stash->get_symbol('&foo');
+ is(ref($val), 'CODE', "got something");
+ is(prototype($val), undef, "got the right variable");
+ &Scalar::Util::set_prototype($val, '&');
+ is($stash->get_symbol('&foo'), $val,
+ "got the right variable");
+ is(prototype($stash->get_symbol('&foo')), '&',
+ "got the right variable");
+ is(prototype(\&Code::foo), '&',
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Io');
+ my $val = $stash->get_symbol('FOO');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ package Io;
+ fileno(FOO);
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Io');
+ my $val = $stash->get_symbol('FOO');
+ isa_ok($val, 'IO');
+ my $str = "foo";
+ open $val, '<', \$str;
+ is(readline($stash->get_symbol('FOO')), "foo",
+ "got the right variable");
+ seek($stash->get_symbol('FOO'), 0, 0);
+ {
+ package Io;
+ ::isa_ok(*FOO{IO}, 'IO');
+ ::is(<FOO>, "foo",
+ "stash has the right variable");
+ }
+ }
+}
+
+{
+ my $stash = Package::Stash->new('Hash::Vivify');
+ my $val = $stash->get_or_add_symbol('%foo');
+ is(ref($val), 'HASH', "got something");
+ $val->{bar} = 1;
+ is_deeply($stash->get_or_add_symbol('%foo'), {bar => 1},
+ "got the right variable");
+ no warnings 'once';
+ is_deeply(\%Hash::Vivify::foo, {bar => 1},
+ "stash has the right variable");
+}
+
+{
+ my $stash = Package::Stash->new('Array::Vivify');
+ my $val = $stash->get_or_add_symbol('@foo');
+ is(ref($val), 'ARRAY', "got something");
+ push @$val, 1;
+ is_deeply($stash->get_or_add_symbol('@foo'), [1],
+ "got the right variable");
+ no warnings 'once';
+ is_deeply(\@Array::Vivify::foo, [1],
+ "stash has the right variable");
+}
+
+{
+ my $stash = Package::Stash->new('Scalar::Vivify');
+ my $val = $stash->get_or_add_symbol('$foo');
+ is(ref($val), 'SCALAR', "got something");
+ $$val = 1;
+ is_deeply($stash->get_or_add_symbol('$foo'), \1,
+ "got the right variable");
+ no warnings 'once';
+ is($Scalar::Vivify::foo, 1,
+ "stash has the right variable");
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Io::Vivify');
+ my $val = $stash->get_or_add_symbol('FOO');
+ isa_ok($val, 'IO');
+ my $str = "foo";
+ open $val, '<', \$str;
+ is(readline($stash->get_symbol('FOO')), "foo",
+ "got the right variable");
+ seek($stash->get_symbol('FOO'), 0, 0);
+ }
+ {
+ package Io::Vivify;
+ no warnings 'once';
+ ::isa_ok(*FOO{IO}, 'IO');
+ ::is(<FOO>, "foo",
+ "stash has the right variable");
+ }
+}
+
+done_testing;
diff --git a/t/io.t b/t/io.t
new file mode 100644
index 0000000..ecade2a
--- /dev/null
+++ b/t/io.t
@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+{
+ package Foo;
+ open *foo, "<", $0;
+
+ sub foo { }
+}
+
+{
+ package Bar;
+ open *bar, "<", $0;
+
+ sub bar { }
+}
+
+use Package::Stash;
+
+{
+ my $stash = Package::Stash->new('Foo');
+ ok($stash->has_symbol('&foo'), "has &foo");
+ ok($stash->has_symbol('foo'), "has foo");
+ $stash->remove_symbol('&foo');
+ ok(!$stash->has_symbol('&foo'), "has &foo");
+ ok($stash->has_symbol('foo'), "has foo");
+}
+
+{
+ my $stash = Package::Stash->new('Bar');
+ ok($stash->has_symbol('&bar'), "has &bar");
+ ok($stash->has_symbol('bar'), "has bar");
+ $stash->remove_symbol('bar');
+ ok($stash->has_symbol('&bar'), "has &bar");
+ ok(!$stash->has_symbol('bar'), "has bar");
+}
+
+{
+ my $stash = Package::Stash->new('Baz');
+ is(exception {
+ $stash->add_symbol('baz', *Foo::foo{IO});
+ }, undef, "can add an IO symbol");
+ ok($stash->has_symbol('baz'), "has baz");
+ is($stash->get_symbol('baz'), *Foo::foo{IO}, "got the right baz");
+}
+
+done_testing;
diff --git a/t/isa.t b/t/isa.t
new file mode 100644
index 0000000..f2e516f
--- /dev/null
+++ b/t/isa.t
@@ -0,0 +1,49 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use Package::Stash;
+
+{
+ package Foo;
+}
+
+{
+ package Bar;
+ sub bar { }
+}
+
+{
+ my $stash = Package::Stash->new('Foo');
+ my @ISA = ('Bar');
+ @{$stash->get_or_add_symbol('@ISA')} = @ISA;
+ isa_ok('Foo', 'Bar');
+ isa_ok(bless({}, 'Foo'), 'Bar');
+}
+
+{
+ package Baz;
+ sub foo { }
+}
+
+{
+ my $stash = Package::Stash->new('Quux');
+ {
+ my $isa = $stash->get_or_add_symbol('@ISA');
+ @$isa = ('Baz');
+ isa_ok('Quux', 'Baz');
+ isa_ok(bless({}, 'Quux'), 'Baz');
+ ok(Quux->can('foo'));
+ }
+ {
+ my $isa = $stash->get_or_add_symbol('@ISA');
+ @$isa = ('Bar');
+ isa_ok('Quux', 'Bar');
+ isa_ok(bless({}, 'Quux'), 'Bar');
+ ok(Quux->can('bar'));
+ }
+}
+
+done_testing;
diff --git a/t/lib/CompileTime.pm b/t/lib/CompileTime.pm
new file mode 100644
index 0000000..925bc18
--- /dev/null
+++ b/t/lib/CompileTime.pm
@@ -0,0 +1,15 @@
+package CompileTime;
+use strict;
+use warnings;
+
+use Package::Stash;
+
+our $foo = 23;
+
+BEGIN {
+ my $stash = Package::Stash->new(__PACKAGE__);
+ $stash->add_symbol('$bar', $foo);
+ $stash->add_symbol('$baz', $stash->get_symbol('$foo'));
+}
+
+1;
diff --git a/t/lib/Package/Stash.pm b/t/lib/Package/Stash.pm
new file mode 100644
index 0000000..a73bec8
--- /dev/null
+++ b/t/lib/Package/Stash.pm
@@ -0,0 +1,19 @@
+package # hide from PAUSE
+ Package::Stash;
+use strict;
+use warnings;
+
+use Package::Stash::XS;
+
+our $IMPLEMENTATION = 'XS';
+
+BEGIN {
+ my $ps = Package::Stash::XS->new(__PACKAGE__);
+ my $ps_xs = Package::Stash::XS->new('Package::Stash::XS');
+ for my $method ($ps_xs->list_all_symbols('CODE')) {
+ my $sym = '&' . $method;
+ $ps->add_symbol($sym => $ps_xs->get_symbol($sym));
+ }
+}
+
+1;
diff --git a/t/magic.t b/t/magic.t
new file mode 100644
index 0000000..df3012a
--- /dev/null
+++ b/t/magic.t
@@ -0,0 +1,80 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use Package::Stash;
+
+# @ISA magic
+{
+ my $Foo = Package::Stash->new('ISAFoo');
+ $Foo->add_symbol('&foo' => sub { });
+
+ my $Bar = Package::Stash->new('ISABar');
+ @{ $Bar->get_or_add_symbol('@ISA') } = ('ISAFoo');
+ can_ok('ISABar', 'foo');
+
+ my $Foo2 = Package::Stash->new('ISAFoo2');
+ $Foo2->add_symbol('&foo2' => sub { });
+ @{ $Bar->get_or_add_symbol('@ISA') } = ('ISAFoo2');
+ can_ok('ISABar', 'foo2');
+ ok(!Bar->can('foo'));
+}
+
+{
+ my $main = Package::Stash->new('main');
+ $main->add_symbol('$"', '-');
+ my @foo = qw(a b c);
+ is(eval q["@foo"], 'a-b-c');
+}
+
+SKIP: {
+ skip "only need to test for magic in the xs version", 10
+ unless $Package::Stash::IMPLEMENTATION eq 'XS';
+ skip "magic stashes require perl 5.10+", 10
+ unless $] >= 5.010;
+ skip "magic stashes require Variable::Magic", 10
+ unless eval { require Variable::Magic; 1 };
+
+ my ($fetch, $store);
+ my $wiz = Variable::Magic::wizard(
+ fetch => sub { $fetch++ },
+ store => sub { $store++ },
+ );
+ Variable::Magic::cast(\%MagicStashTest::, $wiz);
+
+ my $stash = Package::Stash->new('MagicStashTest');
+
+ $fetch = 0;
+ $store = 0;
+ $stash->get_symbol('@foo');
+ is($fetch, 1, "get_symbol fetches (empty slot)");
+ is($store, 0, "get_symbol stores (empty slot)");
+
+ $fetch = 0;
+ $store = 0;
+ $stash->get_or_add_symbol('@bar');
+ is($fetch, 0, "get_or_add_symbol fetches (empty slot)");
+ is($store, 1, "get_or_add_symbol stores (empty slot)");
+
+ $fetch = 0;
+ $store = 0;
+ $stash->add_symbol('@baz', ['baz']);
+ is($fetch, 0, "add_symbol fetches");
+ is($store, 1, "add_symbol stores");
+
+ $fetch = 0;
+ $store = 0;
+ $stash->get_symbol('@baz');
+ is($fetch, 1, "get_symbol fetches (populated slot)");
+ is($store, 0, "get_symbol stores (populated slot)");
+
+ $fetch = 0;
+ $store = 0;
+ $stash->get_or_add_symbol('@baz');
+ is($fetch, 1, "get_or_add_symbol fetches (populated slot)");
+ is($store, 0, "get_or_add_symbol stores (populated slot)");
+}
+
+done_testing;
diff --git a/t/paamayim_nekdotayim.t b/t/paamayim_nekdotayim.t
new file mode 100644
index 0000000..d17bdaf
--- /dev/null
+++ b/t/paamayim_nekdotayim.t
@@ -0,0 +1,28 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+use Package::Stash;
+
+my $stash = Package::Stash->new('Foo');
+# this segfaulted on the xs version
+like(
+ exception { $stash->add_symbol('@bar::baz') },
+ qr/^Variable names may not contain ::/,
+ "can't add symbol with ::"
+);
+like(
+ exception { $stash->get_symbol('@bar::baz') },
+ qr/^Variable names may not contain ::/,
+ "can't add symbol with ::"
+);
+like(
+ exception { $stash->get_or_add_symbol('@bar::baz') },
+ qr/^Variable names may not contain ::/,
+ "can't add symbol with ::"
+);
+
+done_testing;
diff --git a/t/scalar-values.t b/t/scalar-values.t
new file mode 100644
index 0000000..b2daebe
--- /dev/null
+++ b/t/scalar-values.t
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+
+use B;
+use Package::Stash;
+use Scalar::Util qw(reftype);
+use Symbol;
+
+my $Bar = Package::Stash->new('Bar');
+
+my $pviv = 3;
+$pviv =~ s/3/4/;
+isa_ok(B::svref_2object(\$pviv), 'B::PVIV');
+is(exception { $Bar->add_symbol('$pviv', \$pviv) }, undef,
+ "can add PVIV values");
+
+my $pvnv = 4.5;
+$pvnv =~ s/4/5/;
+isa_ok(B::svref_2object(\$pvnv), 'B::PVNV');
+is(exception { $Bar->add_symbol('$pvnv', \$pvnv) }, undef,
+ "can add PVNV values");
+
+my $pvmg = "foo";
+bless \$pvmg, 'Foo';
+isa_ok(B::svref_2object(\$pvmg), 'B::PVMG');
+is(exception { $Bar->add_symbol('$pvmg', \$pvmg) }, undef,
+ "can add PVMG values");
+
+my $regexp = qr/foo/;
+isa_ok(B::svref_2object($regexp), ($] < 5.012 ? 'B::PVMG' : 'B::REGEXP'));
+is(exception { $Bar->add_symbol('$regexp', $regexp) }, undef,
+ "can add REGEXP values");
+
+my $pvgv = Symbol::gensym;
+isa_ok(B::svref_2object($pvgv), 'B::GV');
+isnt(exception { $Bar->add_symbol('$pvgv', $pvgv) }, undef,
+ "can't add PVGV values");
+
+my $pvlv = "foo";
+isa_ok(B::svref_2object(\substr($pvlv, 0, 1)), 'B::PVLV');
+is(exception { $Bar->add_symbol('$pvlv', \substr($pvlv, 0, 1)) }, undef,
+ "can add PVLV values");
+
+my $vstring = v1.2.3;
+is(reftype(\$vstring), ($] < 5.010 ? 'SCALAR' : 'VSTRING'));
+is(exception { $Bar->add_symbol('$vstring', \$vstring) }, undef,
+ "can add vstring values");
+
+done_testing;
diff --git a/t/stash-deletion.t b/t/stash-deletion.t
new file mode 100644
index 0000000..e331234
--- /dev/null
+++ b/t/stash-deletion.t
@@ -0,0 +1,24 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use Package::Stash;
+
+{
+ package Gets::Deleted;
+ sub bar { }
+}
+
+{
+ my $delete = Package::Stash->new('Gets::Deleted');
+ ok($delete->has_symbol('&bar'), "sees the method");
+ {
+ no strict 'refs';
+ delete ${'main::Gets::'}{'Deleted::'};
+ }
+ ok(!$delete->has_symbol('&bar'), "method goes away when stash is deleted");
+}
+
+done_testing;
diff --git a/t/synopsis.t b/t/synopsis.t
new file mode 100644
index 0000000..9f59948
--- /dev/null
+++ b/t/synopsis.t
@@ -0,0 +1,19 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use Package::Stash;
+
+my $stash = Package::Stash->new('Foo');
+$stash->add_symbol('%foo', {bar => 1});
+{
+ no warnings 'once';
+ is($Foo::foo{bar}, 1, "set in the stash properly");
+}
+ok(!$stash->has_symbol('$foo'), "doesn't have anything in scalar slot");
+my $namespace = $stash->namespace;
+is_deeply(*{ $namespace->{foo} }{HASH}, {bar => 1}, "namespace works properly");
+
+done_testing;
diff --git a/t/warnings.t b/t/warnings.t
new file mode 100644
index 0000000..99628ca
--- /dev/null
+++ b/t/warnings.t
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+
+use Package::Stash;
+
+my $warnings;
+BEGIN {
+ $warnings = '';
+ $SIG{__WARN__} = sub { $warnings .= $_[0] };
+}
+
+BEGIN {
+ my $stash = Package::Stash->new('Foo');
+ $stash->get_or_add_symbol('$bar');
+}
+
+is($warnings, '');
+
+done_testing;
diff --git a/typemap b/typemap
new file mode 100644
index 0000000..fc3c031
--- /dev/null
+++ b/typemap
@@ -0,0 +1,18 @@
+TYPEMAP
+varspec_t T_VARSPEC
+vartype_t T_VARTYPE
+
+INPUT
+T_VARSPEC
+ if (SvPOK($arg))
+ _deconstruct_variable_name($arg, &$var);
+ else if (SvROK($arg) && SvTYPE(SvRV($arg)) == SVt_PVHV)
+ _deconstruct_variable_hash((HV*)SvRV($arg), &$var);
+ else
+ croak(\"varspec must be a string or a hashref\");
+ _check_varspec_is_valid(&$var);
+
+T_VARTYPE
+ if (!SvPOK($arg))
+ croak(\"vartype must be a string\");
+ $var = string_to_vartype(SvPV_nolen($arg));
diff --git a/xt/author/leaks-debug.t b/xt/author/leaks-debug.t
new file mode 100644
index 0000000..686a96e
--- /dev/null
+++ b/xt/author/leaks-debug.t
@@ -0,0 +1,230 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+use Test::LeakTrace;
+
+BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE
+
+use Package::Stash;
+use Symbol;
+
+{
+ package Bar;
+}
+
+{
+ package Baz;
+ our $foo;
+ sub bar { }
+ use constant baz => 1;
+ our %quux = (a => 'b');
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Foo');
+ } "object construction doesn't leak";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Bar');
+ } "object construction doesn't leak, with an existing package";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Baz');
+ } "object construction doesn't leak, with an existing package with things in it";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->name;
+ } "name accessor doesn't leak";
+ no_leaks_ok {
+ $foo->namespace;
+ } "namespace accessor doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar');
+ } "add_symbol scalar with no initializer doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('@array');
+ } "add_symbol array with no initializer doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('%hash');
+ } "add_symbol hash with no initializer doesn't leak";
+ { local $TODO = "not sure why this leaks";
+ no_leaks_ok {
+ $foo->add_symbol('io');
+ } "add_symbol io with no initializer doesn't leak";
+ }
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar_init' => 1);
+ } "add_symbol scalar doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('@array_init' => []);
+ } "add_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('%hash_init' => {});
+ } "add_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('&code_init' => sub { "foo" });
+ } "add_symbol code doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('io_init' => Symbol::geniosym);
+ } "add_symbol io doesn't leak";
+ is(exception {
+ is(Foo->code_init, 'foo', "sub installed correctly")
+ }, undef, "code_init exists");
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->remove_symbol('$scalar_init');
+ } "remove_symbol scalar doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('@array_init');
+ } "remove_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('%hash_init');
+ } "remove_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('&code_init');
+ } "remove_symbol code doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('io_init');
+ } "remove_symbol io doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ $foo->add_symbol("${_}glob") for ('$', '@', '%', '');
+ no_leaks_ok {
+ $foo->remove_glob('glob');
+ } "remove_glob doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->has_symbol('io');
+ } "has_symbol io doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('%hash');
+ } "has_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('@array_init');
+ } "has_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('$glob');
+ } "has_symbol nonexistent scalar doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('&something_else');
+ } "has_symbol nonexistent code doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->get_symbol('io');
+ } "get_symbol io doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('%hash');
+ } "get_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('@array_init');
+ } "get_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('$glob');
+ } "get_symbol nonexistent scalar doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('&something_else');
+ } "get_symbol nonexistent code doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ ok(!$foo->has_symbol('$glob'));
+ ok(!$foo->has_symbol('@array_init'));
+ no_leaks_ok {
+ $foo->get_or_add_symbol('io');
+ $foo->get_or_add_symbol('%hash');
+ my @super = ('Exporter');
+ @{$foo->get_or_add_symbol('@ISA')} = @super;
+ $foo->get_or_add_symbol('$glob');
+ } "get_or_add_symbol doesn't leak";
+ { local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ ok($foo->has_symbol('$glob'));
+ }
+ is(ref($foo->get_symbol('$glob')), 'SCALAR');
+ ok($foo->has_symbol('@ISA'));
+ is(ref($foo->get_symbol('@ISA')), 'ARRAY');
+ is_deeply($foo->get_symbol('@ISA'), ['Exporter']);
+ isa_ok('Foo', 'Exporter');
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $baz = Package::Stash->new('Baz');
+ no_leaks_ok {
+ $foo->list_all_symbols;
+ $foo->list_all_symbols('SCALAR');
+ $foo->list_all_symbols('CODE');
+ $baz->list_all_symbols('CODE');
+ } "list_all_symbols doesn't leak";
+}
+
+{
+ package Blah;
+ use constant 'baz';
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $blah = Package::Stash->new('Blah');
+ no_leaks_ok {
+ $foo->get_all_symbols;
+ $foo->get_all_symbols('SCALAR');
+ $foo->get_all_symbols('CODE');
+ $blah->get_all_symbols('CODE');
+ } "get_all_symbols doesn't leak";
+}
+
+# mimic CMOP::create_anon_class
+{
+ local $TODO = $] < 5.010 ? "deleting stashes is inherently leaky on 5.8"
+ : undef;
+ my $i = 0;
+ no_leaks_ok {
+ $i++;
+ eval "package Quux$i; 1;";
+ my $quux = Package::Stash->new("Quux$i");
+ $quux->get_or_add_symbol('@ISA');
+ delete $::{'Quux' . $i . '::'};
+ } "get_symbol doesn't leak during glob expansion";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ eval { $foo->add_symbol('&blorg') };
+ } "doesn't leak on errors";
+}
+
+done_testing;
diff --git a/xt/author/leaks.t b/xt/author/leaks.t
new file mode 100644
index 0000000..e3b50ab
--- /dev/null
+++ b/xt/author/leaks.t
@@ -0,0 +1,228 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+use Test::LeakTrace;
+
+use Package::Stash;
+use Symbol;
+
+{
+ package Bar;
+}
+
+{
+ package Baz;
+ our $foo;
+ sub bar { }
+ use constant baz => 1;
+ our %quux = (a => 'b');
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Foo');
+ } "object construction doesn't leak";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Bar');
+ } "object construction doesn't leak, with an existing package";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Baz');
+ } "object construction doesn't leak, with an existing package with things in it";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->name;
+ } "name accessor doesn't leak";
+ no_leaks_ok {
+ $foo->namespace;
+ } "namespace accessor doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar');
+ } "add_symbol scalar with no initializer doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('@array');
+ } "add_symbol array with no initializer doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('%hash');
+ } "add_symbol hash with no initializer doesn't leak";
+ { local $TODO = "not sure why this leaks";
+ no_leaks_ok {
+ $foo->add_symbol('io');
+ } "add_symbol io with no initializer doesn't leak";
+ }
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar_init' => 1);
+ } "add_symbol scalar doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('@array_init' => []);
+ } "add_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('%hash_init' => {});
+ } "add_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('&code_init' => sub { "foo" });
+ } "add_symbol code doesn't leak";
+ no_leaks_ok {
+ $foo->add_symbol('io_init' => Symbol::geniosym);
+ } "add_symbol io doesn't leak";
+ is(exception {
+ is(Foo->code_init, 'foo', "sub installed correctly")
+ }, undef, "code_init exists");
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->remove_symbol('$scalar_init');
+ } "remove_symbol scalar doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('@array_init');
+ } "remove_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('%hash_init');
+ } "remove_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('&code_init');
+ } "remove_symbol code doesn't leak";
+ no_leaks_ok {
+ $foo->remove_symbol('io_init');
+ } "remove_symbol io doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ $foo->add_symbol("${_}glob") for ('$', '@', '%', '');
+ no_leaks_ok {
+ $foo->remove_glob('glob');
+ } "remove_glob doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->has_symbol('io');
+ } "has_symbol io doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('%hash');
+ } "has_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('@array_init');
+ } "has_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('$glob');
+ } "has_symbol nonexistent scalar doesn't leak";
+ no_leaks_ok {
+ $foo->has_symbol('&something_else');
+ } "has_symbol nonexistent code doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->get_symbol('io');
+ } "get_symbol io doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('%hash');
+ } "get_symbol hash doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('@array_init');
+ } "get_symbol array doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('$glob');
+ } "get_symbol nonexistent scalar doesn't leak";
+ no_leaks_ok {
+ $foo->get_symbol('&something_else');
+ } "get_symbol nonexistent code doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ ok(!$foo->has_symbol('$glob'));
+ ok(!$foo->has_symbol('@array_init'));
+ no_leaks_ok {
+ $foo->get_or_add_symbol('io');
+ $foo->get_or_add_symbol('%hash');
+ my @super = ('Exporter');
+ @{$foo->get_or_add_symbol('@ISA')} = @super;
+ $foo->get_or_add_symbol('$glob');
+ } "get_or_add_symbol doesn't leak";
+ { local $TODO = $] < 5.010
+ ? "undef scalars aren't visible on 5.8"
+ : undef;
+ ok($foo->has_symbol('$glob'));
+ }
+ is(ref($foo->get_symbol('$glob')), 'SCALAR');
+ ok($foo->has_symbol('@ISA'));
+ is(ref($foo->get_symbol('@ISA')), 'ARRAY');
+ is_deeply($foo->get_symbol('@ISA'), ['Exporter']);
+ isa_ok('Foo', 'Exporter');
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $baz = Package::Stash->new('Baz');
+ no_leaks_ok {
+ $foo->list_all_symbols;
+ $foo->list_all_symbols('SCALAR');
+ $foo->list_all_symbols('CODE');
+ $baz->list_all_symbols('CODE');
+ } "list_all_symbols doesn't leak";
+}
+
+{
+ package Blah;
+ use constant 'baz';
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $blah = Package::Stash->new('Blah');
+ no_leaks_ok {
+ $foo->get_all_symbols;
+ $foo->get_all_symbols('SCALAR');
+ $foo->get_all_symbols('CODE');
+ $blah->get_all_symbols('CODE');
+ } "get_all_symbols doesn't leak";
+}
+
+# mimic CMOP::create_anon_class
+{
+ local $TODO = $] < 5.010 ? "deleting stashes is inherently leaky on 5.8"
+ : undef;
+ my $i = 0;
+ no_leaks_ok {
+ $i++;
+ eval "package Quux$i; 1;";
+ my $quux = Package::Stash->new("Quux$i");
+ $quux->get_or_add_symbol('@ISA');
+ delete $::{'Quux' . $i . '::'};
+ } "get_symbol doesn't leak during glob expansion";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ eval { $foo->add_symbol('&blorg') };
+ } "doesn't leak on errors";
+}
+
+done_testing;
diff --git a/xt/release/eol.t b/xt/release/eol.t
new file mode 100644
index 0000000..d13c49d
--- /dev/null
+++ b/xt/release/eol.t
@@ -0,0 +1,8 @@
+use strict;
+use warnings;
+use Test::More;
+
+eval 'use Test::EOL';
+plan skip_all => 'Test::EOL required' if $@;
+
+all_perl_files_ok({ trailing_whitespace => 1 });
diff --git a/xt/release/no-tabs.t b/xt/release/no-tabs.t
new file mode 100644
index 0000000..ff70010
--- /dev/null
+++ b/xt/release/no-tabs.t
@@ -0,0 +1,8 @@
+use strict;
+use warnings;
+use Test::More;
+
+eval 'use Test::NoTabs';
+plan skip_all => 'Test::NoTabs required' if $@;
+
+all_perl_files_ok();
diff --git a/xt/release/pod-coverage.t b/xt/release/pod-coverage.t
new file mode 100644
index 0000000..b52218b
--- /dev/null
+++ b/xt/release/pod-coverage.t
@@ -0,0 +1,13 @@
+#!perl
+
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.08";
+plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage"
+ if $@;
+
+eval "use Pod::Coverage::TrustPod";
+plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' });
diff --git a/xt/release/pod-syntax.t b/xt/release/pod-syntax.t
new file mode 100644
index 0000000..8a22900
--- /dev/null
+++ b/xt/release/pod-syntax.t
@@ -0,0 +1,7 @@
+#!perl
+use Test::More;
+
+eval "use Test::Pod 1.41";
+plan skip_all => "Test::Pod 1.41 required for testing POD" if $@;
+
+all_pod_files_ok();
View Lorry Controller Status