diff options
47 files changed, 6563 insertions, 0 deletions
@@ -0,0 +1,141 @@ +Revision history for Package-Stash + +0.37 2014-09-21 + - fix spurious warning in taint mode (Niko Tyni, #12) + +0.36 2013-09-03 + - support building with PUREPERL_ONLY + +0.35 2013-07-09 + - remove old deprecated api + +0.34 2013-01-04 + - support anonymous stashes on newer perl versions + - prevent harmful effects from invalid settings for + $ENV{PACKAGE_STASH_IMPLEMENTATION} + - switch to Module::Implementation + +0.33 2011-09-28 + - add conflict on MooseX::Method::Signatures 0.36 (ether) + +0.32 2011-09-05 + - bring the behavior of has_symbol for nonexistant scalars into line with + the xs version + - invalid package names (for instance, Foo:Bar) are not allowed + - invalid stash entry names (anything containing ::) are not allowed + +0.31 2011-08-08 + - fix ->add_symbol('$foo', qr/sdlfk/) on 5.12+ + - fix ->add_symbol('$foo', \v1.2.3) on 5.10+ + +0.30 2011-07-21 + - fix compiler detection in Makefile.PL (ribasushi) + +0.29 2011-04-06 + - no, *really* skip the package-stash-conflict script + +0.28 2011-03-29 + - META.json fixes (mst) + +0.27 2011-03-27 + - also skip the package-stash-conflicts script (Father Chrysostomos) + +0.26 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.25 2011-01-25 + - make the leak tests author-only, since some smokers run release tests + +0.24 2011-01-17 + - oops, i did need the Test::Requires dep + +0.23 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.22 2011-01-05 + - bump ::XS dep again + +0.21 2011-01-05 + - bump Package::Stash::XS dep, since a bug was fixed there + +0.20 2011-01-03 + - one more fix for the Conflicts plugin + +0.19 2011-01-03 + - stop manually inserting conflict checking into Makefile.PL since we're + using the dzil Conflicts plugin now + +0.18 2011-01-03 + - non-trial release + +0.17-TRIAL 2011-01-03 + - use Dist::Zilla::Plugin::Conflicts rather than doing it by hand + - silence deprecation warnings for the method renaming for now + +0.16-TRIAL 2010-12-31 + - use Dist::CheckConflicts + +0.15-TRIAL 2010-11-16 + - split the XS conversion out to its own dist (Package-Stash-XS), and + convert Package::Stash into a module which loads either the XS or pure + perl implementation, depending on what's available + +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). + + - methods were renamed for brevity: s/_package// + +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 @@ -0,0 +1,379 @@ +This software is copyright (c) 2014 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) 2014 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, Fifth Floor, Boston, MA 02110-1301 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) 2014 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..e476903 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,48 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.020. +Changes +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README +bin/package-stash-conflicts +dist.ini +inc/MMPackageStash.pm +lib/Package/Stash.pm +lib/Package/Stash/Conflicts.pm +lib/Package/Stash/PP.pm +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/impl-selection/basic-pp.t +t/impl-selection/basic-xs.t +t/impl-selection/bug-rt-78272.t +t/impl-selection/choice.t +t/impl-selection/env.t +t/impl-selection/var.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-taint.t +t/warnings.t +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..db34749 --- /dev/null +++ b/META.json @@ -0,0 +1,573 @@ +{ + "abstract" : "routines for manipulating stashes", + "author" : [ + "Jesse Luehrs <doy@tozt.net>" + ], + "dynamic_config" : 1, + "generated_by" : "Dist::Zilla version 5.020, CPAN::Meta::Converter version 2.140640", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Package-Stash", + "prereqs" : { + "configure" : { + "requires" : { + "Config" : "0", + "Dist::CheckConflicts" : "0.02", + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "Text::ParseWords" : "0" + } + }, + "develop" : { + "requires" : { + "Pod::Coverage::TrustPod" : "0", + "Test::LeakTrace" : "0", + "Test::More" : "0", + "Test::NoTabs" : "0", + "Test::Pod" : "1.41", + "Test::Pod::Coverage" : "1.08" + } + }, + "runtime" : { + "recommends" : { + "Package::Stash::XS" : "0.26" + }, + "requires" : { + "B" : "0", + "Carp" : "0", + "Dist::CheckConflicts" : "0.02", + "Getopt::Long" : "0", + "Module::Implementation" : "0.06", + "Scalar::Util" : "0", + "Symbol" : "0", + "constant" : "0", + "perl" : "5.008001", + "strict" : "0", + "warnings" : "0" + } + }, + "test" : { + "requires" : { + "File::Spec" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Test::Fatal" : "0", + "Test::More" : "0.88", + "Test::Requires" : "0", + "base" : "0", + "lib" : "0" + } + } + }, + "provides" : { + "Package::Stash" : { + "file" : "lib/Package/Stash.pm", + "version" : "0.37" + }, + "Package::Stash::PP" : { + "file" : "lib/Package/Stash/PP.pm", + "version" : "0.37" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/doy/package-stash/issues" + }, + "homepage" : "http://metacpan.org/release/Package-Stash", + "repository" : { + "type" : "git", + "url" : "git://github.com/doy/package-stash.git", + "web" : "https://github.com/doy/package-stash" + } + }, + "version" : "0.37", + "x_Dist_Zilla" : { + "perl" : { + "version" : "5.020000" + }, + "plugins" : [ + { + "class" : "Dist::Zilla::Plugin::FileFinder::Filter", + "name" : "WeaverFinder", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "test", + "type" : "requires" + } + }, + "name" : "@DOY/TestMoreDoneTesting", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::GatherDir", + "name" : "@DOY/GatherDir", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::PruneCruft", + "name" : "@DOY/PruneCruft", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::ManifestSkip", + "name" : "@DOY/ManifestSkip", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::MetaYAML", + "name" : "@DOY/MetaYAML", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::License", + "name" : "@DOY/License", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Readme", + "name" : "@DOY/Readme", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::RunExtraTests", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : 1 + } + }, + "name" : "@DOY/RunExtraTests", + "version" : "0.022" + }, + { + "class" : "Dist::Zilla::Plugin::ExecDir", + "name" : "@DOY/ExecDir", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::ShareDir", + "name" : "@DOY/ShareDir", + "version" : "5.020" + }, + { + "class" : "inc::MMPackageStash", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : 1 + } + }, + "name" : "@DOY/=inc::MMPackageStash", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::Manifest", + "name" : "@DOY/Manifest", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::TestRelease", + "name" : "@DOY/TestRelease", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::ConfirmRelease", + "name" : "@DOY/ConfirmRelease", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::MetaConfig", + "name" : "@DOY/MetaConfig", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::MetaJSON", + "name" : "@DOY/MetaJSON", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::NextRelease", + "name" : "@DOY/NextRelease", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", + "name" : "@DOY/CheckChangesHasContent", + "version" : "0.006" + }, + { + "class" : "Dist::Zilla::Plugin::PkgVersion", + "name" : "@DOY/PkgVersion", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Authority", + "name" : "@DOY/Authority", + "version" : "1.006" + }, + { + "class" : "Dist::Zilla::Plugin::PodCoverageTests", + "name" : "@DOY/PodCoverageTests", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::PodSyntaxTests", + "name" : "@DOY/PodSyntaxTests", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Test::NoTabs", + "config" : { + "Dist::Zilla::Plugin::Test::NoTabs" : { + "finder" : [ + ":InstallModules", + ":ExecFiles", + ":TestFiles" + ] + } + }, + "name" : "@DOY/Test::NoTabs", + "version" : "0.08" + }, + { + "class" : "Dist::Zilla::Plugin::EOLTests", + "name" : "@DOY/EOLTests", + "version" : "0.02" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Compile", + "config" : { + "Dist::Zilla::Plugin::Test::Compile" : { + "filename" : "t/00-compile.t", + "module_finder" : [ + ":InstallModules" + ], + "script_finder" : [ + ":ExecFiles" + ] + } + }, + "name" : "@DOY/Test::Compile", + "version" : "2.043" + }, + { + "class" : "Dist::Zilla::Plugin::Metadata", + "name" : "@DOY/Metadata", + "version" : "3.03" + }, + { + "class" : "Dist::Zilla::Plugin::MetaResources", + "name" : "@DOY/MetaResources", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Check", + "config" : { + "Dist::Zilla::Plugin::Git::Check" : { + "untracked_files" : "die" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DOY/Git::Check", + "version" : "2.023" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "changelog", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "dist.ini", + "Changes" + ], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DOY/Git::Commit", + "version" : "2.023" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Tag", + "config" : { + "Dist::Zilla::Plugin::Git::Tag" : { + "branch" : null, + "signed" : 0, + "tag" : "0.37", + "tag_format" : "%v", + "tag_message" : "", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DOY/Git::Tag", + "version" : "2.023" + }, + { + "class" : "Dist::Zilla::Plugin::Git::NextVersion", + "config" : { + "Dist::Zilla::Plugin::Git::NextVersion" : { + "first_version" : "0.01", + "version_by_branch" : "0", + "version_regexp" : "(?^:^(\\d+\\.\\d+)$)" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DOY/Git::NextVersion", + "version" : "2.023" + }, + { + "class" : "Dist::Zilla::Plugin::ContributorsFromGit", + "name" : "@DOY/ContributorsFromGit", + "version" : "0.014" + }, + { + "class" : "Dist::Zilla::Plugin::MetaProvides::Package", + "config" : { + "Dist::Zilla::Plugin::MetaProvides::Package" : { + "finder_objects" : [ + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : "@DOY/MetaProvides::Package/AUTOVIV/:InstallModulesPM", + "version" : "5.020" + } + ] + }, + "Dist::Zilla::Role::MetaProvider::Provider" : { + "inherit_missing" : "1", + "inherit_version" : "1", + "meta_noindex" : "1" + } + }, + "name" : "@DOY/MetaProvides::Package", + "version" : "2.000002" + }, + { + "class" : "Dist::Zilla::Plugin::PodWeaver", + "config" : { + "Dist::Zilla::Plugin::PodWeaver" : { + "finder" : [ + "WeaverFinder" + ], + "plugins" : [ + { + "class" : "Pod::Weaver::Plugin::EnsurePod5", + "name" : "@CorePrep/EnsurePod5", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Plugin::H1Nester", + "name" : "@CorePrep/H1Nester", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Plugin::SingleEncoding", + "name" : "@Default/SingleEncoding", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Name", + "name" : "@Default/Name", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Version", + "name" : "@Default/Version", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "@Default/prelude", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "SYNOPSIS", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "DESCRIPTION", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "OVERVIEW", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "ATTRIBUTES", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "METHODS", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "FUNCTIONS", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Leftovers", + "name" : "@Default/Leftovers", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "@Default/postlude", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Authors", + "name" : "@Default/Authors", + "version" : "4.006" + }, + { + "class" : "Pod::Weaver::Section::Legal", + "name" : "@Default/Legal", + "version" : "4.006" + } + ] + } + }, + "name" : "@DOY/PodWeaver", + "version" : "4.005" + }, + { + "class" : "Dist::Zilla::Plugin::UploadToCPAN", + "name" : "@DOY/UploadToCPAN", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::AutoPrereqs", + "name" : "AutoPrereqs", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "runtime", + "type" : "recommends" + } + }, + "name" : "RuntimeRecommends", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "develop", + "type" : "requires" + } + }, + "name" : "DevelopRequires", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::Conflicts", + "name" : "Conflicts", + "version" : "0.16" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":InstallModules", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":IncModules", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":TestFiles", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ExecFiles", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ShareFiles", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":MainModule", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":AllFiles", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":NoFiles", + "version" : "5.020" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : "@DOY/MetaProvides::Package/AUTOVIV/:InstallModulesPM", + "version" : "5.020" + } + ], + "zilla" : { + "class" : "Dist::Zilla::Dist::Builder", + "config" : { + "is_trial" : "0" + }, + "version" : "5.020" + } + }, + "x_authority" : "cpan:DOY", + "x_breaks" : { + "Class::MOP" : "<= 1.08", + "MooseX::Method::Signatures" : "<= 0.36", + "MooseX::Role::WithOverloading" : "<= 0.08", + "namespace::clean" : "<= 0.18" + }, + "x_contributors" : [ + "Carlos Lima <carlos@multi>", + "Christian Walde <walde.christian@googlemail.com>", + "Dave Rolsky <autarch@urth.org>", + "Justin Hunter <justin.d.hunter@gmail.com>", + "Kent Fredric <kentfredric@gmail.com>", + "Niko Tyni <ntyni@debian.org>", + "Tim Bunce <Tim.Bunce@pobox.com>" + ] +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..6a22008 --- /dev/null +++ b/META.yml @@ -0,0 +1,421 @@ +--- +abstract: 'routines for manipulating stashes' +author: + - 'Jesse Luehrs <doy@tozt.net>' +build_requires: + File::Spec: '0' + IO::Handle: '0' + IPC::Open3: '0' + Test::Fatal: '0' + Test::More: '0.88' + Test::Requires: '0' + base: '0' + lib: '0' +configure_requires: + Config: '0' + Dist::CheckConflicts: '0.02' + ExtUtils::MakeMaker: '0' + File::Spec: '0' + Text::ParseWords: '0' +dynamic_config: 1 +generated_by: 'Dist::Zilla version 5.020, CPAN::Meta::Converter version 2.140640' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Package-Stash +provides: + Package::Stash: + file: lib/Package/Stash.pm + version: '0.37' + Package::Stash::PP: + file: lib/Package/Stash/PP.pm + version: '0.37' +recommends: + Package::Stash::XS: '0.26' +requires: + B: '0' + Carp: '0' + Dist::CheckConflicts: '0.02' + Getopt::Long: '0' + Module::Implementation: '0.06' + Scalar::Util: '0' + Symbol: '0' + constant: '0' + perl: '5.008001' + strict: '0' + warnings: '0' +resources: + bugtracker: https://github.com/doy/package-stash/issues + homepage: http://metacpan.org/release/Package-Stash + repository: git://github.com/doy/package-stash.git +version: '0.37' +x_Dist_Zilla: + perl: + version: '5.020000' + plugins: + - + class: Dist::Zilla::Plugin::FileFinder::Filter + name: WeaverFinder + version: '5.020' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: test + type: requires + name: '@DOY/TestMoreDoneTesting' + version: '5.020' + - + class: Dist::Zilla::Plugin::GatherDir + name: '@DOY/GatherDir' + version: '5.020' + - + class: Dist::Zilla::Plugin::PruneCruft + name: '@DOY/PruneCruft' + version: '5.020' + - + class: Dist::Zilla::Plugin::ManifestSkip + name: '@DOY/ManifestSkip' + version: '5.020' + - + class: Dist::Zilla::Plugin::MetaYAML + name: '@DOY/MetaYAML' + version: '5.020' + - + class: Dist::Zilla::Plugin::License + name: '@DOY/License' + version: '5.020' + - + class: Dist::Zilla::Plugin::Readme + name: '@DOY/Readme' + version: '5.020' + - + class: Dist::Zilla::Plugin::RunExtraTests + config: + Dist::Zilla::Role::TestRunner: + default_jobs: 1 + name: '@DOY/RunExtraTests' + version: '0.022' + - + class: Dist::Zilla::Plugin::ExecDir + name: '@DOY/ExecDir' + version: '5.020' + - + class: Dist::Zilla::Plugin::ShareDir + name: '@DOY/ShareDir' + version: '5.020' + - + class: inc::MMPackageStash + config: + Dist::Zilla::Role::TestRunner: + default_jobs: 1 + name: '@DOY/=inc::MMPackageStash' + version: ~ + - + class: Dist::Zilla::Plugin::Manifest + name: '@DOY/Manifest' + version: '5.020' + - + class: Dist::Zilla::Plugin::TestRelease + name: '@DOY/TestRelease' + version: '5.020' + - + class: Dist::Zilla::Plugin::ConfirmRelease + name: '@DOY/ConfirmRelease' + version: '5.020' + - + class: Dist::Zilla::Plugin::MetaConfig + name: '@DOY/MetaConfig' + version: '5.020' + - + class: Dist::Zilla::Plugin::MetaJSON + name: '@DOY/MetaJSON' + version: '5.020' + - + class: Dist::Zilla::Plugin::NextRelease + name: '@DOY/NextRelease' + version: '5.020' + - + class: Dist::Zilla::Plugin::CheckChangesHasContent + name: '@DOY/CheckChangesHasContent' + version: '0.006' + - + class: Dist::Zilla::Plugin::PkgVersion + name: '@DOY/PkgVersion' + version: '5.020' + - + class: Dist::Zilla::Plugin::Authority + name: '@DOY/Authority' + version: '1.006' + - + class: Dist::Zilla::Plugin::PodCoverageTests + name: '@DOY/PodCoverageTests' + version: '5.020' + - + class: Dist::Zilla::Plugin::PodSyntaxTests + name: '@DOY/PodSyntaxTests' + version: '5.020' + - + class: Dist::Zilla::Plugin::Test::NoTabs + config: + Dist::Zilla::Plugin::Test::NoTabs: + finder: + - ':InstallModules' + - ':ExecFiles' + - ':TestFiles' + name: '@DOY/Test::NoTabs' + version: '0.08' + - + class: Dist::Zilla::Plugin::EOLTests + name: '@DOY/EOLTests' + version: '0.02' + - + class: Dist::Zilla::Plugin::Test::Compile + config: + Dist::Zilla::Plugin::Test::Compile: + filename: t/00-compile.t + module_finder: + - ':InstallModules' + script_finder: + - ':ExecFiles' + name: '@DOY/Test::Compile' + version: '2.043' + - + class: Dist::Zilla::Plugin::Metadata + name: '@DOY/Metadata' + version: '3.03' + - + class: Dist::Zilla::Plugin::MetaResources + name: '@DOY/MetaResources' + version: '5.020' + - + class: Dist::Zilla::Plugin::Git::Check + config: + Dist::Zilla::Plugin::Git::Check: + untracked_files: die + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: [] + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DOY/Git::Check' + version: '2.023' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: changelog + time_zone: local + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - dist.ini + - Changes + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DOY/Git::Commit' + version: '2.023' + - + class: Dist::Zilla::Plugin::Git::Tag + config: + Dist::Zilla::Plugin::Git::Tag: + branch: ~ + signed: 0 + tag: '0.37' + tag_format: '%v' + tag_message: '' + time_zone: local + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DOY/Git::Tag' + version: '2.023' + - + class: Dist::Zilla::Plugin::Git::NextVersion + config: + Dist::Zilla::Plugin::Git::NextVersion: + first_version: '0.01' + version_by_branch: '0' + version_regexp: (?^:^(\d+\.\d+)$) + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DOY/Git::NextVersion' + version: '2.023' + - + class: Dist::Zilla::Plugin::ContributorsFromGit + name: '@DOY/ContributorsFromGit' + version: '0.014' + - + class: Dist::Zilla::Plugin::MetaProvides::Package + config: + Dist::Zilla::Plugin::MetaProvides::Package: + finder_objects: + - + class: Dist::Zilla::Plugin::FinderCode + name: '@DOY/MetaProvides::Package/AUTOVIV/:InstallModulesPM' + version: '5.020' + Dist::Zilla::Role::MetaProvider::Provider: + inherit_missing: '1' + inherit_version: '1' + meta_noindex: '1' + name: '@DOY/MetaProvides::Package' + version: '2.000002' + - + class: Dist::Zilla::Plugin::PodWeaver + config: + Dist::Zilla::Plugin::PodWeaver: + finder: + - WeaverFinder + plugins: + - + class: Pod::Weaver::Plugin::EnsurePod5 + name: '@CorePrep/EnsurePod5' + version: '4.006' + - + class: Pod::Weaver::Plugin::H1Nester + name: '@CorePrep/H1Nester' + version: '4.006' + - + class: Pod::Weaver::Plugin::SingleEncoding + name: '@Default/SingleEncoding' + version: '4.006' + - + class: Pod::Weaver::Section::Name + name: '@Default/Name' + version: '4.006' + - + class: Pod::Weaver::Section::Version + name: '@Default/Version' + version: '4.006' + - + class: Pod::Weaver::Section::Region + name: '@Default/prelude' + version: '4.006' + - + class: Pod::Weaver::Section::Generic + name: SYNOPSIS + version: '4.006' + - + class: Pod::Weaver::Section::Generic + name: DESCRIPTION + version: '4.006' + - + class: Pod::Weaver::Section::Generic + name: OVERVIEW + version: '4.006' + - + class: Pod::Weaver::Section::Collect + name: ATTRIBUTES + version: '4.006' + - + class: Pod::Weaver::Section::Collect + name: METHODS + version: '4.006' + - + class: Pod::Weaver::Section::Collect + name: FUNCTIONS + version: '4.006' + - + class: Pod::Weaver::Section::Leftovers + name: '@Default/Leftovers' + version: '4.006' + - + class: Pod::Weaver::Section::Region + name: '@Default/postlude' + version: '4.006' + - + class: Pod::Weaver::Section::Authors + name: '@Default/Authors' + version: '4.006' + - + class: Pod::Weaver::Section::Legal + name: '@Default/Legal' + version: '4.006' + name: '@DOY/PodWeaver' + version: '4.005' + - + class: Dist::Zilla::Plugin::UploadToCPAN + name: '@DOY/UploadToCPAN' + version: '5.020' + - + class: Dist::Zilla::Plugin::AutoPrereqs + name: AutoPrereqs + version: '5.020' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: runtime + type: recommends + name: RuntimeRecommends + version: '5.020' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: develop + type: requires + name: DevelopRequires + version: '5.020' + - + class: Dist::Zilla::Plugin::Conflicts + name: Conflicts + version: '0.16' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':InstallModules' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':IncModules' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':TestFiles' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ExecFiles' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ShareFiles' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':MainModule' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':AllFiles' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':NoFiles' + version: '5.020' + - + class: Dist::Zilla::Plugin::FinderCode + name: '@DOY/MetaProvides::Package/AUTOVIV/:InstallModulesPM' + version: '5.020' + zilla: + class: Dist::Zilla::Dist::Builder + config: + is_trial: '0' + version: '5.020' +x_authority: cpan:DOY +x_breaks: + Class::MOP: '<= 1.08' + MooseX::Method::Signatures: '<= 0.36' + MooseX::Role::WithOverloading: '<= 0.08' + namespace::clean: '<= 0.18' +x_contributors: + - 'Carlos Lima <carlos@multi>' + - 'Christian Walde <walde.christian@googlemail.com>' + - 'Dave Rolsky <autarch@urth.org>' + - 'Justin Hunter <justin.d.hunter@gmail.com>' + - 'Kent Fredric <kentfredric@gmail.com>' + - 'Niko Tyni <ntyni@debian.org>' + - 'Tim Bunce <Tim.Bunce@pobox.com>' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..f78de94 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,165 @@ +# This Makefile.PL for Package-Stash was generated by +# inc::MMPackageStash <self> +# and Dist::Zilla::Plugin::MakeMaker::Awesome 0.27. +# Don't edit it but the dist.ini and plugins used to construct it. + +use strict; +use warnings; + +use 5.008001; +use ExtUtils::MakeMaker; +check_conflicts(); + +my %WriteMakefileArgs = ( + "ABSTRACT" => "routines for manipulating stashes", + "AUTHOR" => "Jesse Luehrs <doy\@tozt.net>", + "CONFIGURE_REQUIRES" => { + "Config" => 0, + "Dist::CheckConflicts" => "0.02", + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "Text::ParseWords" => 0 + }, + "DISTNAME" => "Package-Stash", + "EXE_FILES" => [ + "bin/package-stash-conflicts" + ], + "LICENSE" => "perl", + "NAME" => "Package::Stash", + "PREREQ_PM" => { + "B" => 0, + "Carp" => 0, + "Dist::CheckConflicts" => "0.02", + "Getopt::Long" => 0, + "Module::Implementation" => "0.06", + "Scalar::Util" => 0, + "Symbol" => 0, + "constant" => 0, + "strict" => 0, + "warnings" => 0 + }, + "TEST_REQUIRES" => { + "File::Spec" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "Test::Fatal" => 0, + "Test::More" => "0.88", + "Test::Requires" => 0, + "base" => 0, + "lib" => 0 + }, + "VERSION" => "0.37", + "test" => { + "TESTS" => "t/*.t t/impl-selection/*.t" + } +); + +my %FallbackPrereqs = ( + "B" => 0, + "Carp" => 0, + "Dist::CheckConflicts" => "0.02", + "File::Spec" => 0, + "Getopt::Long" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "Module::Implementation" => "0.06", + "Scalar::Util" => 0, + "Symbol" => 0, + "Test::Fatal" => 0, + "Test::More" => "0.88", + "Test::Requires" => 0, + "base" => 0, + "constant" => 0, + "lib" => 0, + "strict" => 0, + "warnings" => 0 +); + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + delete $WriteMakefileArgs{TEST_REQUIRES}; + delete $WriteMakefileArgs{BUILD_REQUIRES}; + $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +$WriteMakefileArgs{PREREQ_PM}{'Package::Stash::XS'} = 0.26 + if !parse_args()->{PUREPERL_ONLY} && can_cc(); + +WriteMakefile(%WriteMakefileArgs); + +use Config (); +use File::Spec (); +use Text::ParseWords (); + +# check if we can run some command +sub can_run { + my ($cmd) = @_; + + my $_cmd = $cmd; + return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + next if $dir eq ''; + my $abs = File::Spec->catfile($dir, $_[0]); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +# can we locate a (the) C compiler +sub can_cc { + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# XXX this is gross, but apparently it's the least gross option? +sub parse_args { + my $tmp = {}; + # copied from EUMM + ExtUtils::MakeMaker::parse_args( + $tmp, + Text::ParseWords::shellwords($ENV{PERL_MM_OPT} || ''), + @ARGV, + ); + return $tmp->{ARGS} || {}; +} + +sub check_conflicts { + if ( eval { require 'lib/Package/Stash/Conflicts.pm'; 1; } ) { + if ( eval { Package::Stash::Conflicts->check_conflicts; 1 } ) { + return; + } + else { + my $err = $@; + $err =~ s/^/ /mg; + warn "***\n$err***\n"; + } + } + else { + print <<'EOF'; +*** + Your toolchain doesn't support configure_requires, so Dist::CheckConflicts + hasn't been installed yet. You should check for conflicting modules + manually using the 'package-stash-conflicts' script that is installed with + this distribution once the installation finishes. +*** +EOF + } + + return if $ENV{AUTOMATED_TESTING} || $ENV{NONINTERACTIVE_TESTING}; + + # More or less copied from Module::Build + return if $ENV{PERL_MM_USE_DEFAULT}; + return unless -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); + + sleep 4; +} @@ -0,0 +1,15 @@ + + +This archive contains the distribution Package-Stash, +version 0.37: + + routines for manipulating stashes + +This software is copyright (c) 2014 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. + + +This README file was generated by Dist::Zilla::Plugin::Readme v5.020. + diff --git a/bin/package-stash-conflicts b/bin/package-stash-conflicts new file mode 100644 index 0000000..c4c8b4b --- /dev/null +++ b/bin/package-stash-conflicts @@ -0,0 +1,49 @@ +#!/usr/bin/perl + +use strict; +use warnings; +# PODNAME: package-stash-conflicts + +# this script was generated with Dist::Zilla::Plugin::Conflicts 0.16 + +use Getopt::Long; +use Package::Stash::Conflicts; + +my $verbose; +GetOptions( 'verbose|v' => \$verbose ); + +if ($verbose) { + Package::Stash::Conflicts->check_conflicts; +} +else { + my @conflicts = Package::Stash::Conflicts->calculate_conflicts; + print "$_\n" for map { $_->{package} } @conflicts; + exit @conflicts; +} + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +package-stash-conflicts + +=head1 VERSION + +version 0.37 + +=head1 AUTHOR + +Jesse Luehrs <doy@tozt.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 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/dist.ini b/dist.ini new file mode 100644 index 0000000..7407a20 --- /dev/null +++ b/dist.ini @@ -0,0 +1,39 @@ +name = Package-Stash +author = Jesse Luehrs <doy@tozt.net> +license = Perl_5 +copyright_holder = Jesse Luehrs + +[FileFinder::Filter / WeaverFinder] +finder = :InstallModules +finder = :ExecFiles +skip = Conflicts.pm$ + +[@DOY] +:version = 0.14 +dist = Package-Stash +repository = github +awesome = =inc::MMPackageStash +dynamic_config = 1 +CompileTests_skip = [Cc]onflicts$ +Authority_finder = WeaverFinder +PodWeaver_finder = WeaverFinder + +[AutoPrereqs] +skip = Variable::Magic + +[Prereqs / RuntimeRecommends] +; XXX keep this in sync with inc/MMPackageStash.pm +Package::Stash::XS = 0.26 + +[Prereqs / DevelopRequires] +Test::LeakTrace = 0 +; XXX can't just have a dep here because it won't install on 5.12 and below +; see .travis.yml +; Package::Anon = 0 + +[Conflicts] +-script = bin/package-stash-conflicts +Class::MOP = 1.08 +MooseX::Role::WithOverloading = 0.08 +namespace::clean = 0.18 +MooseX::Method::Signatures = 0.36 diff --git a/inc/MMPackageStash.pm b/inc/MMPackageStash.pm new file mode 100644 index 0000000..7e27961 --- /dev/null +++ b/inc/MMPackageStash.pm @@ -0,0 +1,86 @@ +package inc::MMPackageStash; +use Moose; + +extends 'Dist::Zilla::Plugin::MakeMaker::Awesome'; + +# XXX: this is pretty gross, it should be possible to clean this up later +around _build_MakeFile_PL_template => sub { + my $orig = shift; + my $self = shift; + + # XXX keep this in sync with dist.ini + my $xs_version = 0.26; + + # can_run and can_cc copied from M::I + my $helpers = <<'HELPERS'; +use Config (); +use File::Spec (); +use Text::ParseWords (); + +# check if we can run some command +sub can_run { + my ($cmd) = @_; + + my $_cmd = $cmd; + return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + next if $dir eq ''; + my $abs = File::Spec->catfile($dir, $_[0]); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +# can we locate a (the) C compiler +sub can_cc { + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# XXX this is gross, but apparently it's the least gross option? +sub parse_args { + my $tmp = {}; + # copied from EUMM + ExtUtils::MakeMaker::parse_args( + $tmp, + Text::ParseWords::shellwords($ENV{PERL_MM_OPT} || ''), + @ARGV, + ); + return $tmp->{ARGS} || {}; +} +HELPERS + + my $fixup_prereqs = <<PREREQS; +\$WriteMakefileArgs{PREREQ_PM}{'Package::Stash::XS'} = $xs_version + if !parse_args()->{PUREPERL_ONLY} && can_cc(); +PREREQS + + my $template = $self->$orig(@_); + $template =~ s/(WriteMakefile\()/$fixup_prereqs\n$1/; + $template .= $helpers; + + return $template; +}; + +after register_prereqs => sub { + my $self = shift; + $self->zilla->register_prereqs( + { phase => 'configure' }, + 'Config' => 0, + 'File::Spec' => 0, + 'Text::ParseWords' => 0, + ); +}; + +__PACKAGE__->meta->make_immutable; +no Moose; + +1; diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm new file mode 100644 index 0000000..58727a6 --- /dev/null +++ b/lib/Package/Stash.pm @@ -0,0 +1,284 @@ +package Package::Stash; +BEGIN { + $Package::Stash::AUTHORITY = 'cpan:DOY'; +} +$Package::Stash::VERSION = '0.37'; +use strict; +use warnings; +use 5.008001; +# ABSTRACT: routines for manipulating stashes + +our $IMPLEMENTATION; + +use Module::Implementation 0.06; + +BEGIN { + local $ENV{PACKAGE_STASH_IMPLEMENTATION} = $IMPLEMENTATION + if ( $IMPLEMENTATION and not $ENV{PACKAGE_STASH_IMPLEMENTATION} ); + + Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => [qw( + new + name + namespace + add_symbol + remove_glob + has_symbol + get_symbol + get_or_add_symbol + remove_symbol + list_all_symbols + get_all_symbols + )], + )->(); + $IMPLEMENTATION = Module::Implementation::implementation_for(__PACKAGE__); +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Package::Stash - routines for manipulating stashes + +=head1 VERSION + +version 0.37 + +=head1 SYNOPSIS + + my $stash = Package::Stash->new('Foo'); + $stash->add_symbol('%foo', {bar => 1}); + # $Foo::foo{bar} == 1 + $stash->has_symbol('$foo') # false + my $namespace = $stash->namespace; + *{ $namespace->{foo} }{HASH} # {bar => 1} + +=head1 DESCRIPTION + +Manipulating stashes (Perl's symbol tables) is occasionally necessary, but +incredibly messy, and easy to get wrong. This module hides all of that behind a +simple API. + +NOTE: Most methods in this class require a variable specification that includes +a sigil. If this sigil is absent, it is assumed to represent the IO slot. + +Due to limitations in the typeglob API available to perl code, and to typeglob +manipulation in perl being quite slow, this module provides two +implementations - one in pure perl, and one using XS. The XS implementation is +to be preferred for most usages; the pure perl one is provided for cases where +XS modules are not a possibility. The current implementation in use can be set +by setting C<$ENV{PACKAGE_STASH_IMPLEMENTATION}> or +C<$Package::Stash::IMPLEMENTATION> before loading Package::Stash (with the +environment variable taking precedence), otherwise, it will use the XS +implementation if possible, falling back to the pure perl one. + +=head1 METHODS + +=head2 new $package_name + +Creates a new C<Package::Stash> object, for the package given as the only +argument. + +=head2 name + +Returns the name of the package that this object represents. + +=head2 namespace + +Returns the raw stash itself. + +=head2 add_symbol $variable $value %opts + +Adds a new package symbol, for the symbol given as C<$variable>, and optionally +gives it an initial value of C<$value>. C<$variable> should be the name of +variable including the sigil, so + + Package::Stash->new('Foo')->add_symbol('%foo') + +will create C<%Foo::foo>. + +Valid options (all optional) are C<filename>, C<first_line_num>, and +C<last_line_num>. + +C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can +be used to indicate where the symbol should be regarded as having been defined. +Currently these values are only used if the symbol is a subroutine ('C<&>' +sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub> +hash is updated to record the values of C<filename>, C<first_line_num>, and +C<last_line_num> for the subroutine. If these are not passed, their values are +inferred (as much as possible) from C<caller> information. + +This is especially useful for debuggers and profilers, which use C<%DB::sub> to +determine where the source code for a subroutine can be found. See +L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more +information about C<%DB::sub>. + +=head2 remove_glob $name + +Removes all package variables with the given name, regardless of sigil. + +=head2 has_symbol $variable + +Returns whether or not the given package variable (including sigil) exists. + +=head2 get_symbol $variable + +Returns the value of the given package variable (including sigil). + +=head2 get_or_add_symbol $variable + +Like C<get_symbol>, except that it will return an empty hashref or +arrayref if the variable doesn't exist. + +=head2 remove_symbol $variable + +Removes the package variable described by C<$variable> (which includes the +sigil); other variables with the same name but different sigils will be +untouched. + +=head2 list_all_symbols $type_filter + +Returns a list of package variable names in the package, without sigils. If a +C<type_filter> is passed, it is used to select package variables of a given +type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH', +etc). Note that if the package contained any C<BEGIN> blocks, perl will leave +an empty typeglob in the C<BEGIN> slot, so this will show up if no filter is +used (and similarly for C<INIT>, C<END>, etc). + +=head2 get_all_symbols $type_filter + +Returns a hashref, keyed by the variable names in the package. If +C<$type_filter> is passed, the hash will contain every variable of that type in +the package as values, otherwise, it will contain the typeglobs corresponding +to the variable names (basically, a clone of the stash). + +=head1 WORKING WITH VARIABLES + +It is important to note, that when working with scalar variables, the default +behavior is to B<copy> values. + + my $stash = Package::Stash->new('Some::Namespace'); + my $variable = 1; + # $Some::Namespace::name is a copy of $variable + $stash->add_symbol('$name', $variable); + $variable++ + # $Some::Namespace::name == 1 , $variable == 2 + +This will likely confuse people who expect it to work the same as typeglob +assignment, which simply creates new references to existing variables. + + my $variable = 1; + { + no strict 'refs'; + # assign $Package::Stash::name = $variable + *{'Package::Stash::name'} = \$variable; + } + $variable++ # affects both names + +If this behaviour is desired when working with Package::Stash, simply pass +Package::Stash a scalar ref: + + my $stash = Package::Stash->new('Some::Namespace'); + my $variable = 1; + # $Some::Namespace::name is now $variable + $stash->add_symbol('$name', \$variable); + $variable++ + # $Some::Namespace::name == 2 , $variable == 2 + +This will be what you want as well if you're ever working with L<Readonly> +variables: + + use Readonly; + Readonly my $value, 'hello'; + + $stash->add_symbol('$name', \$value); # reference + print $Some::Namespace::name; # hello + # Tries to modify the read-only 'hello' and dies. + $Some::Namespace::name .= " world"; + + $stash->add_symbol('$name', $value); # copy + print $Some::Namespace::name; # hello + # No problem, modifying a copy, not the original + $Some::Namespace::name .= " world"; + +=head1 BUGS / CAVEATS + +=over 4 + +=item * Prior to perl 5.10, scalar slots are only considered to exist if they are defined + +This is due to a shortcoming within perl itself. See +L<perlref/Making References> point 7 for more information. + +=item * GLOB and FORMAT variables are not (yet) accessible through this module. + +=item * Also, see the BUGS section for the specific backends (L<Package::Stash::XS> and L<Package::Stash::PP>) + +=back + +Please report any bugs to GitHub Issues at +L<https://github.com/doy/package-stash/issues>. + +=head1 SEE ALSO + +=over 4 + +=item * L<Class::MOP::Package> + +This module is a factoring out of code that used to live here + +=back + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Package::Stash + +You can also look for information at: + +=over 4 + +=item * MetaCPAN + +L<https://metacpan.org/release/Package-Stash> + +=item * Github + +L<https://github.com/doy/package-stash> + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/d/Package-Stash> + +=back + +=head1 HISTORY + +Based on code from L<Class::MOP::Package>, by Stevan Little and the Moose +Cabal. + +=head1 AUTHOR + +Jesse Luehrs <doy@tozt.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 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/lib/Package/Stash/Conflicts.pm b/lib/Package/Stash/Conflicts.pm new file mode 100644 index 0000000..adb3a4c --- /dev/null +++ b/lib/Package/Stash/Conflicts.pm @@ -0,0 +1,35 @@ +package # hide from PAUSE + Package::Stash::Conflicts; + +use strict; +use warnings; + +# this module was generated with Dist::Zilla::Plugin::Conflicts 0.16 + +use Dist::CheckConflicts + -dist => 'Package::Stash', + -conflicts => { + 'Class::MOP' => '1.08', + 'MooseX::Method::Signatures' => '0.36', + 'MooseX::Role::WithOverloading' => '0.08', + 'namespace::clean' => '0.18', + }, + -also => [ qw( + B + Carp + Dist::CheckConflicts + Getopt::Long + Module::Implementation + Scalar::Util + Symbol + constant + strict + warnings + ) ], + +; + +1; + +# ABSTRACT: Provide information on conflicts for Package::Stash +# Dist::Zilla: -PodWeaver diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm new file mode 100644 index 0000000..1e17d4b --- /dev/null +++ b/lib/Package/Stash/PP.pm @@ -0,0 +1,530 @@ +package Package::Stash::PP; +BEGIN { + $Package::Stash::PP::AUTHORITY = 'cpan:DOY'; +} +$Package::Stash::PP::VERSION = '0.37'; +use strict; +use warnings; +# ABSTRACT: pure perl implementation of the Package::Stash API + +use B; +use Carp qw(confess); +use Scalar::Util qw(blessed reftype weaken); +use Symbol; +# before 5.12, assigning to the ISA glob would make it lose its magical ->isa +# powers +use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012); +# before 5.10, stashes don't ever seem to drop to a refcount of zero, so +# weakening them isn't helpful +use constant BROKEN_WEAK_STASH => ($] < 5.010); +# before 5.10, the scalar slot was always treated as existing if the +# glob existed +use constant BROKEN_SCALAR_INITIALIZATION => ($] < 5.010); +# add_method on anon stashes triggers rt.perl #1804 otherwise +# fixed in perl commit v5.13.3-70-g0fe688f +use constant BROKEN_GLOB_ASSIGNMENT => ($] < 5.013004); +# pre-5.10, ->isa lookups were cached in the ::ISA::CACHE:: slot +use constant HAS_ISA_CACHE => ($] < 5.010); + + +sub new { + my $class = shift; + my ($package) = @_; + + if (!defined($package) || (ref($package) && reftype($package) ne 'HASH')) { + confess "Package::Stash->new must be passed the name of the " + . "package to access"; + } + elsif (ref($package) && reftype($package) eq 'HASH') { + confess "The PP implementation of Package::Stash does not support " + . "anonymous stashes before perl 5.14" + if BROKEN_GLOB_ASSIGNMENT; + + return bless { + 'namespace' => $package, + }, $class; + } + elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) { + return bless { + 'package' => $package, + }, $class; + } + else { + confess "$package is not a module name"; + } + +} + +sub name { + confess "Can't call name as a class method" + unless blessed($_[0]); + confess "Can't get the name of an anonymous package" + unless defined($_[0]->{package}); + return $_[0]->{package}; +} + +sub namespace { + confess "Can't call namespace as a class method" + unless blessed($_[0]); + + if (BROKEN_WEAK_STASH) { + no strict 'refs'; + return \%{$_[0]->name . '::'}; + } + else { + return $_[0]->{namespace} if defined $_[0]->{namespace}; + + { + no strict 'refs'; + $_[0]->{namespace} = \%{$_[0]->name . '::'}; + } + + weaken($_[0]->{namespace}); + + return $_[0]->{namespace}; + } +} + +{ + my %SIGIL_MAP = ( + '$' => 'SCALAR', + '@' => 'ARRAY', + '%' => 'HASH', + '&' => 'CODE', + '' => 'IO', + ); + + sub _deconstruct_variable_name { + my ($variable) = @_; + + my @ret; + if (ref($variable) eq 'HASH') { + @ret = @{$variable}{qw[name sigil type]}; + } + else { + (defined $variable && length $variable) + || confess "You must pass a variable name"; + + my $sigil = substr($variable, 0, 1, ''); + + if (exists $SIGIL_MAP{$sigil}) { + @ret = ($variable, $sigil, $SIGIL_MAP{$sigil}); + } + else { + @ret = ("${sigil}${variable}", '', $SIGIL_MAP{''}); + } + } + + # XXX in pure perl, this will access things in inner packages, + # in xs, this will segfault - probably look more into this at + # some point + ($ret[0] !~ /::/) + || confess "Variable names may not contain ::"; + + return @ret; + } +} + +sub _valid_for_type { + my ($value, $type) = @_; + if ($type eq 'HASH' || $type eq 'ARRAY' + || $type eq 'IO' || $type eq 'CODE') { + return reftype($value) eq $type; + } + else { + my $ref = reftype($value); + return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING'; + } +} + +sub add_symbol { + my ($self, $variable, $initial_value, %opts) = @_; + + my ($name, $sigil, $type) = _deconstruct_variable_name($variable); + + if (@_ > 2) { + _valid_for_type($initial_value, $type) + || confess "$initial_value is not of type $type"; + + # cheap fail-fast check for PERLDBf_SUBLINE and '&' + if ($^P and $^P & 0x10 && $sigil eq '&') { + my $filename = $opts{filename}; + my $first_line_num = $opts{first_line_num}; + + (undef, $filename, $first_line_num) = caller + if not defined $filename; + + my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0); + + # http://perldoc.perl.org/perldebguts.html#Debugger-Internals + $DB::sub{$self->name . '::' . $name} = "$filename:$first_line_num-$last_line_num"; + } + } + + if (BROKEN_GLOB_ASSIGNMENT) { + if (@_ > 2) { + no strict 'refs'; + no warnings 'redefine'; + *{ $self->name . '::' . $name } = ref $initial_value + ? $initial_value : \$initial_value; + } + else { + no strict 'refs'; + if (BROKEN_ISA_ASSIGNMENT && $name eq 'ISA') { + *{ $self->name . '::' . $name }; + } + else { + my $undef = _undef_ref_for_type($type); + *{ $self->name . '::' . $name } = $undef; + } + } + } + else { + my $namespace = $self->namespace; + { + # using glob aliasing instead of Symbol::gensym, because otherwise, + # magic doesn't get applied properly. + # see <20120710063744.19360.qmail@lists-nntp.develooper.com> on p5p + local *__ANON__:: = $namespace; + no strict 'refs'; + no warnings 'void'; + no warnings 'once'; + *{"__ANON__::$name"}; + } + + if (@_ > 2) { + no warnings 'redefine'; + *{ $namespace->{$name} } = ref $initial_value + ? $initial_value : \$initial_value; + } + else { + return if BROKEN_ISA_ASSIGNMENT && $name eq 'ISA'; + *{ $namespace->{$name} } = _undef_ref_for_type($type); + } + } +} + +sub _undef_ref_for_type { + my ($type) = @_; + + if ($type eq 'ARRAY') { + return []; + } + elsif ($type eq 'HASH') { + return {}; + } + elsif ($type eq 'SCALAR') { + return \undef; + } + elsif ($type eq 'IO') { + return Symbol::geniosym; + } + elsif ($type eq 'CODE') { + confess "Don't know how to vivify CODE variables"; + } + else { + confess "Unknown type $type in vivication"; + } +} + +sub remove_glob { + my ($self, $name) = @_; + delete $self->namespace->{$name}; +} + +sub has_symbol { + my ($self, $variable) = @_; + + my ($name, $sigil, $type) = _deconstruct_variable_name($variable); + + my $namespace = $self->namespace; + + return unless exists $namespace->{$name}; + + my $entry_ref = \$namespace->{$name}; + if (reftype($entry_ref) eq 'GLOB') { + if ($type eq 'SCALAR') { + if (BROKEN_SCALAR_INITIALIZATION) { + return defined ${ *{$entry_ref}{$type} }; + } + else { + my $sv = B::svref_2object($entry_ref)->SV; + return $sv->isa('B::SV') + || ($sv->isa('B::SPECIAL') + && $B::specialsv_name[$$sv] ne 'Nullsv'); + } + } + else { + return defined *{$entry_ref}{$type}; + } + } + else { + # a symbol table entry can be -1 (stub), string (stub with prototype), + # or reference (constant) + return $type eq 'CODE'; + } +} + +sub get_symbol { + my ($self, $variable, %opts) = @_; + + my ($name, $sigil, $type) = _deconstruct_variable_name($variable); + + my $namespace = $self->namespace; + + if (!exists $namespace->{$name}) { + if ($opts{vivify}) { + $self->add_symbol($variable); + } + else { + return undef; + } + } + + my $entry_ref = \$namespace->{$name}; + + if (ref($entry_ref) eq 'GLOB') { + return *{$entry_ref}{$type}; + } + else { + if ($type eq 'CODE') { + if (BROKEN_GLOB_ASSIGNMENT || defined($self->{package})) { + no strict 'refs'; + return \&{ $self->name . '::' . $name }; + } + + # XXX we should really be able to support arbitrary anonymous + # stashes here... (not just via Package::Anon) + if (blessed($namespace) && $namespace->isa('Package::Anon')) { + # ->can will call gv_init for us, which inflates the glob + # don't know how to do this in general + $namespace->bless(\(my $foo))->can($name); + } + else { + confess "Don't know how to inflate a " . ref($entry_ref) + . " into a full coderef (perhaps you could use" + . " Package::Anon instead of a bare stash?)" + } + + return *{ $namespace->{$name} }{CODE}; + } + else { + return undef; + } + } +} + +sub get_or_add_symbol { + my $self = shift; + $self->get_symbol(@_, vivify => 1); +} + +sub remove_symbol { + my ($self, $variable) = @_; + + my ($name, $sigil, $type) = _deconstruct_variable_name($variable); + + # FIXME: + # no doubt this is grossly inefficient and + # could be done much easier and faster in XS + + my %desc = ( + SCALAR => { sigil => '$', type => 'SCALAR', name => $name }, + ARRAY => { sigil => '@', type => 'ARRAY', name => $name }, + HASH => { sigil => '%', type => 'HASH', name => $name }, + CODE => { sigil => '&', type => 'CODE', name => $name }, + IO => { sigil => '', type => 'IO', name => $name }, + ); + confess "This should never ever ever happen" if !$desc{$type}; + + my @types_to_store = grep { $type ne $_ && $self->has_symbol($desc{$_}) } + keys %desc; + my %values = map { $_, $self->get_symbol($desc{$_}) } @types_to_store; + + $values{SCALAR} = $self->get_symbol($desc{SCALAR}) + if !defined $values{SCALAR} + && $type ne 'SCALAR' + && BROKEN_SCALAR_INITIALIZATION; + + $self->remove_glob($name); + + $self->add_symbol($desc{$_} => $values{$_}) + for grep { defined $values{$_} } keys %values; +} + +sub list_all_symbols { + my ($self, $type_filter) = @_; + + my $namespace = $self->namespace; + if (HAS_ISA_CACHE) { + return grep { $_ ne '::ISA::CACHE::' } keys %{$namespace} + unless defined $type_filter; + } + else { + return keys %{$namespace} + unless defined $type_filter; + } + + # NOTE: + # or we can filter based on + # type (SCALAR|ARRAY|HASH|CODE) + if ($type_filter eq 'CODE') { + return grep { + # any non-typeglob in the symbol table is a constant or stub + ref(\$namespace->{$_}) ne 'GLOB' + # regular subs are stored in the CODE slot of the typeglob + || defined(*{$namespace->{$_}}{CODE}) + } keys %{$namespace}; + } + elsif ($type_filter eq 'SCALAR') { + return grep { + !(HAS_ISA_CACHE && $_ eq '::ISA::CACHE::') && + (BROKEN_SCALAR_INITIALIZATION + ? (ref(\$namespace->{$_}) eq 'GLOB' + && defined(${*{$namespace->{$_}}{'SCALAR'}})) + : (do { + my $entry = \$namespace->{$_}; + ref($entry) eq 'GLOB' + && B::svref_2object($entry)->SV->isa('B::SV') + })) + } keys %{$namespace}; + } + else { + return grep { + ref(\$namespace->{$_}) eq 'GLOB' + && defined(*{$namespace->{$_}}{$type_filter}) + } keys %{$namespace}; + } +} + +sub get_all_symbols { + my ($self, $type_filter) = @_; + + my $namespace = $self->namespace; + return { %{$namespace} } unless defined $type_filter; + + return { + map { $_ => $self->get_symbol({name => $_, type => $type_filter}) } + $self->list_all_symbols($type_filter) + } +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Package::Stash::PP - pure perl implementation of the Package::Stash API + +=head1 VERSION + +version 0.37 + +=head1 SYNOPSIS + + use Package::Stash; + +=head1 DESCRIPTION + +This is a backend for L<Package::Stash> implemented in pure perl, for those without a compiler or who would like to use this inline in scripts. + +=head1 BUGS + +=over 4 + +=item * remove_symbol also replaces the associated typeglob + +This can cause unexpected behavior when doing manipulation at compile time - +removing subroutines will still allow them to be called from within the package +as subroutines (although they will not be available as methods). This can be +considered a feature in some cases (this is how L<namespace::clean> works, for +instance), but should not be relied upon - use C<remove_glob> directly if you +want this behavior. + +=item * Some minor memory leaks + +The pure perl implementation has a couple minor memory leaks (see the TODO +tests in t/20-leaks.t) that I'm having a hard time tracking down - these may be +core perl bugs, it's hard to tell. + +=back + +Please report any bugs through RT: email +C<bug-package-stash at rt.cpan.org>, or browse to +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>. + +=head1 SEE ALSO + +=over 4 + +=item * L<Class::MOP::Package> + +This module is a factoring out of code that used to live here + +=back + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Package::Stash + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/Package-Stash> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/d/Package-Stash> + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash> + +=item * Search CPAN + +L<http://search.cpan.org/dist/Package-Stash> + +=back + +=head1 AUTHOR + +Jesse Luehrs <doy at tozt dot net> + +Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the +Moose Cabal. + +=for Pod::Coverage BROKEN_ISA_ASSIGNMENT +add_symbol +get_all_symbols +get_or_add_symbol +get_symbol +has_symbol +list_all_symbols +name +namespace +new +remove_glob + +=head1 AUTHOR + +Jesse Luehrs <doy@tozt.net> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 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/t/00-compile.t b/t/00-compile.t new file mode 100644 index 0000000..e322cc2 --- /dev/null +++ b/t/00-compile.t @@ -0,0 +1,79 @@ +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.043 + +use Test::More tests => 4 + ($ENV{AUTHOR_TESTING} ? 1 : 0); + + + +my @module_files = ( + 'Package/Stash.pm', + 'Package/Stash/Conflicts.pm', + 'Package/Stash/PP.pm' +); + +my @scripts = ( + 'bin/package-stash-conflicts' +); + +# no fake home requested + +my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L<perlfaq8/How can I capture STDERR from an external command?> + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + +foreach my $file (@scripts) +{ SKIP: { + open my $fh, '<', $file or warn("Unable to open $file: $!"), next; + my $line = <$fh>; + + close $fh and skip("$file isn't perl", 1) unless $line =~ /^#!\s*(?:\S*perl\S*)((?:\s+-\w*)*)(?:\s*#.*)?$/; + my @flags = $1 ? split(' ', $1) : (); + + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, @flags, '-c', $file); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$file compiled ok"); + + # in older perls, -c output is simply the file portion of the path being tested + if (@_warnings = grep { !/\bsyntax OK$/ } + grep { chomp; $_ ne (File::Spec->splitpath($file))[2] } @_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} } + + + +is(scalar(@warnings), 0, 'no warnings found') if $ENV{AUTHOR_TESTING}; + + 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..5f7fb93 --- /dev/null +++ b/t/anon-basic.t @@ -0,0 +1,406 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +use Package::Stash; + +BEGIN { + plan skip_all => "Anonymous stashes in PP need at least perl 5.14" + if $] < 5.014 + && $Package::Stash::IMPLEMENTATION eq 'PP'; +} + +use Test::Requires 'Package::Anon'; +use Symbol; + +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..94d2f65 --- /dev/null +++ b/t/anon.t @@ -0,0 +1,51 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use lib 't/lib'; + +use Package::Stash; + +BEGIN { + plan skip_all => "Anonymous stashes in PP need at least perl 5.14" + if $] < 5.014 + && $Package::Stash::IMPLEMENTATION eq 'PP'; +} + +use Test::Requires 'Package::Anon'; +use Symbol; + +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..c3cc981 --- /dev/null +++ b/t/bare-anon-basic.t @@ -0,0 +1,400 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +use Package::Stash; + +BEGIN { + 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"; +} + +use Symbol; + +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..f42dce8 --- /dev/null +++ b/t/bare-anon.t @@ -0,0 +1,65 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use lib 't/lib'; + +use Package::Stash; + +BEGIN { + 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"; +} + +use Symbol; + +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; @@ -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/impl-selection/basic-pp.t b/t/impl-selection/basic-pp.t new file mode 100644 index 0000000..58ff523 --- /dev/null +++ b/t/impl-selection/basic-pp.t @@ -0,0 +1,452 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +BEGIN { $Package::Stash::IMPLEMENTATION = 'PP' } + +use Package::Stash; + +ok(exists $INC{'Package/Stash/PP.pm'}, "loaded PP"); +ok(!exists $INC{'Package/Stash/XS.pm'}, "didn't load XS"); + +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/impl-selection/basic-xs.t b/t/impl-selection/basic-xs.t new file mode 100644 index 0000000..8612906 --- /dev/null +++ b/t/impl-selection/basic-xs.t @@ -0,0 +1,453 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Requires 'Package::Stash::XS'; + +BEGIN { $Package::Stash::IMPLEMENTATION = 'XS' } + +use Package::Stash; + +ok(exists $INC{'Package/Stash/XS.pm'}, "loaded XS"); +ok(!exists $INC{'Package/Stash/PP.pm'}, "didn't load PP"); + +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/impl-selection/bug-rt-78272.t b/t/impl-selection/bug-rt-78272.t new file mode 100644 index 0000000..dc74922 --- /dev/null +++ b/t/impl-selection/bug-rt-78272.t @@ -0,0 +1,39 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +# https://rt.cpan.org/Public/Bug/Display.html?id=78272 +my $e = $ENV{PACKAGE_STASH_IMPLEMENTATION} = "PP; exit 1"; + +like( + exception { require Package::Stash }, + qr/$e is not a valid implementation for Package::Stash/, + 'Arbitrary code in $ENV throws exception' +); + +like( + exception { + delete $INC{'Package/Stash.pm'}; + require Package::Stash; + }, + qr/$e is not a valid implementation for Package::Stash/, + 'Sanity check: forcing package reload throws the exception again' +); + +is( + exception { + $ENV{PACKAGE_STASH_IMPLEMENTATION} = "PP"; + delete $INC{'Package/Stash.pm'}; + require Package::Stash; + new_ok( + 'Package::Stash' => ['Foo'], + 'Loaded and able to create instances' + ); + }, + undef, + 'Valid $ENV value loads correctly' +); + +done_testing; diff --git a/t/impl-selection/choice.t b/t/impl-selection/choice.t new file mode 100644 index 0000000..7bbe29c --- /dev/null +++ b/t/impl-selection/choice.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +my $has_xs = eval "require Package::Stash::XS; 1"; + +require Package::Stash; + +no warnings 'once'; + +my $expected = $has_xs ? 'XS' : 'PP'; +is($Package::Stash::IMPLEMENTATION, $expected, + "autodetected properly: $expected"); +can_ok('Package::Stash', 'new'); + +done_testing; diff --git a/t/impl-selection/env.t b/t/impl-selection/env.t new file mode 100644 index 0000000..c050267 --- /dev/null +++ b/t/impl-selection/env.t @@ -0,0 +1,39 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +# XXX: work around dumb core segfault bug when you delete stashes +sub get_impl { eval '$Package::Stash::IMPLEMENTATION' } +sub set_impl { eval '$Package::Stash::IMPLEMENTATION = "' . $_[0] . '"' } + +{ + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'PP'; + require Package::Stash; + is(get_impl, 'PP', "autodetected properly: PP"); + can_ok('Package::Stash', 'new'); +} + +delete $Package::{'Stash::'}; +delete $INC{'Package/Stash.pm'}; +delete $INC{'Package/Stash/PP.pm'}; + +SKIP: { + skip "no XS", 2 unless eval "require Package::Stash::XS; 1"; + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'XS'; + require Package::Stash; + is(get_impl, 'XS', "autodetected properly: XS"); + can_ok('Package::Stash', 'new'); +} + +{ + delete $Package::{'Stash::'}; + delete $INC{'Package/Stash.pm'}; + set_impl('INVALID'); + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'PP'; + require Package::Stash; + is(get_impl, 'PP', '$ENV takes precedence over $Package::Stash::IMPLEMENTATION'); + can_ok('Package::Stash', 'new'); +} + +done_testing; diff --git a/t/impl-selection/var.t b/t/impl-selection/var.t new file mode 100644 index 0000000..dd5e7d8 --- /dev/null +++ b/t/impl-selection/var.t @@ -0,0 +1,29 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +# XXX: work around dumb core segfault bug when you delete stashes +sub get_impl { eval '$Package::Stash::IMPLEMENTATION' } +sub set_impl { eval '$Package::Stash::IMPLEMENTATION = "' . $_[0] . '"' } + +{ + $Package::Stash::IMPLEMENTATION = 'PP'; + require Package::Stash; + is(get_impl, 'PP', "autodetected properly: PP"); + can_ok('Package::Stash', 'new'); +} + +delete $Package::{'Stash::'}; +delete $INC{'Package/Stash.pm'}; +delete $INC{'Package/Stash/PP.pm'}; + +SKIP: { + skip "no XS", 2 unless eval "require Package::Stash::XS; 1"; + $Package::Stash::IMPLEMENTATION = 'XS'; + require Package::Stash; + is(get_impl, 'XS', "autodetected properly: XS"); + can_ok('Package::Stash', 'new'); +} + +done_testing; @@ -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; @@ -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..8f97587 --- /dev/null +++ b/t/lib/Package/Stash.pm @@ -0,0 +1,3 @@ +$Package::Stash::IMPLEMENTATION = 'PP'; +do './lib/Package/Stash.pm' or die $@ || $!; +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-taint.t b/t/warnings-taint.t new file mode 100644 index 0000000..68dee3c --- /dev/null +++ b/t/warnings-taint.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl -T +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/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/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..3b21fc9 --- /dev/null +++ b/xt/release/no-tabs.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.08 + +use Test::More 0.88; +use Test::NoTabs; + +my @files = ( + 'bin/package-stash-conflicts', + 'lib/Package/Stash.pm', + 'lib/Package/Stash/Conflicts.pm', + 'lib/Package/Stash/PP.pm', + '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/impl-selection/basic-pp.t', + 't/impl-selection/basic-xs.t', + 't/impl-selection/bug-rt-78272.t', + 't/impl-selection/choice.t', + 't/impl-selection/env.t', + 't/impl-selection/var.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-taint.t', + 't/warnings.t' +); + +notabs_ok($_) foreach @files; +done_testing; diff --git a/xt/release/pod-coverage.t b/xt/release/pod-coverage.t new file mode 100644 index 0000000..66b3b64 --- /dev/null +++ b/xt/release/pod-coverage.t @@ -0,0 +1,7 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. + +use Test::Pod::Coverage 1.08; +use Pod::Coverage::TrustPod; + +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..f0468f1 --- /dev/null +++ b/xt/release/pod-syntax.t @@ -0,0 +1,6 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. +use Test::More; +use Test::Pod 1.41; + +all_pod_files_ok(); |