diff options
| author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2013-10-18 15:10:07 +0000 |
|---|---|---|
| committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2013-10-18 15:10:07 +0000 |
| commit | 641cf398662e09a9660e5b4187f8691a3205a3db (patch) | |
| tree | 96b89e8da457bddc0fbe2fcbc72d51466bc16169 | |
| download | Sub-Exporter-tarball-master.tar.gz | |
Sub-Exporter-0.987HEADSub-Exporter-0.987master
40 files changed, 5707 insertions, 0 deletions
@@ -0,0 +1,138 @@ +Revision history for Sub-Exporter + +0.987 2013-10-18 11:10:03 America/New_York + update bugtracker metadata + +0.986 2013-06-14 18:45:45 America/New_York + typo fixes in docs (thanks, David Steinbrunner!) + +0.985 2013-02-20 19:02:30 America/New_York + documentation fixes (thanks, George Hartzell) + +0.984 2012-06-05 07:59:40 America/New_York + documentation fixes (thanks, GitHub user "everybody") + +0.983 2011-01-24 + documentation fixes (thanks, Karen Etheridge and Luc St-Louis!) + +0.982 2009-01-16 + add metadata for repo + +0.981 2008-10-24 + finally fix very occasional hash ordering issue in tests + fix typo in SYNOPSIS (thanks, Florian!) + +0.980 2008-09-14 + fix inadvertant futzing with group generator args + https://rt.cpan.org/Ticket/Display.html?id=38885 + thanks, trendele! + +0.979 2008-04-29 + add INIT collector + declare reservation of all CAPS collectors + clarify documentation of -setup after report by GAISSMAI + +0.978 2007-11-19 + improve documentation of new installer/generator options + deprecate calling "installer" the "exporter" + WARNING: "exporter" OPTION WILL BE REMOVED AFTER 2008-06-01 + major refactoring of the core generation/installation code + tentative interface documentation for replacing it! + +0.976 2007-08-30 + fixed merge_col, which was not updated to work with \name generators + collector hooks can now alter @_ to replace the value to be collected + clarify args passed to generator in Tutorial; thanks MARKSTOS + + added commented-out name_map to Sub::Exporter::Util; future feature? + +0.975 2007-07-04 + update Tutorial to show (preferred) \'name' style for generators + changed "standard" name of curry_class to curry_method + added curry_chain + added Sub::Exporter::Cookbook + +0.974 2007-04-22 + fix a bug: would try to export routines that didn't exist + in the exporting package; this caused Sub::Install to give the + unhelpful message "argument 'code' is not optional" + +0.973 2007-02-02 + document changes made in 0.972 + minor code changes for readability + +0.972 2006-12-05 + allow exporter config to provide name (via string ref) of generator + for groups and exports + similarly allow a string ref for a method name for a collector hook + remove some pointless conditions + +0.971 2006-11-06 + minor documentation clarification + add Perl::Critic tests (disabled by default) + +0.970 2006-06-27 + defaults populate before collectors collect, now + default group's value is undef by default, not 1 + mixin_exporter can now export into objects, creating virtual classes + +0.966 2006-06-17 + correct documentation of collector hook args + simplify internal use of setup_exporter + clean up documentation in ::Util + +0.965 2006-06-05 + curry_class now allows the export to curry a differently-named method + +0.961 2006-06-05 + Data::OptList is now in its own dist; updated to use it + +0.960 2006-05-31 + added into and into_config to config + 100% test coverage... almost! + fix bug that prevented validation of opt lists with must_be=class + +0.954 2006-05-11 + tweaks to Data::OptList, moving toward its own dist: now it exports + expand_opt_list is now opt_list_as_hash + +0.953 2006-05-10 + require Params::Util for craftier opt list validation + use reinstall, rather than install, to avoid warnings on redef + +0.952 2006-04-30 + add missing file to manifest + +0.951 2006-04-30 + fix util-mixin.t to skip if prereqs are missing + various changes to improve blessed/weird generators + (thanks to Yuval Kogman for pointing problems out) + +0.95 2006-04-26 + break out Data::OptList for future disting + remove an "optimization" that broke expand_opt_list + improve detection of group generators + improve data passed to hooks (if you relied on the guts, you'll break) + the ::Util module + +0.93 2006-03-26 + internal refactoring + add more arguments to collector hook calls + +0.92 2006-03-16 + FIX BUG in nested imports: when importing groups A and B, and group B + includes group A, the nested group would be ignored, even though it + was not recursing + + allow 'into_level' parameter to setup_exporter + rewrite collection collector to be more efficient + rewrite opt list handlers to be more efficient + restate some code to improve clarity and coverage (now 100%) + better diagnostic messages + +0.91 2006-03-16 + added "import elsewhere" option to generated exporter (thanks + chansen!) + +0.90 2006-03-11 + first public release @@ -0,0 +1,379 @@ +This software is copyright (c) 2007 by Ricardo Signes. + +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) 2007 by Ricardo Signes. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2007 by Ricardo Signes. + +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..df748bc --- /dev/null +++ b/MANIFEST @@ -0,0 +1,40 @@ +Changes +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README +dist.ini +lib/Sub/Exporter.pm +lib/Sub/Exporter/Cookbook.pod +lib/Sub/Exporter/Tutorial.pod +lib/Sub/Exporter/Util.pm +t/00-compile.t +t/000-report-versions-tiny.t +t/col-init.t +t/collection.t +t/expand-group.t +t/faux-export.t +t/gen-callable.t +t/group-generator.t +t/inherited.t +t/into-level.t +t/lib/Test/SubExporter/DashSetup.pm +t/lib/Test/SubExporter/Faux.pm +t/lib/Test/SubExporter/GroupGen.pm +t/lib/Test/SubExporter/GroupGenSubclass.pm +t/lib/Test/SubExporter/ObjGen.pm +t/lib/Test/SubExporter/s_e.pm +t/real-export-groupgen.t +t/real-export-href.t +t/real-export-setup.t +t/util-curry.t +t/util-currychain.t +t/util-like.t +t/util-merge.t +t/util-mixin.t +t/util-namemap.t +t/valid-config.t +xt/release/changes_has_content.t +xt/release/pod-syntax.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..367041f --- /dev/null +++ b/META.json @@ -0,0 +1,320 @@ +{ + "abstract" : "a sophisticated exporter for custom-built routines", + "author" : [ + "Ricardo Signes <rjbs@cpan.org>" + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 4.300039, CPAN::Meta::Converter version 2.132830", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Sub-Exporter", + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "6.30" + } + }, + "develop" : { + "requires" : { + "Test::Pod" : "1.41", + "version" : "0.9901" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Data::OptList" : "0.100", + "Params::Util" : "0.14", + "Sub::Install" : "0.92", + "perl" : "5.006", + "strict" : "0", + "warnings" : "0" + } + }, + "test" : { + "requires" : { + "Exporter" : "0", + "File::Spec" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Test::More" : "0.96", + "base" : "0", + "lib" : "0", + "overload" : "0", + "subs" : "0" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/rjbs/Sub-Exporter/issues" + }, + "homepage" : "https://github.com/rjbs/Sub-Exporter", + "repository" : { + "type" : "git", + "url" : "https://github.com/rjbs/Sub-Exporter.git", + "web" : "https://github.com/rjbs/Sub-Exporter" + } + }, + "version" : "0.987", + "x_Dist_Zilla" : { + "perl" : { + "version" : "5.019004" + }, + "plugins" : [ + { + "class" : "Dist::Zilla::Plugin::Git::GatherDir", + "name" : "@RJBS/Git::GatherDir", + "version" : "2.014" + }, + { + "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed", + "name" : "@RJBS/CheckPrereqsIndexed", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::CheckExtraTests", + "name" : "@RJBS/CheckExtraTests", + "version" : "0.013" + }, + { + "class" : "Dist::Zilla::Plugin::PromptIfStale", + "name" : "@RJBS/RJBS-Outdated", + "version" : "0.008" + }, + { + "class" : "Dist::Zilla::Plugin::PromptIfStale", + "name" : "@RJBS/CPAN-Outdated", + "version" : "0.008" + }, + { + "class" : "Dist::Zilla::Plugin::PruneCruft", + "name" : "@RJBS/@Filter/PruneCruft", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::ManifestSkip", + "name" : "@RJBS/@Filter/ManifestSkip", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::MetaYAML", + "name" : "@RJBS/@Filter/MetaYAML", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::License", + "name" : "@RJBS/@Filter/License", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::Readme", + "name" : "@RJBS/@Filter/Readme", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::ExecDir", + "name" : "@RJBS/@Filter/ExecDir", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::ShareDir", + "name" : "@RJBS/@Filter/ShareDir", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::MakeMaker", + "name" : "@RJBS/@Filter/MakeMaker", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::Manifest", + "name" : "@RJBS/@Filter/Manifest", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::TestRelease", + "name" : "@RJBS/@Filter/TestRelease", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::ConfirmRelease", + "name" : "@RJBS/@Filter/ConfirmRelease", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::UploadToCPAN", + "name" : "@RJBS/@Filter/UploadToCPAN", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::AutoPrereqs", + "name" : "@RJBS/AutoPrereqs", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::Git::NextVersion", + "name" : "@RJBS/Git::NextVersion", + "version" : "2.014" + }, + { + "class" : "Dist::Zilla::Plugin::PkgVersion", + "name" : "@RJBS/PkgVersion", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::MetaConfig", + "name" : "@RJBS/MetaConfig", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::MetaJSON", + "name" : "@RJBS/MetaJSON", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::NextRelease", + "name" : "@RJBS/NextRelease", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent", + "name" : "@RJBS/Test::ChangesHasContent", + "version" : "0.006" + }, + { + "class" : "Dist::Zilla::Plugin::PodSyntaxTests", + "name" : "@RJBS/PodSyntaxTests", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::ReportVersions::Tiny", + "name" : "@RJBS/ReportVersions::Tiny", + "version" : "1.10" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Compile", + "config" : { + "Dist::Zilla::Plugin::Test::Compile" : { + "filename" : "t/00-compile.t", + "module_finder" : [ + ":InstallModules" + ], + "script_finder" : [ + ":ExecFiles" + ] + } + }, + "name" : "@RJBS/Test::Compile", + "version" : "2.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "test", + "type" : "requires" + } + }, + "name" : "@RJBS/TestMoreWithSubtests", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::PodWeaver", + "config" : { + "Dist::Zilla::Plugin::PodWeaver" : { + "config_plugin" : "@RJBS", + "finder" : [ + ":InstallModules", + ":ExecFiles" + ] + } + }, + "name" : "@RJBS/PodWeaver", + "version" : "3.102000" + }, + { + "class" : "Dist::Zilla::Plugin::GithubMeta", + "name" : "@RJBS/GithubMeta", + "version" : "0.42" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Check", + "name" : "@RJBS/@Git/Check", + "version" : "2.014" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "name" : "@RJBS/@Git/Commit", + "version" : "2.014" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Tag", + "name" : "@RJBS/@Git/Tag", + "version" : "2.014" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Push", + "name" : "@RJBS/@Git/Push", + "version" : "2.014" + }, + { + "class" : "Dist::Zilla::Plugin::RemovePrereqs", + "config" : { + "Dist::Zilla::Plugin::RemovePrereqs" : { + "modules_to_remove" : [ + "E::Parent", + "Package::Generator" + ] + } + }, + "name" : "RemovePrereqs", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":InstallModules", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":IncModules", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":TestFiles", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ExecFiles", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ShareFiles", + "version" : "4.300039" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":MainModule", + "version" : "4.300039" + } + ], + "zilla" : { + "class" : "Dist::Zilla::Dist::Builder", + "config" : { + "is_trial" : "0" + }, + "version" : "4.300039" + } + } +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..890764d --- /dev/null +++ b/META.yml @@ -0,0 +1,231 @@ +--- +abstract: 'a sophisticated exporter for custom-built routines' +author: + - 'Ricardo Signes <rjbs@cpan.org>' +build_requires: + Exporter: 0 + File::Spec: 0 + IO::Handle: 0 + IPC::Open3: 0 + Test::More: 0.96 + base: 0 + lib: 0 + overload: 0 + subs: 0 +configure_requires: + ExtUtils::MakeMaker: 6.30 +dynamic_config: 0 +generated_by: 'Dist::Zilla version 4.300039, CPAN::Meta::Converter version 2.132830' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Sub-Exporter +requires: + Carp: 0 + Data::OptList: 0.100 + Params::Util: 0.14 + Sub::Install: 0.92 + perl: 5.006 + strict: 0 + warnings: 0 +resources: + bugtracker: https://github.com/rjbs/Sub-Exporter/issues + homepage: https://github.com/rjbs/Sub-Exporter + repository: https://github.com/rjbs/Sub-Exporter.git +version: 0.987 +x_Dist_Zilla: + perl: + version: 5.019004 + plugins: + - + class: Dist::Zilla::Plugin::Git::GatherDir + name: '@RJBS/Git::GatherDir' + version: 2.014 + - + class: Dist::Zilla::Plugin::CheckPrereqsIndexed + name: '@RJBS/CheckPrereqsIndexed' + version: 0.009 + - + class: Dist::Zilla::Plugin::CheckExtraTests + name: '@RJBS/CheckExtraTests' + version: 0.013 + - + class: Dist::Zilla::Plugin::PromptIfStale + name: '@RJBS/RJBS-Outdated' + version: 0.008 + - + class: Dist::Zilla::Plugin::PromptIfStale + name: '@RJBS/CPAN-Outdated' + version: 0.008 + - + class: Dist::Zilla::Plugin::PruneCruft + name: '@RJBS/@Filter/PruneCruft' + version: 4.300039 + - + class: Dist::Zilla::Plugin::ManifestSkip + name: '@RJBS/@Filter/ManifestSkip' + version: 4.300039 + - + class: Dist::Zilla::Plugin::MetaYAML + name: '@RJBS/@Filter/MetaYAML' + version: 4.300039 + - + class: Dist::Zilla::Plugin::License + name: '@RJBS/@Filter/License' + version: 4.300039 + - + class: Dist::Zilla::Plugin::Readme + name: '@RJBS/@Filter/Readme' + version: 4.300039 + - + class: Dist::Zilla::Plugin::ExecDir + name: '@RJBS/@Filter/ExecDir' + version: 4.300039 + - + class: Dist::Zilla::Plugin::ShareDir + name: '@RJBS/@Filter/ShareDir' + version: 4.300039 + - + class: Dist::Zilla::Plugin::MakeMaker + name: '@RJBS/@Filter/MakeMaker' + version: 4.300039 + - + class: Dist::Zilla::Plugin::Manifest + name: '@RJBS/@Filter/Manifest' + version: 4.300039 + - + class: Dist::Zilla::Plugin::TestRelease + name: '@RJBS/@Filter/TestRelease' + version: 4.300039 + - + class: Dist::Zilla::Plugin::ConfirmRelease + name: '@RJBS/@Filter/ConfirmRelease' + version: 4.300039 + - + class: Dist::Zilla::Plugin::UploadToCPAN + name: '@RJBS/@Filter/UploadToCPAN' + version: 4.300039 + - + class: Dist::Zilla::Plugin::AutoPrereqs + name: '@RJBS/AutoPrereqs' + version: 4.300039 + - + class: Dist::Zilla::Plugin::Git::NextVersion + name: '@RJBS/Git::NextVersion' + version: 2.014 + - + class: Dist::Zilla::Plugin::PkgVersion + name: '@RJBS/PkgVersion' + version: 4.300039 + - + class: Dist::Zilla::Plugin::MetaConfig + name: '@RJBS/MetaConfig' + version: 4.300039 + - + class: Dist::Zilla::Plugin::MetaJSON + name: '@RJBS/MetaJSON' + version: 4.300039 + - + class: Dist::Zilla::Plugin::NextRelease + name: '@RJBS/NextRelease' + version: 4.300039 + - + class: Dist::Zilla::Plugin::Test::ChangesHasContent + name: '@RJBS/Test::ChangesHasContent' + version: 0.006 + - + class: Dist::Zilla::Plugin::PodSyntaxTests + name: '@RJBS/PodSyntaxTests' + version: 4.300039 + - + class: Dist::Zilla::Plugin::ReportVersions::Tiny + name: '@RJBS/ReportVersions::Tiny' + version: 1.10 + - + class: Dist::Zilla::Plugin::Test::Compile + config: + Dist::Zilla::Plugin::Test::Compile: + filename: t/00-compile.t + module_finder: + - ':InstallModules' + script_finder: + - ':ExecFiles' + name: '@RJBS/Test::Compile' + version: 2.037 + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: test + type: requires + name: '@RJBS/TestMoreWithSubtests' + version: 4.300039 + - + class: Dist::Zilla::Plugin::PodWeaver + config: + Dist::Zilla::Plugin::PodWeaver: + config_plugin: '@RJBS' + finder: + - ':InstallModules' + - ':ExecFiles' + name: '@RJBS/PodWeaver' + version: 3.102000 + - + class: Dist::Zilla::Plugin::GithubMeta + name: '@RJBS/GithubMeta' + version: 0.42 + - + class: Dist::Zilla::Plugin::Git::Check + name: '@RJBS/@Git/Check' + version: 2.014 + - + class: Dist::Zilla::Plugin::Git::Commit + name: '@RJBS/@Git/Commit' + version: 2.014 + - + class: Dist::Zilla::Plugin::Git::Tag + name: '@RJBS/@Git/Tag' + version: 2.014 + - + class: Dist::Zilla::Plugin::Git::Push + name: '@RJBS/@Git/Push' + version: 2.014 + - + class: Dist::Zilla::Plugin::RemovePrereqs + config: + Dist::Zilla::Plugin::RemovePrereqs: + modules_to_remove: + - E::Parent + - Package::Generator + name: RemovePrereqs + version: 4.300039 + - + class: Dist::Zilla::Plugin::FinderCode + name: ':InstallModules' + version: 4.300039 + - + class: Dist::Zilla::Plugin::FinderCode + name: ':IncModules' + version: 4.300039 + - + class: Dist::Zilla::Plugin::FinderCode + name: ':TestFiles' + version: 4.300039 + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ExecFiles' + version: 4.300039 + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ShareFiles' + version: 4.300039 + - + class: Dist::Zilla::Plugin::FinderCode + name: ':MainModule' + version: 4.300039 + zilla: + class: Dist::Zilla::Dist::Builder + config: + is_trial: 0 + version: 4.300039 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..336aec9 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,80 @@ + +use strict; +use warnings; + +use 5.006; + +use ExtUtils::MakeMaker 6.30; + + + +my %WriteMakefileArgs = ( + "ABSTRACT" => "a sophisticated exporter for custom-built routines", + "AUTHOR" => "Ricardo Signes <rjbs\@cpan.org>", + "BUILD_REQUIRES" => {}, + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => "6.30" + }, + "DISTNAME" => "Sub-Exporter", + "EXE_FILES" => [], + "LICENSE" => "perl", + "NAME" => "Sub::Exporter", + "PREREQ_PM" => { + "Carp" => 0, + "Data::OptList" => "0.100", + "Params::Util" => "0.14", + "Sub::Install" => "0.92", + "strict" => 0, + "warnings" => 0 + }, + "TEST_REQUIRES" => { + "Exporter" => 0, + "File::Spec" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "Test::More" => "0.96", + "base" => 0, + "lib" => 0, + "overload" => 0, + "subs" => 0 + }, + "VERSION" => "0.987", + "test" => { + "TESTS" => "t/*.t" + } +); + + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + my $tr = delete $WriteMakefileArgs{TEST_REQUIRES}; + my $br = $WriteMakefileArgs{BUILD_REQUIRES}; + for my $mod ( keys %$tr ) { + if ( exists $br->{$mod} ) { + $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; + } + else { + $br->{$mod} = $tr->{$mod}; + } + } +} + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { + my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; + my $pp = $WriteMakefileArgs{PREREQ_PM}; + for my $mod ( keys %$br ) { + if ( exists $pp->{$mod} ) { + $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; + } + else { + $pp->{$mod} = $br->{$mod}; + } + } +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +WriteMakefile(%WriteMakefileArgs); + + + @@ -0,0 +1,13 @@ + + +This archive contains the distribution Sub-Exporter, +version 0.987: + + a sophisticated exporter for custom-built routines + +This software is copyright (c) 2007 by Ricardo Signes. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + + diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..52caee0 --- /dev/null +++ b/dist.ini @@ -0,0 +1,11 @@ +name = Sub-Exporter +author = Ricardo Signes <rjbs@cpan.org> +license = Perl_5 +copyright_holder = Ricardo Signes +copyright_year = 2007 + +[@RJBS] + +[RemovePrereqs] +remove = E::Parent +remove = Package::Generator diff --git a/lib/Sub/Exporter.pm b/lib/Sub/Exporter.pm new file mode 100644 index 0000000..25c9b7e --- /dev/null +++ b/lib/Sub/Exporter.pm @@ -0,0 +1,1108 @@ +use 5.006; +use strict; +use warnings; +package Sub::Exporter; +{ + $Sub::Exporter::VERSION = '0.987'; +} +# ABSTRACT: a sophisticated exporter for custom-built routines + +use Carp (); +use Data::OptList 0.100 (); +use Params::Util 0.14 (); # _CODELIKE +use Sub::Install 0.92 (); + + +# Given a potential import name, this returns the group name -- if it's got a +# group prefix. +sub _group_name { + my ($name) = @_; + + return if (index q{-:}, (substr $name, 0, 1)) == -1; + return substr $name, 1; +} + +# \@groups is a canonicalized opt list of exports and groups this returns +# another canonicalized opt list with groups replaced with relevant exports. +# \%seen is groups we've already expanded and can ignore. +# \%merge is merged options from the group we're descending through. +sub _expand_groups { + my ($class, $config, $groups, $collection, $seen, $merge) = @_; + $seen ||= {}; + $merge ||= {}; + my @groups = @$groups; + + for my $i (reverse 0 .. $#groups) { + if (my $group_name = _group_name($groups[$i][0])) { + my $seen = { %$seen }; # faux-dynamic scoping + + splice @groups, $i, 1, + _expand_group($class, $config, $groups[$i], $collection, $seen, $merge); + } else { + # there's nothing to munge in this export's args + next unless my %merge = %$merge; + + # we have things to merge in; do so + my $prefix = (delete $merge{-prefix}) || ''; + my $suffix = (delete $merge{-suffix}) || ''; + + if ( + Params::Util::_CODELIKE($groups[$i][1]) ## no critic Private + or + Params::Util::_SCALAR0($groups[$i][1]) ## no critic Private + ) { + # this entry was build by a group generator + $groups[$i][0] = $prefix . $groups[$i][0] . $suffix; + } else { + my $as + = ref $groups[$i][1]{-as} ? $groups[$i][1]{-as} + : $groups[$i][1]{-as} ? $prefix . $groups[$i][1]{-as} . $suffix + : $prefix . $groups[$i][0] . $suffix; + + $groups[$i][1] = { %{ $groups[$i][1] }, %merge, -as => $as }; + } + } + } + + return \@groups; +} + +# \@group is a name/value pair from an opt list. +sub _expand_group { + my ($class, $config, $group, $collection, $seen, $merge) = @_; + $merge ||= {}; + + my ($group_name, $group_arg) = @$group; + $group_name = _group_name($group_name); + + Carp::croak qq(group "$group_name" is not exported by the $class module) + unless exists $config->{groups}{$group_name}; + + return if $seen->{$group_name}++; + + if (ref $group_arg) { + my $prefix = (delete $merge->{-prefix}||'') . ($group_arg->{-prefix}||''); + my $suffix = ($group_arg->{-suffix}||'') . (delete $merge->{-suffix}||''); + $merge = { + %$merge, + %$group_arg, + ($prefix ? (-prefix => $prefix) : ()), + ($suffix ? (-suffix => $suffix) : ()), + }; + } + + my $exports = $config->{groups}{$group_name}; + + if ( + Params::Util::_CODELIKE($exports) ## no critic Private + or + Params::Util::_SCALAR0($exports) ## no critic Private + ) { + # I'm not very happy with this code for hiding -prefix and -suffix, but + # it's needed, and I'm not sure, offhand, how to make it better. + # -- rjbs, 2006-12-05 + my $group_arg = $merge ? { %$merge } : {}; + delete $group_arg->{-prefix}; + delete $group_arg->{-suffix}; + + my $group = Params::Util::_CODELIKE($exports) ## no critic Private + ? $exports->($class, $group_name, $group_arg, $collection) + : $class->$$exports($group_name, $group_arg, $collection); + + Carp::croak qq(group generator "$group_name" did not return a hashref) + if ref $group ne 'HASH'; + + my $stuff = [ map { [ $_ => $group->{$_} ] } keys %$group ]; + return @{ + _expand_groups($class, $config, $stuff, $collection, $seen, $merge) + }; + } else { + $exports + = Data::OptList::mkopt($exports, "$group_name exports"); + + return @{ + _expand_groups($class, $config, $exports, $collection, $seen, $merge) + }; + } +} + +sub _mk_collection_builder { + my ($col, $etc) = @_; + my ($config, $import_args, $class, $into) = @$etc; + + my %seen; + sub { + my ($collection) = @_; + my ($name, $value) = @$collection; + + Carp::croak "collection $name provided multiple times in import" + if $seen{ $name }++; + + if (ref(my $hook = $config->{collectors}{$name})) { + my $arg = { + name => $name, + config => $config, + import_args => $import_args, + class => $class, + into => $into, + }; + + my $error_msg = "collection $name failed validation"; + if (Params::Util::_SCALAR0($hook)) { ## no critic Private + Carp::croak $error_msg unless $class->$$hook($value, $arg); + } else { + Carp::croak $error_msg unless $hook->($value, $arg); + } + } + + $col->{ $name } = $value; + } +} + +# Given a config and pre-canonicalized importer args, remove collections from +# the args and return them. +sub _collect_collections { + my ($config, $import_args, $class, $into) = @_; + + my @collections + = map { splice @$import_args, $_, 1 } + grep { exists $config->{collectors}{ $import_args->[$_][0] } } + reverse 0 .. $#$import_args; + + unshift @collections, [ INIT => {} ] if $config->{collectors}{INIT}; + + my $col = {}; + my $builder = _mk_collection_builder($col, \@_); + for my $collection (@collections) { + $builder->($collection) + } + + return $col; +} + + +sub setup_exporter { + my ($config) = @_; + + Carp::croak 'into and into_level may not both be supplied to exporter' + if exists $config->{into} and exists $config->{into_level}; + + my $as = delete $config->{as} || 'import'; + my $into + = exists $config->{into} ? delete $config->{into} + : exists $config->{into_level} ? caller(delete $config->{into_level}) + : caller(0); + + my $import = build_exporter($config); + + Sub::Install::reinstall_sub({ + code => $import, + into => $into, + as => $as, + }); +} + + +sub _key_intersection { + my ($x, $y) = @_; + my %seen = map { $_ => 1 } keys %$x; + my @names = grep { $seen{$_} } keys %$y; +} + +# Given the config passed to setup_exporter, which contains sugary opt list +# data, rewrite the opt lists into hashes, catch a few kinds of invalid +# configurations, and set up defaults. Since the config is a reference, it's +# rewritten in place. +my %valid_config_key; +BEGIN { + %valid_config_key = + map { $_ => 1 } + qw(as collectors installer generator exports groups into into_level), + qw(exporter), # deprecated +} + +sub _assert_collector_names_ok { + my ($collectors) = @_; + + for my $reserved_name (grep { /\A[_A-Z]+\z/ } keys %$collectors) { + Carp::croak "unknown reserved collector name: $reserved_name" + if $reserved_name ne 'INIT'; + } +} + +sub _rewrite_build_config { + my ($config) = @_; + + if (my @keys = grep { not exists $valid_config_key{$_} } keys %$config) { + Carp::croak "unknown options (@keys) passed to Sub::Exporter"; + } + + Carp::croak q(into and into_level may not both be supplied to exporter) + if exists $config->{into} and exists $config->{into_level}; + + # XXX: Remove after deprecation period. + if ($config->{exporter}) { + Carp::cluck "'exporter' argument to build_exporter is deprecated. Use 'installer' instead; the semantics are identical."; + $config->{installer} = delete $config->{exporter}; + } + + Carp::croak q(into and into_level may not both be supplied to exporter) + if exists $config->{into} and exists $config->{into_level}; + + for (qw(exports collectors)) { + $config->{$_} = Data::OptList::mkopt_hash( + $config->{$_}, + $_, + [ 'CODE', 'SCALAR' ], + ); + } + + _assert_collector_names_ok($config->{collectors}); + + if (my @names = _key_intersection(@$config{qw(exports collectors)})) { + Carp::croak "names (@names) used in both collections and exports"; + } + + $config->{groups} = Data::OptList::mkopt_hash( + $config->{groups}, + 'groups', + [ + 'HASH', # standard opt list + 'ARRAY', # standard opt list + 'CODE', # group generator + 'SCALAR', # name of group generation method + ] + ); + + # by default, export nothing + $config->{groups}{default} ||= []; + + # by default, build an all-inclusive 'all' group + $config->{groups}{all} ||= [ keys %{ $config->{exports} } ]; + + $config->{generator} ||= \&default_generator; + $config->{installer} ||= \&default_installer; +} + +sub build_exporter { + my ($config) = @_; + + _rewrite_build_config($config); + + my $import = sub { + my ($class) = shift; + + # XXX: clean this up -- rjbs, 2006-03-16 + my $special = (ref $_[0]) ? shift(@_) : {}; + Carp::croak q(into and into_level may not both be supplied to exporter) + if exists $special->{into} and exists $special->{into_level}; + + if ($special->{exporter}) { + Carp::cluck "'exporter' special import argument is deprecated. Use 'installer' instead; the semantics are identical."; + $special->{installer} = delete $special->{exporter}; + } + + my $into + = defined $special->{into} ? delete $special->{into} + : defined $special->{into_level} ? caller(delete $special->{into_level}) + : defined $config->{into} ? $config->{into} + : defined $config->{into_level} ? caller($config->{into_level}) + : caller(0); + + my $generator = delete $special->{generator} || $config->{generator}; + my $installer = delete $special->{installer} || $config->{installer}; + + # this builds a AOA, where the inner arrays are [ name => value_ref ] + my $import_args = Data::OptList::mkopt([ @_ ]); + + # is this right? defaults first or collectors first? -- rjbs, 2006-06-24 + $import_args = [ [ -default => undef ] ] unless @$import_args; + + my $collection = _collect_collections($config, $import_args, $class, $into); + + my $to_import = _expand_groups($class, $config, $import_args, $collection); + + # now, finally $import_arg is really the "to do" list + _do_import( + { + class => $class, + col => $collection, + config => $config, + into => $into, + generator => $generator, + installer => $installer, + }, + $to_import, + ); + }; + + return $import; +} + +sub _do_import { + my ($arg, $to_import) = @_; + + my @todo; + + for my $pair (@$to_import) { + my ($name, $import_arg) = @$pair; + + my ($generator, $as); + + if ($import_arg and Params::Util::_CODELIKE($import_arg)) { ## no critic + # This is the case when a group generator has inserted name/code pairs. + $generator = sub { $import_arg }; + $as = $name; + } else { + $import_arg = { $import_arg ? %$import_arg : () }; + + Carp::croak qq("$name" is not exported by the $arg->{class} module) + unless exists $arg->{config}{exports}{$name}; + + $generator = $arg->{config}{exports}{$name}; + + $as = exists $import_arg->{-as} ? (delete $import_arg->{-as}) : $name; + } + + my $code = $arg->{generator}->( + { + class => $arg->{class}, + name => $name, + arg => $import_arg, + col => $arg->{col}, + generator => $generator, + } + ); + + push @todo, $as, $code; + } + + $arg->{installer}->( + { + class => $arg->{class}, + into => $arg->{into}, + col => $arg->{col}, + }, + \@todo, + ); +} + +## Cute idea, possibly for future use: also supply an "unimport" for: +## no Module::Whatever qw(arg arg arg); +# sub _unexport { +# my (undef, undef, undef, undef, undef, $as, $into) = @_; +# +# if (ref $as eq 'SCALAR') { +# undef $$as; +# } elsif (ref $as) { +# Carp::croak "invalid reference type for $as: " . ref $as; +# } else { +# no strict 'refs'; +# delete &{$into . '::' . $as}; +# } +# } + + +sub default_generator { + my ($arg) = @_; + my ($class, $name, $generator) = @$arg{qw(class name generator)}; + + if (not defined $generator) { + my $code = $class->can($name) + or Carp::croak "can't locate exported subroutine $name via $class"; + return $code; + } + + # I considered making this "$class->$generator(" but it seems that + # overloading precedence would turn an overloaded-as-code generator object + # into a string before code. -- rjbs, 2006-06-11 + return $generator->($class, $name, $arg->{arg}, $arg->{col}) + if Params::Util::_CODELIKE($generator); ## no critic Private + + # This "must" be a scalar reference, to a generator method name. + # -- rjbs, 2006-12-05 + return $class->$$generator($name, $arg->{arg}, $arg->{col}); +} + + +sub default_installer { + my ($arg, $to_export) = @_; + + for (my $i = 0; $i < @$to_export; $i += 2) { + my ($as, $code) = @$to_export[ $i, $i+1 ]; + + # Allow as isa ARRAY to push onto an array? + # Allow into isa HASH to install name=>code into hash? + + if (ref $as eq 'SCALAR') { + $$as = $code; + } elsif (ref $as) { + Carp::croak "invalid reference type for $as: " . ref $as; + } else { + Sub::Install::reinstall_sub({ + code => $code, + into => $arg->{into}, + as => $as + }); + } + } +} + +sub default_exporter { + Carp::cluck "default_exporter is deprecated; call default_installer instead; the semantics are identical"; + goto &default_installer; +} + + +setup_exporter({ + exports => [ + qw(setup_exporter build_exporter), + _import => sub { build_exporter($_[2]) }, + ], + groups => { + all => [ qw(setup_exporter build_export) ], + }, + collectors => { -setup => \&_setup }, +}); + +sub _setup { + my ($value, $arg) = @_; + + if (ref $value eq 'HASH') { + push @{ $arg->{import_args} }, [ _import => { -as => 'import', %$value } ]; + return 1; + } elsif (ref $value eq 'ARRAY') { + push @{ $arg->{import_args} }, + [ _import => { -as => 'import', exports => $value } ]; + return 1; + } + return; +} + + + +"jn8:32"; # <-- magic true value + +__END__ + +=pod + +=head1 NAME + +Sub::Exporter - a sophisticated exporter for custom-built routines + +=head1 VERSION + +version 0.987 + +=head1 SYNOPSIS + +Sub::Exporter must be used in two places. First, in an exporting module: + + # in the exporting module: + package Text::Tweaker; + use Sub::Exporter -setup => { + exports => [ + qw(squish titlecase), # always works the same way + reformat => \&build_reformatter, # generator to build exported function + trim => \&build_trimmer, + indent => \&build_indenter, + ], + collectors => [ 'defaults' ], + }; + +Then, in an importing module: + + # in the importing module: + use Text::Tweaker + 'squish', + indent => { margin => 5 }, + reformat => { width => 79, justify => 'full', -as => 'prettify_text' }, + defaults => { eol => 'CRLF' }; + +With this setup, the importing module ends up with three routines: C<squish>, +C<indent>, and C<prettify_text>. The latter two have been built to the +specifications of the importer -- they are not just copies of the code in the +exporting package. + +=head1 DESCRIPTION + +B<ACHTUNG!> If you're not familiar with Exporter or exporting, read +L<Sub::Exporter::Tutorial> first! + +=head2 Why Generators? + +The biggest benefit of Sub::Exporter over existing exporters (including the +ubiquitous Exporter.pm) is its ability to build new coderefs for export, rather +than to simply export code identical to that found in the exporting package. + +If your module's consumers get a routine that works like this: + + use Data::Analyze qw(analyze); + my $value = analyze($data, $tolerance, $passes); + +and they constantly pass only one or two different set of values for the +non-C<$data> arguments, your code can benefit from Sub::Exporter. By writing a +simple generator, you can let them do this, instead: + + use Data::Analyze + analyze => { tolerance => 0.10, passes => 10, -as => analyze10 }, + analyze => { tolerance => 0.15, passes => 50, -as => analyze50 }; + + my $value = analyze10($data); + +The package with the generator for that would look something like this: + + package Data::Analyze; + use Sub::Exporter -setup => { + exports => [ + analyze => \&build_analyzer, + ], + }; + + sub build_analyzer { + my ($class, $name, $arg) = @_; + + return sub { + my $data = shift; + my $tolerance = shift || $arg->{tolerance}; + my $passes = shift || $arg->{passes}; + + analyze($data, $tolerance, $passes); + } + } + +Your module's user now has to do less work to benefit from it -- and remember, +you're often your own user! Investing in customized subroutines is an +investment in future laziness. + +This also avoids a common form of ugliness seen in many modules: package-level +configuration. That is, you might have seen something like the above +implemented like so: + + use Data::Analyze qw(analyze); + $Data::Analyze::default_tolerance = 0.10; + $Data::Analyze::default_passes = 10; + +This might save time, until you have multiple modules using Data::Analyze. +Because there is only one global configuration, they step on each other's toes +and your code begins to have mysterious errors. + +Generators can also allow you to export class methods to be called as +subroutines: + + package Data::Methodical; + use Sub::Exporter -setup => { exports => { some_method => \&_curry_class } }; + + sub _curry_class { + my ($class, $name) = @_; + sub { $class->$name(@_); }; + } + +Because of the way that exporters and Sub::Exporter work, any package that +inherits from Data::Methodical can inherit its exporter and override its +C<some_method>. If a user imports C<some_method> from that package, he'll +receive a subroutine that calls the method on the subclass, rather than on +Data::Methodical itself. + +=head2 Other Customizations + +Building custom routines with generators isn't the only way that Sub::Exporters +allows the importing code to refine its use of the exported routines. They may +also be renamed to avoid naming collisions. + +Consider the following code: + + # this program determines to which circle of Hell you will be condemned + use Morality qw(sin virtue); # for calculating viciousness + use Math::Trig qw(:all); # for dealing with circles + +The programmer has inadvertently imported two C<sin> routines. The solution, +in Exporter.pm-based modules, would be to import only one and then call the +other by its fully-qualified name. Alternately, the importer could write a +routine that did so, or could mess about with typeglobs. + +How much easier to write: + + # this program determines to which circle of Hell you will be condemned + use Morality qw(virtue), sin => { -as => 'offense' }; + use Math::Trig -all => { -prefix => 'trig_' }; + +and to have at one's disposal C<offense> and C<trig_sin> -- not to mention +C<trig_cos> and C<trig_tan>. + +=head1 EXPORTER CONFIGURATION + +You can configure an exporter for your package by using Sub::Exporter like so: + + package Tools; + use Sub::Exporter + -setup => { exports => [ qw(function1 function2 function3) ] }; + +This is the simplest way to use the exporter, and is basically equivalent to +this: + + package Tools; + use base qw(Exporter); + our @EXPORT_OK = qw(function1 function2 function3); + +Any basic use of Sub::Exporter will look like this: + + package Tools; + use Sub::Exporter -setup => \%config; + +The following keys are valid in C<%config>: + + exports - a list of routines to provide for exporting; each routine may be + followed by generator + groups - a list of groups to provide for exporting; each must be followed by + either (a) a list of exports, possibly with arguments for each + export, or (b) a generator + + collectors - a list of names into which values are collected for use in + routine generation; each name may be followed by a validator + +In addition to the basic options above, a few more advanced options may be +passed: + + into_level - how far up the caller stack to look for a target (default 0) + into - an explicit target (package) into which to export routines + +In other words: Sub::Exporter installs a C<import> routine which, when called, +exports routines to the calling namespace. The C<into> and C<into_level> +options change where those exported routines are installed. + + generator - a callback used to produce the code that will be installed + default: Sub::Exporter::default_generator + + installer - a callback used to install the code produced by the generator + default: Sub::Exporter::default_installer + +For information on how these callbacks are used, see the documentation for +C<L</default_generator>> and C<L</default_installer>>. + +=head2 Export Configuration + +The C<exports> list may be provided as an array reference or a hash reference. +The list is processed in such a way that the following are equivalent: + + { exports => [ qw(foo bar baz), quux => \&quux_generator ] } + + { exports => + { foo => undef, bar => undef, baz => undef, quux => \&quux_generator } } + +Generators are code that return coderefs. They are called with four +parameters: + + $class - the class whose exporter has been called (the exporting class) + $name - the name of the export for which the routine is being build + \%arg - the arguments passed for this export + \%col - the collections for this import + +Given the configuration in the L</SYNOPSIS>, the following C<use> statement: + + use Text::Tweaker + reformat => { -as => 'make_narrow', width => 33 }, + defaults => { eol => 'CR' }; + +would result in the following call to C<&build_reformatter>: + + my $code = build_reformatter( + 'Text::Tweaker', + 'reformat', + { width => 33 }, # note that -as is not passed in + { defaults => { eol => 'CR' } }, + ); + +The returned coderef (C<$code>) would then be installed as C<make_narrow> in the +calling package. + +Instead of providing a coderef in the configuration, a reference to a method +name may be provided. This method will then be called on the invocant of the +C<import> method. (In this case, we do not pass the C<$class> parameter, as it +would be redundant.) + +=head2 Group Configuration + +The C<groups> list can be passed in the same forms as C<exports>. Groups must +have values to be meaningful, which may either list exports that make up the +group (optionally with arguments) or may provide a way to build the group. + +The simpler case is the first: a group definition is a list of exports. Here's +the example that could go in exporter in the L</SYNOPSIS>. + + groups => { + default => [ qw(reformat) ], + shorteners => [ qw(squish trim) ], + email_safe => [ + 'indent', + reformat => { -as => 'email_format', width => 72 } + ], + }, + +Groups are imported by specifying their name prefixed be either a dash or a +colon. This line of code would import the C<shorteners> group: + + use Text::Tweaker qw(-shorteners); + +Arguments passed to a group when importing are merged into the groups options +and passed to any relevant generators. Groups can contain other groups, but +looping group structures are ignored. + +The other possible value for a group definition, a coderef, allows one +generator to build several exportable routines simultaneously. This is useful +when many routines must share enclosed lexical variables. The coderef must +return a hash reference. The keys will be used as export names and the values +are the subs that will be exported. + +This example shows a simple use of the group generator. + + package Data::Crypto; + use Sub::Exporter -setup => { groups => { cipher => \&build_cipher_group } }; + + sub build_cipher_group { + my ($class, $group, $arg) = @_; + my ($encode, $decode) = build_codec($arg->{secret}); + return { cipher => $encode, decipher => $decode }; + } + +The C<cipher> and C<decipher> routines are built in a group because they are +built together by code which encloses their secret in their environment. + +=head3 Default Groups + +If a module that uses Sub::Exporter is C<use>d with no arguments, it will try +to export the group named C<default>. If that group has not been specifically +configured, it will be empty, and nothing will happen. + +Another group is also created if not defined: C<all>. The C<all> group +contains all the exports from the exports list. + +=head2 Collector Configuration + +The C<collectors> entry in the exporter configuration gives names which, when +found in the import call, have their values collected and passed to every +generator. + +For example, the C<build_analyzer> generator that we saw above could be +rewritten as: + + sub build_analyzer { + my ($class, $name, $arg, $col) = @_; + + return sub { + my $data = shift; + my $tolerance = shift || $arg->{tolerance} || $col->{defaults}{tolerance}; + my $passes = shift || $arg->{passes} || $col->{defaults}{passes}; + + analyze($data, $tolerance, $passes); + } + } + +That would allow the importer to specify global defaults for his imports: + + use Data::Analyze + 'analyze', + analyze => { tolerance => 0.10, -as => analyze10 }, + analyze => { tolerance => 0.15, passes => 50, -as => analyze50 }, + defaults => { passes => 10 }; + + my $A = analyze10($data); # equivalent to analyze($data, 0.10, 10); + my $C = analyze50($data); # equivalent to analyze($data, 0.15, 50); + my $B = analyze($data, 0.20); # equivalent to analyze($data, 0.20, 10); + +If values are provided in the C<collectors> list during exporter setup, they +must be code references, and are used to validate the importer's values. The +validator is called when the collection is found, and if it returns false, an +exception is thrown. We could ensure that no one tries to set a global data +default easily: + + collectors => { defaults => sub { return (exists $_[0]->{data}) ? 0 : 1 } } + +Collector coderefs can also be used as hooks to perform arbitrary actions +before anything is exported. + +When the coderef is called, it is passed the value of the collection and a +hashref containing the following entries: + + name - the name of the collector + config - the exporter configuration (hashref) + import_args - the arguments passed to the exporter, sans collections (aref) + class - the package on which the importer was called + into - the package into which exports will be exported + +Collectors with all-caps names (that is, made up of underscore or capital A +through Z) are reserved for special use. The only currently implemented +special collector is C<INIT>, whose hook (if present in the exporter +configuration) is always run before any other hook. + +=head1 CALLING THE EXPORTER + +Arguments to the exporter (that is, the arguments after the module name in a +C<use> statement) are parsed as follows: + +First, the collectors gather any collections found in the arguments. Any +reference type may be given as the value for a collector. For each collection +given in the arguments, its validator (if any) is called. + +Next, groups are expanded. If the group is implemented by a group generator, +the generator is called. There are two special arguments which, if given to a +group, have special meaning: + + -prefix - a string to prepend to any export imported from this group + -suffix - a string to append to any export imported from this group + +Finally, individual export generators are called and all subs, generated or +otherwise, are installed in the calling package. There is only one special +argument for export generators: + + -as - where to install the exported sub + +Normally, C<-as> will contain an alternate name for the routine. It may, +however, contain a reference to a scalar. If that is the case, a reference the +generated routine will be placed in the scalar referenced by C<-as>. It will +not be installed into the calling package. + +=head2 Special Exporter Arguments + +The generated exporter accept some special options, which may be passed as the +first argument, in a hashref. + +These options are: + + into_level + into + generator + installer + +These override the same-named configuration options described in L</EXPORTER +CONFIGURATION>. + +=head1 SUBROUTINES + +=head2 setup_exporter + +This routine builds and installs an C<import> routine. It is called with one +argument, a hashref containing the exporter configuration. Using this, it +builds an exporter and installs it into the calling package with the name +"import." In addition to the normal exporter configuration, a few named +arguments may be passed in the hashref: + + into - into what package should the exporter be installed + into_level - into what level up the stack should the exporter be installed + as - what name should the installed exporter be given + +By default the exporter is installed with the name C<import> into the immediate +caller of C<setup_exporter>. In other words, if your package calls +C<setup_exporter> without providing any of the three above arguments, it will +have an C<import> routine installed. + +Providing both C<into> and C<into_level> will cause an exception to be thrown. + +The exporter is built by C<L</build_exporter>>. + +=head2 build_exporter + +Given a standard exporter configuration, this routine builds and returns an +exporter -- that is, a subroutine that can be installed as a class method to +perform exporting on request. + +Usually, this method is called by C<L</setup_exporter>>, which then installs +the exporter as a package's import routine. + +=head2 default_generator + +This is Sub::Exporter's default generator. It takes bits of configuration that +have been gathered during the import and turns them into a coderef that can be +installed. + + my $code = default_generator(\%arg); + +Passed arguments are: + + class - the class on which the import method was called + name - the name of the export being generated + arg - the arguments to the generator + col - the collections + + generator - the generator to be used to build the export (code or scalar ref) + +=head2 default_installer + +This is Sub::Exporter's default installer. It does what Sub::Exporter +promises: it installs code into the target package. + + default_installer(\%arg, \@to_export); + +Passed arguments are: + + into - the package into which exports should be delivered + +C<@to_export> is a list of name/value pairs. The default exporter assigns code +(the values) to named slots (the names) in the given package. If the name is a +scalar reference, the scalar reference is made to point to the code reference +instead. + +=head1 EXPORTS + +Sub::Exporter also offers its own exports: the C<setup_exporter> and +C<build_exporter> routines described above. It also provides a special "setup" +collector, which will set up an exporter using the parameters passed to it. + +Note that the "setup" collector (seen in examples like the L</SYNOPSIS> above) +uses C<build_exporter>, not C<setup_exporter>. This means that the special +arguments like "into" and "as" for C<setup_exporter> are not accepted here. +Instead, you may write something like: + + use Sub::Exporter + { into => 'Target::Package' }, + -setup => { + -as => 'do_import', + exports => [ ... ], + } + ; + +Finding a good reason for wanting to do this is left as an exercise for the +reader. + +=head1 COMPARISONS + +There are a whole mess of exporters on the CPAN. The features included in +Sub::Exporter set it apart from any existing Exporter. Here's a summary of +some other exporters and how they compare. + +=over + +=item * L<Exporter> and co. + +This is the standard Perl exporter. Its interface is a little clunky, but it's +fast and ubiquitous. It can do some things that Sub::Exporter can't: it can +export things other than routines, it can import "everything in this group +except this symbol," and some other more esoteric things. These features seem +to go nearly entirely unused. + +It always exports things exactly as they appear in the exporting module; it +can't rename or customize routines. Its groups ("tags") can't be nested. + +L<Exporter::Lite> is a whole lot like Exporter, but it does significantly less: +it supports exporting symbols, but not groups, pattern matching, or negation. + +The fact that Sub::Exporter can't export symbols other than subroutines is +a good idea, not a missing feature. + +For simple uses, setting up Sub::Exporter is about as easy as Exporter. For +complex uses, Sub::Exporter makes hard things possible, which would not be +possible with Exporter. + +When using a module that uses Sub::Exporter, users familiar with Exporter will +probably see no difference in the basics. These two lines do about the same +thing in whether the exporting module uses Exporter or Sub::Exporter. + + use Some::Module qw(foo bar baz); + use Some::Module qw(foo :bar baz); + +The definition for exporting in Exporter.pm might look like this: + + package Some::Module; + use base qw(Exporter); + our @EXPORT_OK = qw(foo bar baz quux); + our %EXPORT_TAGS = (bar => [ qw(bar baz) ]); + +Using Sub::Exporter, it would look like this: + + package Some::Module; + use Sub::Exporter -setup => { + exports => [ qw(foo bar baz quux) ], + groups => { bar => [ qw(bar baz) ]} + }; + +Sub::Exporter respects inheritance, so that a package may export inherited +routines, and will export the most inherited version. Exporting methods +without currying away the invocant is a bad idea, but Sub::Exporter allows you +to do just that -- and anyway, there are other uses for this feature, like +packages of exported subroutines which use inheritance specifically to allow +more specialized, but similar, packages. + +L<Exporter::Easy> provides a wrapper around the standard Exporter. It makes it +simpler to build groups, but doesn't provide any more functionality. Because +it is a front-end to Exporter, it will store your exporter's configuration in +global package variables. + +=item * Attribute-Based Exporters + +Some exporters use attributes to mark variables to export. L<Exporter::Simple> +supports exporting any kind of symbol, and supports groups. Using a module +like Exporter or Sub::Exporter, it's easy to look at one place and see what is +exported, but it's impossible to look at a variable definition and see whether +it is exported by that alone. Exporter::Simple makes this trade in reverse: +each variable's declaration includes its export definition, but there is no one +place to look to find a manifest of exports. + +More importantly, Exporter::Simple does not add any new features to those of +Exporter. In fact, like Exporter::Easy, it is just a front-end to Exporter, so +it ends up storing its configuration in global package variables. (This means +that there is one place to look for your exporter's manifest, actually. You +can inspect the C<@EXPORT> package variables, and other related package +variables, at runtime.) + +L<Perl6::Export> isn't actually attribute based, but looks similar. Its syntax +is borrowed from Perl 6, and implemented by a source filter. It is a prototype +of an interface that is still being designed. It should probably be avoided +for production work. On the other hand, L<Perl6::Export::Attrs> implements +Perl 6-like exporting, but translates it into Perl 5 by providing attributes. + +=item * Other Exporters + +L<Exporter::Renaming> wraps the standard Exporter to allow it to export symbols +with changed names. + +L<Class::Exporter> performs a special kind of routine generation, giving each +importing package an instance of your class, and then exporting the instance's +methods as normal routines. (Sub::Exporter, of course, can easily emulate this +behavior, as shown above.) + +L<Exporter::Tidy> implements a form of renaming (using its C<_map> argument) +and of prefixing, and implements groups. It also avoids using package +variables for its configuration. + +=back + +=head1 TODO + +=over + +=item * write a set of longer, more demonstrative examples + +=item * solidify the "custom exporter" interface (see C<&default_exporter>) + +=item * add an "always" group + +=back + +=head1 THANKS + +Hans Dieter Pearcey provided helpful advice while I was writing Sub::Exporter. +Ian Langworth and Shawn Sorichetti asked some good questions and helped me +improve my documentation quite a bit. Yuval Kogman helped me find a bunch of +little problems. + +Thanks, guys! + +=head1 BUGS + +Please report any bugs or feature requests through the web interface at +L<http://rt.cpan.org>. I will be notified, and then you'll automatically be +notified of progress on your bug as I make changes. + +=head1 AUTHOR + +Ricardo Signes <rjbs@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2007 by Ricardo Signes. + +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/Sub/Exporter/Cookbook.pod b/lib/Sub/Exporter/Cookbook.pod new file mode 100644 index 0000000..70a124b --- /dev/null +++ b/lib/Sub/Exporter/Cookbook.pod @@ -0,0 +1,308 @@ + +# ABSTRACT: useful, demonstrative, or stupid Sub::Exporter tricks +# PODNAME: Sub::Exporter::Cookbook + +__END__ + +=pod + +=head1 NAME + +Sub::Exporter::Cookbook - useful, demonstrative, or stupid Sub::Exporter tricks + +=head1 VERSION + +version 0.987 + +=head1 OVERVIEW + +Sub::Exporter is a fairly simple tool, and can be used to achieve some very +simple goals. Its basic behaviors and their basic application (that is, +"traditional" exporting of routines) are described in +L<Sub::Exporter::Tutorial> and L<Sub::Exporter>. This document presents +applications that may not be immediately obvious, or that can demonstrate how +certain features can be put to use (for good or evil). + +=head1 THE RECIPES + +=head2 Exporting Methods as Routines + +With Exporter.pm, exporting methods is a non-starter. Sub::Exporter makes it +simple. By using the C<curry_method> utility provided in +L<Sub::Exporter::Util>, a method can be exported with the invocant built in. + + package Object::Strenuous; + + use Sub::Exporter::Util 'curry_method'; + use Sub::Exporter -setup => { + exports => [ objection => curry_method('new') ], + }; + +With this configuration, the importing code may contain: + + my $obj = objection("irrelevant"); + +...and this will be equivalent to: + + my $obj = Object::Strenuous->new("irrelevant"); + +The built-in invocant is determined by the invocant for the C<import> method. +That means that if we were to subclass Object::Strenuous as follows: + + package Object::Strenuous::Repeated; + @ISA = 'Object::Strenuous'; + +...then importing C<objection> from the subclass would build-in that subclass. + +Finally, since the invocant can be an object, you can write something like +this: + + package Cypher; + use Sub::Exporter::Util 'curry_method'; + use Sub::Exporter -setup => { + exports => [ encypher => curry_method ], + }; + +with the expectation that C<import> will be called on an instantiated Cypher +object: + + BEGIN { + my $cypher = Cypher->new( ... ); + $cypher->import('encypher'); + } + +Now there is a globally-available C<encypher> routine which calls the encypher +method on an otherwise unavailable Cypher object. + +=head2 Exporting Methods as Methods + +While exporting modules usually export subroutines to be called as subroutines, +it's easy to use Sub::Exporter to export subroutines meant to be called as +methods on the importing package or its objects. + +Here's a trivial (and naive) example: + + package Mixin::DumpObj; + + use Data::Dumper; + + use Sub::Exporter -setup => { + exports => [ qw(dump) ] + }; + + sub dump { + my ($self) = @_; + return Dumper($self); + } + +When writing your own object class, you can then import C<dump> to be used as a +method, called like so: + + $object->dump; + +By assuming that the importing class will provide a certain interface, a +method-exporting module can be used as a simple plugin: + + package Number::Plugin::Upto; + use Sub::Exporter -setup => { + into => 'Number', + exports => [ qw(upto) ], + groups => [ default => [ qw(upto) ] ], + }; + + sub upto { + my ($self) = @_; + return 1 .. abs($self->as_integer); + } + +The C<into> line in the configuration says that this plugin will export, by +default, into the Number package, not into the C<use>-ing package. It can be +exported anyway, though, and will work as long as the destination provides an +C<as_integer> method like the one it expects. To import it to a different +destination, one can just write: + + use Number::Plugin::Upto { into => 'Quantity' }; + +=head2 Mixing-in Complex External Behavior + +When exporting methods to be used as methods (see above), one very powerful +option is to export methods that are generated routines that maintain an +enclosed reference to the exporting module. This allows a user to import a +single method which is implemented in terms of a complete, well-structured +package. + +Here is a very small example: + + package Data::Analyzer; + + use Sub::Exporter -setup => { + exports => [ analyze => \'_generate_analyzer' ], + }; + + sub _generate_analyzer { + my ($mixin, $name, $arg, $col) = @_; + + return sub { + my ($self) = @_; + + my $values = [ $self->values ]; + + my $analyzer = $mixin->new($values); + $analyzer->perform_analysis; + $analyzer->aggregate_results; + + return $analyzer->summary; + }; + } + +If imported by any package providing a C<values> method, this plugin will +provide a single C<analyze> method that acts as a simple interface to a more +complex set of behaviors. + +Even more importantly, because the C<$mixin> value will be the invocant on +which the C<import> was actually called, one can subclass C<Data::Analyzer> and +replace only individual pieces of the complex behavior, making it easy to write +complex, subclassable toolkits with simple single points of entry for external +interfaces. + +=head2 Exporting Constants + +While Sub::Exporter isn't in the constant-exporting business, it's easy to +export constants by using one of its sister modules, Package::Generator. + + package Important::Constants; + + use Sub::Exporter -setup => { + collectors => [ constants => \'_set_constants' ], + }; + + sub _set_constants { + my ($class, $value, $data) = @_; + + Package::Generator->assign_symbols( + $data->{into}, + [ + MEANING_OF_LIFE => \42, + ONE_TRUE_BASE => \13, + FACTORS => [ 6, 9 ], + ], + ); + + return 1; + } + +Then, someone can write: + + use Important::Constants 'constants'; + + print "The factors @FACTORS produce $MEANING_OF_LIFE in $ONE_TRUE_BASE."; + +(The constants must be exported via a collector, because they are effectively +altering the importing class in a way other than installing subroutines.) + +=head2 Altering the Importer's @ISA + +It's trivial to make a collector that changes the inheritance of an importing +package: + + use Sub::Exporter -setup => { + collectors => { -base => \'_make_base' }, + }; + + sub _make_base { + my ($class, $value, $data) = @_; + + my $target = $data->{into}; + push @{"$target\::ISA"}, $class; + } + +Then, the user of your class can write: + + use Some::Class -base; + +and become a subclass. This can be quite useful in building, for example, a +module that helps build plugins. We may want a few utilities imported, but we +also want to inherit behavior from some base plugin class; + + package Framework::Util; + + use Sub::Exporter -setup => { + exports => [ qw(log global_config) ], + groups => [ _plugin => [ qw(log global_config) ] + collectors => { '-plugin' => \'_become_plugin' }, + }; + + sub _become_plugin { + my ($class, $value, $data) = @_; + + my $target = $data->{into}; + push @{"$target\::ISA"}, $class->plugin_base_class; + + push @{ $data->{import_args} }, '-_plugin'; + } + +Now, you can write a plugin like this: + + package Framework::Plugin::AirFreshener; + use Framework::Util -plugin; + +=head2 Eating Exporter.pm's Brain + +You probably shouldn't actually do this in production. It's offered more as a +demonstration than a suggestion. + + sub exporter_upgrade { + my ($pkg) = @_; + my $new_pkg = "$pkg\::UsingSubExporter"; + + return $new_pkg if $new_pkg->isa($pkg); + + Sub::Exporter::setup_exporter({ + as => 'import', + into => $new_pkg, + exports => [ @{"$pkg\::EXPORT_OK"} ], + groups => { + %{"$pkg\::EXPORT_TAG"}, + default => [ @{"$pkg\::EXPORTS"} ], + }, + }); + + @{"$new_pkg\::ISA"} = $pkg; + return $new_pkg; + } + +This routine, given the name of an existing package configured to use +Exporter.pm, returns the name of a new package with a Sub::Exporter-powered +C<import> routine. This lets you import C<Toolkit::exported_sub> into the +current package with the name C<foo> by writing: + + BEGIN { + require Toolkit; + exporter_upgrade('Toolkit')->import(exported_sub => { -as => 'foo' }) + } + +If you're feeling particularly naughty, this routine could have been declared +in the UNIVERSAL package, meaning you could write: + + BEGIN { + require Toolkit; + Toolkit->exporter_upgrade->import(exported_sub => { -as => 'foo' }) + } + +The new package will have all the same exporter configuration as the original, +but will support export and group renaming, including exporting into scalar +references. Further, since Sub::Exporter uses C<can> to find the routine being +exported, the new package may be subclassed and some of its exports replaced. + +=head1 AUTHOR + +Ricardo Signes <rjbs@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2007 by Ricardo Signes. + +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/Sub/Exporter/Tutorial.pod b/lib/Sub/Exporter/Tutorial.pod new file mode 100644 index 0000000..6674b2c --- /dev/null +++ b/lib/Sub/Exporter/Tutorial.pod @@ -0,0 +1,280 @@ + +# PODNAME: Sub::Exporter::Tutorial +# ABSTRACT: a friendly guide to exporting with Sub::Exporter + +__END__ + +=pod + +=head1 NAME + +Sub::Exporter::Tutorial - a friendly guide to exporting with Sub::Exporter + +=head1 VERSION + +version 0.987 + +=head1 DESCRIPTION + +=head2 What's an Exporter? + +When you C<use> a module, first it is required, then its C<import> method is +called. The Perl documentation tells us that the following two lines are +equivalent: + + use Module LIST; + + BEGIN { require Module; Module->import(LIST); } + +The method named C<import> is the module's I<exporter>, it exports +functions and variables into its caller's namespace. + +=head2 The Basics of Sub::Exporter + +Sub::Exporter builds a custom exporter which can then be installed into your +module. It builds this method based on configuration passed to its +C<setup_exporter> method. + +A very basic use case might look like this: + + package Addition; + use Sub::Exporter; + Sub::Exporter::setup_exporter({ exports => [ qw(plus) ]}); + + sub plus { my ($x, $y) = @_; return $x + $y; } + +This would mean that when someone used your Addition module, they could have +its C<plus> routine imported into their package: + + use Addition qw(plus); + + my $z = plus(2, 2); # this works, because now plus is in the main package + +That syntax to set up the exporter, above, is a little verbose, so for the +simple case of just naming some exports, you can write this: + + use Sub::Exporter -setup => { exports => [ qw(plus) ] }; + +...which is the same as the original example -- except that now the exporter is +built and installed at compile time. Well, that and you typed less. + +=head2 Using Export Groups + +You can specify whole groups of things that should be exportable together. +These are called groups. L<Exporter> calls these tags. To specify groups, you +just pass a C<groups> key in your exporter configuration: + + package Food; + use Sub::Exporter -setup => { + exports => [ qw(apple banana beef fluff lox rabbit) ], + groups => { + fauna => [ qw(beef lox rabbit) ], + flora => [ qw(apple banana) ], + } + }; + +Now, to import all that delicious foreign meat, your consumer needs only to +write: + + use Food qw(:fauna); + use Food qw(-fauna); + +Either one of the above is acceptable. A colon is more traditional, but +barewords with a leading colon can't be enquoted by a fat arrow. We'll see why +that matters later on. + +Groups can contain other groups. If you include a group name (with the leading +dash or colon) in a group definition, it will be expanded recursively when the +exporter is called. The exporter will B<not> recurse into the same group twice +while expanding groups. + +There are two special groups: C<all> and C<default>. The C<all> group is +defined for you and contains all exportable subs. You can redefine it, +if you want to export only a subset when all exports are requested. The +C<default> group is the set of routines to export when nothing specific is +requested. By default, there is no C<default> group. + +=head2 Renaming Your Imports + +Sometimes you want to import something, but you don't like the name as which +it's imported. Sub::Exporter can rename your imports for you. If you wanted +to import C<lox> from the Food package, but you don't like the name, you could +write this: + + use Food lox => { -as => 'salmon' }; + +Now you'd get the C<lox> routine, but it would be called salmon in your +package. You can also rename entire groups by using the C<prefix> option: + + use Food -fauna => { -prefix => 'cute_little_' }; + +Now you can call your C<cute_little_rabbit> routine. (You can also call +C<cute_little_beef>, but that hardly seems as enticing.) + +When you define groups, you can include renaming. + + use Sub::Exporter -setup => { + exports => [ qw(apple banana beef fluff lox rabbit) ], + groups => { + fauna => [ qw(beef lox), rabbit => { -as => 'coney' } ], + } + }; + +A prefix on a group like that does the right thing. This is when it's useful +to use a dash instead of a colon to indicate a group: you can put a fat arrow +between the group and its arguments, then. + + use Food -fauna => { -prefix => 'lovely_' }; + + eat( lovely_coney ); # this works + +Prefixes also apply recursively. That means that this code works: + + use Sub::Exporter -setup => { + exports => [ qw(apple banana beef fluff lox rabbit) ], + groups => { + fauna => [ qw(beef lox), rabbit => { -as => 'coney' } ], + allowed => [ -fauna => { -prefix => 'willing_' }, 'banana' ], + } + }; + + ... + + use Food -allowed => { -prefix => 'any_' }; + + $dinner = any_willing_coney; # yum! + +Groups can also be passed a C<-suffix> argument. + +Finally, if the C<-as> argument to an exported routine is a reference to a +scalar, a reference to the routine will be placed in that scalar. + +=head2 Building Subroutines to Order + +Sometimes, you want to export things that you don't have on hand. You might +want to offer customized routines built to the specification of your consumer; +that's just good business! With Sub::Exporter, this is easy. + +To offer subroutines to order, you need to provide a generator when you set up +your exporter. A generator is just a routine that returns a new routine. +L<perlref> is talking about these when it discusses closures and function +templates. The canonical example of a generator builds a unique incrementor; +here's how you'd do that with Sub::Exporter; + + package Package::Counter; + use Sub::Exporter -setup => { + exports => [ counter => sub { my $i = 0; sub { $i++ } } ], + groups => { default => [ qw(counter) ] }, + }; + +Now anyone can use your Package::Counter module and he'll receive a C<counter> +in his package. It will count up by one, and will never interfere with anyone +else's counter. + +This isn't very useful, though, unless the consumer can explain what he wants. +This is done, in part, by supplying arguments when importing. The following +example shows how a generator can take and use arguments: + + package Package::Counter; + + sub _build_counter { + my ($class, $name, $arg) = @_; + $arg ||= {}; + my $i = $arg->{start} || 0; + return sub { $i++ }; + } + + use Sub::Exporter -setup => { + exports => [ counter => \'_build_counter' ], + groups => { default => [ qw(counter) ] }, + }; + +Now, the consumer can (if he wants) specify a starting value for his counter: + + use Package::Counter counter => { start => 10 }; + +Arguments to a group are passed along to the generators of routines in that +group, but Sub::Exporter arguments -- anything beginning with a dash -- are +never passed in. When groups are nested, the arguments are merged as the +groups are expanded. + +Notice, too, that in the example above, we gave a reference to a method I<name> +rather than a method I<implementation>. By giving the name rather than the +subroutine, we make it possible for subclasses of our "Package::Counter" module +to replace the C<_build_counter> method. + +When a generator is called, it is passed four parameters: + +=over + +=item * the invocant on which the exporter was called + +=item * the name of the export being generated (not the name it's being installed as) + +=item * the arguments supplied for the routine + +=item * the collection of generic arguments + +=back + +The fourth item is the last major feature that hasn't been covered. + +=head2 Argument Collectors + +Sometimes you will want to accept arguments once that can then be available to +any subroutine that you're going to export. To do this, you specify +collectors, like this: + + package Menu::Airline + use Sub::Exporter -setup => { + exports => ... , + groups => ... , + collectors => [ qw(allergies ethics) ], + }; + +Collectors look like normal exports in the import call, but they don't do +anything but collect data which can later be passed to generators. If the +module was used like this: + + use Menu::Airline allergies => [ qw(peanuts) ], ethics => [ qw(vegan) ]; + +...the consumer would get a salad. Also, all the generators would be passed, +as their fourth argument, something like this: + + { allerges => [ qw(peanuts) ], ethics => [ qw(vegan) ] } + +Generators may have arguments in their definition, as well. These must be code +refs that perform validation of the collected values. They are passed the +collection value and may return true or false. If they return false, the +exporter will throw an exception. + +=head2 Generating Many Routines in One Scope + +Sometimes it's useful to have multiple routines generated in one scope. This +way they can share lexical data which is otherwise unavailable. To do this, +you can supply a generator for a group which returns a hashref of names and +code references. This generator is passed all the usual data, and the group +may receive the usual C<-prefix> or C<-suffix> arguments. + +=head1 SEE ALSO + +=over 4 + +=item * + +L<Sub::Exporter> for complete documentation and references to other exporters + +=back + +=head1 AUTHOR + +Ricardo Signes <rjbs@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2007 by Ricardo Signes. + +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/Sub/Exporter/Util.pm b/lib/Sub/Exporter/Util.pm new file mode 100644 index 0000000..4058633 --- /dev/null +++ b/lib/Sub/Exporter/Util.pm @@ -0,0 +1,354 @@ +use strict; +use warnings; +package Sub::Exporter::Util; +{ + $Sub::Exporter::Util::VERSION = '0.987'; +} +# ABSTRACT: utilities to make Sub::Exporter easier + +use Data::OptList (); +use Params::Util (); + + +sub curry_method { + my $override_name = shift; + sub { + my ($class, $name) = @_; + $name = $override_name if defined $override_name; + sub { $class->$name(@_); }; + } +} + +BEGIN { *curry_class = \&curry_method; } + + +sub curry_chain { + # In the future, we can make \%arg an optional prepend, like the "special" + # args to the default Sub::Exporter-generated import routine. + my (@opt_list) = @_; + + my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY'); + + sub { + my ($class) = @_; + + sub { + my $next = $class; + + for my $i (0 .. $#$pairs) { + my $pair = $pairs->[ $i ]; + + unless (Params::Util::_INVOCANT($next)) { ## no critic Private + my $str = defined $next ? "'$next'" : 'undef'; + Carp::croak("can't call $pair->[0] on non-invocant $str") + } + + my ($method, $args) = @$pair; + + if ($i == $#$pairs) { + return $next->$method($args ? @$args : ()); + } else { + $next = $next->$method($args ? @$args : ()); + } + } + }; + } +} + +# =head2 name_map +# +# This utility returns an list to be used in specify export generators. For +# example, the following: +# +# exports => { +# name_map( +# '_?_gen' => [ qw(fee fie) ], +# '_make_?' => [ qw(foo bar) ], +# ), +# } +# +# is equivalent to: +# +# exports => { +# name_map( +# fee => \'_fee_gen', +# fie => \'_fie_gen', +# foo => \'_make_foo', +# bar => \'_make_bar', +# ), +# } +# +# This can save a lot of typing, when providing many exports with similarly-named +# generators. +# +# =cut +# +# sub name_map { +# my (%groups) = @_; +# +# my %map; +# +# while (my ($template, $names) = each %groups) { +# for my $name (@$names) { +# (my $export = $template) =~ s/\?/$name/ +# or Carp::croak 'no ? found in name_map template'; +# +# $map{ $name } = \$export; +# } +# } +# +# return %map; +# } + + +sub merge_col { + my (%groups) = @_; + + my %merged; + + while (my ($default_name, $group) = each %groups) { + while (my ($export_name, $gen) = each %$group) { + $merged{$export_name} = sub { + my ($class, $name, $arg, $col) = @_; + + my $merged_arg = exists $col->{$default_name} + ? { %{ $col->{$default_name} }, %$arg } + : $arg; + + if (Params::Util::_CODELIKE($gen)) { ## no critic Private + $gen->($class, $name, $merged_arg, $col); + } else { + $class->$$gen($name, $merged_arg, $col); + } + } + } + } + + return %merged; +} + + +sub __mixin_class_for { + my ($class, $mix_into) = @_; + require Package::Generator; + my $mixin_class = Package::Generator->new_package({ + base => "$class\:\:__mixin__", + }); + + ## no critic (ProhibitNoStrict) + no strict 'refs'; + if (ref $mix_into) { + unshift @{"$mixin_class" . "::ISA"}, ref $mix_into; + } else { + unshift @{"$mix_into" . "::ISA"}, $mixin_class; + } + return $mixin_class; +} + +sub mixin_installer { + sub { + my ($arg, $to_export) = @_; + + my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into}); + bless $arg->{into} => $mixin_class if ref $arg->{into}; + + Sub::Exporter::default_installer( + { %$arg, into => $mixin_class }, + $to_export, + ); + }; +} + +sub mixin_exporter { + Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically"; + return mixin_installer; +} + + +sub like { + sub { + my ($value, $arg) = @_; + Carp::croak "no regex supplied to regex group generator" unless $value; + + # Oh, qr//, how you bother me! See the p5p thread from around now about + # fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25 + my @values = eval { $value->isa('Regexp') } ? ($value, undef) + : @$value; + + while (my ($re, $opt) = splice @values, 0, 2) { + Carp::croak "given pattern for regex group generater is not a Regexp" + unless eval { $re->isa('Regexp') }; + my @exports = keys %{ $arg->{config}->{exports} }; + my @matching = grep { $_ =~ $re } @exports; + + my %merge = $opt ? %$opt : (); + my $prefix = (delete $merge{-prefix}) || ''; + my $suffix = (delete $merge{-suffix}) || ''; + + for my $name (@matching) { + my $as = $prefix . $name . $suffix; + push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ]; + } + } + + 1; + } +} + +use Sub::Exporter -setup => { + exports => [ qw( + like + name_map + merge_col + curry_method curry_class + curry_chain + mixin_installer mixin_exporter + ) ] +}; + +1; + +__END__ + +=pod + +=head1 NAME + +Sub::Exporter::Util - utilities to make Sub::Exporter easier + +=head1 VERSION + +version 0.987 + +=head1 DESCRIPTION + +This module provides a number of utility functions for performing common or +useful operations when setting up a Sub::Exporter configuration. All of the +utilities may be exported, but none are by default. + +=head1 THE UTILITIES + +=head2 curry_method + + exports => { + some_method => curry_method, + } + +This utility returns a generator which will produce an invocant-curried version +of a method. In other words, it will export a method call with the exporting +class built in as the invocant. + +A module importing the code some the above example might do this: + + use Some::Module qw(some_method); + + my $x = some_method; + +This would be equivalent to: + + use Some::Module; + + my $x = Some::Module->some_method; + +If Some::Module is subclassed and the subclass's import method is called to +import C<some_method>, the subclass will be curried in as the invocant. + +If an argument is provided for C<curry_method> it is used as the name of the +curried method to export. This means you could export a Widget constructor +like this: + + exports => { widget => curry_method('new') } + +This utility may also be called as C<curry_class>, for backwards compatibility. + +=head2 curry_chain + +C<curry_chain> behaves like C<L</curry_method>>, but is meant for generating +exports that will call several methods in succession. + + exports => { + reticulate => curry_chain( + new => gather_data => analyze => [ detail => 100 ] => 'results' + ), + } + +If imported from Spliner, calling the C<reticulate> routine will be equivalent +to: + + Spliner->new->gather_data->analyze(detail => 100)->results; + +If any method returns something on which methods may not be called, the routine +croaks. + +The arguments to C<curry_chain> form an optlist. The names are methods to be +called and the arguments, if given, are arrayrefs to be dereferenced and passed +as arguments to those methods. C<curry_chain> returns a generator like those +expected by Sub::Exporter. + +B<Achtung!> at present, there is no way to pass arguments from the generated +routine to the method calls. This will probably be solved in future revisions +by allowing the opt list's values to be subroutines that will be called with +the generated routine's stack. + +=head2 merge_col + + exports => { + merge_col(defaults => { + twiddle => \'_twiddle_gen', + tweak => \&_tweak_gen, + }), + } + +This utility wraps the given generator in one that will merge the named +collection into its args before calling it. This means that you can support a +"default" collector in multiple exports without writing the code each time. + +You can specify as many pairs of collection names and generators as you like. + +=head2 mixin_installer + + use Sub::Exporter -setup => { + installer => Sub::Exporter::Util::mixin_installer, + exports => [ qw(foo bar baz) ], + }; + +This utility returns an installer that will install into a superclass and +adjust the ISA importing class to include the newly generated superclass. + +If the target of importing is an object, the hierarchy is reversed: the new +class will be ISA the object's class, and the object will be reblessed. + +B<Prerequisites>: This utility requires that Package::Generator be installed. + +=head2 like + +It's a collector that adds imports for anything like given regex. + +If you provide this configuration: + + exports => [ qw(igrep imap islurp exhausted) ], + collectors => { -like => Sub::Exporter::Util::like }, + +A user may import from your module like this: + + use Your::Iterator -like => qr/^i/; # imports igre, imap, islurp + +or + + use Your::Iterator -like => [ qr/^i/ => { -prefix => 'your_' } ]; + +The group-like prefix and suffix arguments are respected; other arguments are +passed on to the generators for matching exports. + +=head1 AUTHOR + +Ricardo Signes <rjbs@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2007 by Ricardo Signes. + +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..f113aea --- /dev/null +++ b/t/00-compile.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.037 + +use Test::More 0.94 tests => 2; + + + +my @module_files = ( + 'Sub/Exporter.pm', + 'Sub/Exporter/Util.pm' +); + + + +# no fake home requested + +my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +my @warnings; +for my $lib (@module_files) +{ + # see L<perlfaq8/How can I capture STDERR from an external command?> + open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + 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; + } +} + + + +# no warning checks; + +BAIL_OUT("Compilation problems") if !Test::More->builder->is_passing; diff --git a/t/000-report-versions-tiny.t b/t/000-report-versions-tiny.t new file mode 100644 index 0000000..690c94b --- /dev/null +++ b/t/000-report-versions-tiny.t @@ -0,0 +1,85 @@ +use strict; +use warnings; +use Test::More 0.88; +# This is a relatively nice way to avoid Test::NoWarnings breaking our +# expectations by adding extra tests, without using no_plan. It also helps +# avoid any other test module that feels introducing random tests, or even +# test plans, is a nice idea. +our $success = 0; +END { $success && done_testing; } + +# List our own version used to generate this +my $v = "\nGenerated by Dist::Zilla::Plugin::ReportVersions::Tiny v1.10\n"; + +eval { # no excuses! + # report our Perl details + my $want = '5.006'; + $v .= "perl: $] (wanted $want) on $^O from $^X\n\n"; +}; +defined($@) and diag("$@"); + +# Now, our module version dependencies: +sub pmver { + my ($module, $wanted) = @_; + $wanted = " (want $wanted)"; + my $pmver; + eval "require $module;"; + if ($@) { + if ($@ =~ m/Can't locate .* in \@INC/) { + $pmver = 'module not found.'; + } else { + diag("${module}: $@"); + $pmver = 'died during require.'; + } + } else { + my $version; + eval { $version = $module->VERSION; }; + if ($@) { + diag("${module}: $@"); + $pmver = 'died during VERSION check.'; + } elsif (defined $version) { + $pmver = "$version"; + } else { + $pmver = '<undef>'; + } + } + + # So, we should be good, right? + return sprintf('%-45s => %-10s%-15s%s', $module, $pmver, $wanted, "\n"); +} + +eval { $v .= pmver('Carp','any version') }; +eval { $v .= pmver('Data::OptList','0.100') }; +eval { $v .= pmver('Exporter','any version') }; +eval { $v .= pmver('ExtUtils::MakeMaker','6.30') }; +eval { $v .= pmver('File::Spec','any version') }; +eval { $v .= pmver('IO::Handle','any version') }; +eval { $v .= pmver('IPC::Open3','any version') }; +eval { $v .= pmver('Params::Util','0.14') }; +eval { $v .= pmver('Sub::Install','0.92') }; +eval { $v .= pmver('Test::More','0.96') }; +eval { $v .= pmver('base','any version') }; +eval { $v .= pmver('lib','any version') }; +eval { $v .= pmver('overload','any version') }; +eval { $v .= pmver('strict','any version') }; +eval { $v .= pmver('subs','any version') }; +eval { $v .= pmver('warnings','any version') }; + + +# All done. +$v .= <<'EOT'; + +Thanks for using my code. I hope it works for you. +If not, please try and include this output in the bug report. +That will help me reproduce the issue and solve your problem. + +EOT + +diag($v); +ok(1, "we really didn't test anything, just reporting data"); +$success = 1; + +# Work around another nasty module on CPAN. :/ +no warnings 'once'; +$Template::Test::NO_FLUSH = 1; +exit 0; diff --git a/t/col-init.t b/t/col-init.t new file mode 100644 index 0000000..52aa8ea --- /dev/null +++ b/t/col-init.t @@ -0,0 +1,65 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests exercise the handling of collections in the exporter option lists. + +=cut + +use Test::More tests => 3; +use Data::OptList qw(mkopt_hash); + +BEGIN { use_ok('Sub::Exporter'); } + +sub is_defined { + my ($class, $value, $arg) = @_; + return defined $value; +} + +my $counter = 0; + +my $config = { + exports => [ qw(circsaw drill handsaw nailgun) ], + collectors => [ + INIT => sub { + my ($value, $arg) = @_; + return 0 if @{$arg->{import_args}}; # in other words, fail if args + $_[0] = [ $counter++ ]; + return 1; + }, + ] +}; + +$config->{$_} = mkopt_hash($config->{$_}) for qw(exports collectors); + +{ + my $collection = Sub::Exporter::_collect_collections( + $config, + [ ], + 'main', + ); + + is_deeply( + $collection, + { INIT => [ 0 ] }, + "collection returned properly from collector", + ); +} + +{ + my $collection = eval { + Sub::Exporter::_collect_collections( + $config, + [ [ handsaw => undef ] ], + 'main', + ); + }; + + like( + $@, + qr/INIT failed/, + "the init collector is run even when other things are here", + ); +} diff --git a/t/collection.t b/t/collection.t new file mode 100644 index 0000000..35dbb48 --- /dev/null +++ b/t/collection.t @@ -0,0 +1,125 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests exercise the handling of collections in the exporter option lists. + +=cut + +use Test::More tests => 8; +use Data::OptList qw(mkopt_hash); + +BEGIN { use_ok('Sub::Exporter'); } + +sub is_defined { + my ($class, $value, $arg) = @_; + return defined $value; +} + +my $config = { + exports => [ + qw(circsaw drill handsaw nailgun), + hammer => sub { sub { print "BANG BANG BANG\n" } }, + ], + groups => { + default => [ + 'handsaw', + 'hammer' => { claw => 1 }, + ], + cutters => [ qw(circsaw handsaw), circsaw => { as => 'buzzsaw' } ], + }, + collectors => [ + 'defaults', + brand_preference => sub { 0 }, + model_preference => sub { 1 }, + sets_own_value => sub { $_[0] = { foo => 10 } }, + definedp => \'is_defined', + ] +}; + +$config->{$_} = mkopt_hash($config->{$_}) + for qw(exports collectors); + +{ + my $collection = Sub::Exporter::_collect_collections( + $config, + [ [ circsaw => undef ], [ defaults => { foo => 1, bar => 2 } ] ], + 'main', + ); + + is_deeply( + $collection, + { defaults => { foo => 1, bar => 2 } }, + "collection returned properly from collector", + ); +} + +{ + my $collection = Sub::Exporter::_collect_collections( + $config, + [ [ sets_own_value => undef ] ], + 'main', + ); + + is_deeply( + $collection, + { sets_own_value => { foo => 10} }, + "a collector can alter the stack to change its own value", + ); +} + +{ + my $arg = [ [ defaults => [ 1 ] ], [ defaults => { foo => 1, bar => 2 } ] ]; + + eval { Sub::Exporter::_collect_collections($config, $arg, 'main'); }; + like( + $@, + qr/collection \S+ provided multiple/, + "can't provide multiple collection values", + ); +} + +{ + # because the brand_preference validator always fails, this should die + my $arg = [ [ brand_preference => [ 1, 2, 3 ] ] ]; + eval { Sub::Exporter::_collect_collections($config, $arg, 'main') }; + like( + $@, + qr/brand_preference failed validation/, + "collector validator prevents bad export" + ); +} + +{ + # the definedp collector should require a defined value; this should be ok + my $arg = [ [ definedp => {} ] ]; + my $collection = Sub::Exporter::_collect_collections($config, $arg, 'main'); + is_deeply( + $collection, + { definedp => {} }, + "collector validator allows collection" + ); +} + +{ + # the definedp collector should require a defined value; this should die + my $arg = [ [ definedp => undef ] ]; + eval { Sub::Exporter::_collect_collections($config, $arg, 'main') }; + like( + $@, + qr/definedp failed validation/, + "collector validator prevents bad export" + ); +} + +{ + my $arg = [ [ model_preference => [ 1, 2, 3 ] ] ]; + my $collection = Sub::Exporter::_collect_collections($config, $arg, 'main'); + is_deeply( + $collection, + { model_preference => [ 1, 2, 3 ] }, + "true-returning validator allows collection", + ); +} diff --git a/t/expand-group.t b/t/expand-group.t new file mode 100644 index 0000000..a3295d2 --- /dev/null +++ b/t/expand-group.t @@ -0,0 +1,214 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests check export group expansion, name prefixing, and option merging. + +=cut + +use Test::More tests => 55; + +BEGIN { use_ok('Sub::Exporter'); } + +my $import_target; + +my $config = { + exports => [ qw(a b c) ], + groups => { + A => [ 'a' ], + B => [ qw(b c) ], + C => [ qw(a b :C) ], + D => [ qw(:A :B) ], + + a_as_b => [ a => { -as => 'b' } ], + prefixed_A => [ -A => { -prefix => 'alfa_' } ], + suffixed_A => [ -A => { -suffix => '_yankee' } ], + diprefixed_A => [ -prefixed_A => { -prefix => 'bravo_' } ], + disuffixed_A => [ -suffixed_A => { -suffix => '_zulu' } ], + presuffixed_A=> [ -A => { -prefix => 'freakin_', -suffix => '_right' } ], + a_to_subref => [ a => { -as => \$import_target }, 'b' ], + prefixed_a_s => [ -a_to_subref => { -prefix => 'alfa_' } ], + } +}; + +my @single_tests = ( + [ "simple group 1", [ ':A' => undef ] => [ [ a => undef ] ] ], + [ "simple group 2", [ ':B' => undef ] => [ [ b => undef ], [ c => undef ] ] ], + + [ + "group of groups", + [ ':D' => undef ], + [ [ a => undef ], [ b => undef ], [ c => undef ] ], + ], + [ + "recursive group", + [ ':C' => undef ], + [ [ a => undef ], [b => undef ] ], + ], + [ + "group with empty args", + [ -A => { } ], + [ [ a => undef ] ], + ], + [ + "group with prefix", + [ -A => { -prefix => 'alpha_' } ], + [ [ a => { -as => 'alpha_a' } ] ], + ], + [ + "group with suffix", + [ -A => { -suffix => '_import' } ], + [ [ a => { -as => 'a_import' } ] ], + ], + [ + "recursive group with prefix", + [ -C => { -prefix => 'kappa_' } ], + [ [ a => { -as => 'kappa_a' } ], [ b => { -as => 'kappa_b' } ] ], + ], + [ + "recursive group with suffix", + [ -C => { -suffix => '_etc' } ], + [ [ a => { -as => 'a_etc' } ], [ b => { -as => 'b_etc' } ] ], + ], + [ + "group that renames", + [ -a_as_b => undef ], + [ [ a => { -as => 'b' } ] ], + ], + [ + "group that renames, with options", + [ -a_as_b => { foo => 10 } ], + [ [ a => { -as => 'b', foo => 10 } ] ], + ], + [ + "group that renames, with a prefix", + [ -a_as_b => { -prefix => 'not_really_' } ], + [ [ a => { -as => 'not_really_b' } ] ], + ], + [ + "group that renames, with a suffix", + [ -a_as_b => { -suffix => '_or_not' } ], + [ [ a => { -as => 'b_or_not' } ] ], + ], + [ + "group that renames, with a prefix and suffix", + [ -a_as_b => { -prefix => 'not_really_' } ], + [ [ a => { -as => 'not_really_b' } ] ], + ], + [ + "recursive group with a built-in prefix", + [ -prefixed_A => undef ], + [ [ a => { -as => 'alfa_a' } ] ], + ], + [ + "recursive group with built-in and passed-in prefix", + [ -prefixed_A => { -prefix => 'bravo_' } ], + [ [ a => { -as => 'bravo_alfa_a' } ] ], + ], + [ + "recursive group with built-in and passed-in suffix", + [ -suffixed_A => { -suffix => '_zulu' } ], + [ [ a => { -as => 'a_yankee_zulu' } ] ], + ], + [ + "multi-prefixed group", + [ -diprefixed_A => undef ], + [ [ a => { -as => 'bravo_alfa_a' } ] ], + ], + [ + "multi-suffixed group", + [ -disuffixed_A => undef ], + [ [ a => { -as => 'a_yankee_zulu' } ] ], + ], + [ + "multi-prefixed group with prefix", + [ -diprefixed_A => { -prefix => 'charlie_' } ], + [ [ a => { -as => 'charlie_bravo_alfa_a' } ] ], + ], + [ + "group with built-in prefix and suffix", + [ -presuffixed_A => undef ], + [ [ a => { -as => 'freakin_a_right' } ] ], + ], + [ + "group with built-in prefix and suffix, plus prefix", + [ -presuffixed_A => { -prefix => 'totally_' } ], + [ [ a => { -as => 'totally_freakin_a_right' } ] ], + ], + [ + "group with built-in prefix and suffix, plus suffix", + [ -presuffixed_A => { -suffix => '_dude' } ], + [ [ a => { -as => 'freakin_a_right_dude' } ] ], + ], + [ + "group with built-in prefix and suffix, plus prefix and suffix", + [ -presuffixed_A => { -prefix => 'totally_', -suffix => '_dude' } ], + [ [ a => { -as => 'totally_freakin_a_right_dude' } ] ], + ], + [ + "group that exports to scalar (unusual)", + [ -a_to_subref => undef ], + [ [ a => { -as => \$import_target } ], [ b => undef ] ], + ], + [ + "group that exports to scalar, with prefix", + [ -a_to_subref => { -prefix => 'jubju' } ], + [ [ a => { -as => \$import_target } ], [ b => { -as => 'jubjub' } ] ], + ], +); + +for my $test (@single_tests) { + my ($label, $given, $expected) = @$test; + + my @got = Sub::Exporter::_expand_group( + 'Class', + $config, + $given, + {}, + ); + + is_deeply(\@got, $expected, "expand_group: $label"); +} + +for my $test (@single_tests) { + my ($label, $given, $expected) = @$test; + + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + [ $given ], + ); + + is_deeply($got, $expected, "expand_groups: $label [single test]"); +} + +my @multi_tests = ( + [ + "group and export", + [ [ ':A', undef ], [ c => undef ] ], + [ [ a => undef ], [ c => undef ] ] + ], + [ + "two groups with different merges", + [ [ -A => { -prefix => 'A_' } ], [ -prefixed_A => { -suffix => '_p' } ] ], + [ + [ a => { -as => 'A_a' } ], + [ a => { -as => 'alfa_a_p' } ], + ] + ], +); + +for my $test (@multi_tests) { + my ($label, $given, $expected) = @$test; + + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + $given, + ); + + is_deeply($got, $expected, "expand_groups: $label"); +} + diff --git a/t/faux-export.t b/t/faux-export.t new file mode 100644 index 0000000..1d07a60 --- /dev/null +++ b/t/faux-export.t @@ -0,0 +1,123 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests check the output of build_installer when handed an alternate +installer that returns its plan. + +=cut + +use Test::More tests => 11; + +BEGIN { use_ok('Sub::Exporter'); } + +use lib 't/lib'; +use Test::SubExporter::Faux; + +my $config = { + exports => [ + qw(circsaw drill handsaw nailgun), + hammer => sub { sub { print "BANG BANG BANG\n" } }, + ], + groups => { + default => [ + 'handsaw', + 'hammer' => { claw => 1 }, + ], + cutters => [ qw(circsaw handsaw), circsaw => { -as => 'buzzsaw' } ], + }, + collectors => [ + 'defaults', + 'brand_preference' => sub { 0 }, + ] +}; + +{ + my ($generator, $installer, $reset, $exports) = faux_installer; + my $code = sub { + $reset->(); + splice @_, 1, 0, { generator => $generator, installer => $installer }; + Sub::Exporter::build_exporter($config)->(@_); + }; + + $code->('Tools::Power'); + exports_ok( + $exports, + [ [ handsaw => {} ], [ hammer => { claw => 1 } ] ], + "exporting with no arguments gave us default group" + ); + + $code->('Tools::Power', ':all'); + exports_ok( + [ sort { $a->[0] cmp $b->[0] } @$exports ], + [ map { [ $_ => {} ] } sort qw(circsaw drill handsaw nailgun hammer), ], + "exporting :all gave us all exports", + ); + + $code->('Tools::Power', drill => { -as => 'auger' }); + exports_ok( + $exports, + [ [ drill => {} ] ], + "'-as' parameter is not passed to generators", + ); + + $code->('Tools::Power', ':cutters'); + exports_ok( + $exports, + [ [ circsaw => {} ], [ handsaw => {} ], [ circsaw => {} ] ], + "group with two export instances of one export", + ); + + eval { $code->('Tools::Power', 'router') }; + like($@, qr/not exported/, "can't export un-exported export (got that?)"); + + eval { $code->('Tools::Power', ':sockets') }; + like($@, qr/not exported/, "can't export nonexistent group, either"); + + # because the brand_preference validator always fails, this should die + eval { $code->('Tools::Power', brand_preference => [ '...' ]) }; + like( + $@, + qr/brand_preference failed validation/, + "collector validator prevents bad export" + ); +} + +{ + my ($generator, $installer, $reset, $exports) = faux_installer; + my $code = sub { + $reset->(); + splice @_, 1, 0, { generator => $generator, installer => $installer }; + Sub::Exporter::build_exporter({ exports => [ 'foo' ] })->(@_); + }; + + $code->('Example::Foo'); + exports_ok( + $exports, + [ ], + "exporting with no arguments gave us default default group, i.e., nothing" + ); + + $code->('Tools::Power', ':all'); + exports_ok( + $exports, + [ [ foo => {} ] ], + "exporting :all gave us all exports, i.e., foo", + ); +} + +{ + package Test::SubExport::FAUX; + my ($generator, $installer, $reset, $exports) = main::faux_installer; + + Sub::Exporter::setup_exporter({ + exports => [ 'X' ], + installer => $installer, + generator => $generator, + }); + __PACKAGE__->import(':all'); + + main::exports_ok($exports, [ [ X => {} ] ], "setup (not built) exporter"); +} diff --git a/t/gen-callable.t b/t/gen-callable.t new file mode 100644 index 0000000..d17705a --- /dev/null +++ b/t/gen-callable.t @@ -0,0 +1,21 @@ +#!perl -T +use strict; +use warnings; + +use Test::More tests => 8; + +use lib 't/lib'; + +BEGIN { + use_ok("Sub::Exporter"); + use_ok("Test::SubExporter::ObjGen", 'baz', '-meta', 'quux', '-ringo'); +} + +is(quux(), 'QUUX', 'blessed coderef generator'); +is(baz(), 'BAZ', 'object with &{} as generator'); + +is(foo(), 'FOO', 'object with &{} as group generator (1/2)'); +is(bar(), 'BAR', 'object with &{} as group generator (2/2)'); + +is(ringo(), 'starr', 'blessed coderef as group generator (1/2)'); +is(richard(), 'starkey', 'blessed coderef as group generator (2/2)'); diff --git a/t/group-generator.t b/t/group-generator.t new file mode 100644 index 0000000..5bfecf0 --- /dev/null +++ b/t/group-generator.t @@ -0,0 +1,191 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests check export group expansion, specifically the expansion of groups +that use group generators. + +=cut + +# XXX: The framework is stolen from expand-group. I guess it should be +# factored out. Whatever. -- rjbs, 2006-03-12 + +use Test::More tests => 12; + +BEGIN { use_ok('Sub::Exporter'); } + +my $alfa = sub { 'alfa' }; +my $bravo = sub { 'bravo' }; + +my $returner = sub { + my ($class, $group, $arg, $collection) = @_; + + my %given = ( + class => $class, + group => $group, + arg => $arg, + collection => $collection, + ); + + return { + foo => sub { return { name => 'foo', %given }; }, + bar => sub { return { name => 'bar', %given }; }, + }; +}; + +my $config = { + exports => [ ], + groups => { + alphabet => sub { { A => $alfa, b => $bravo } }, + broken => sub { [ qw(this is broken because it is not a hashref) ] }, + generated => $returner, + nested => [qw( :generated )], + }, + collectors => [ 'col1' ], +}; + +my @single_tests = ( + # [ comment, \@group, \@output ] + # [ "simple group 1", [ ':A' => undef ] => [ [ a => undef ] ] ], + [ + "simple group generator", + [ -alphabet => undef ], + [ [ A => $alfa ], [ b => $bravo ] ], + ], + [ + "simple group generator with prefix", + [ -alphabet => { -prefix => 'prefix_' } ], + [ [ prefix_A => $alfa ], [ prefix_b => $bravo ] ], + ], +); + +for my $test (@single_tests) { + my ($label, $given, $expected) = @$test; + + my @got = Sub::Exporter::_expand_group( + 'Class', + $config, + $given, + {}, + ); + + is_deeply( + [ sort { lc $a->[0] cmp lc $b->[0] } @got ], + $expected, + "expand_group: $label", + ); +} + +for my $test (@single_tests) { + my ($label, $given, $expected) = @$test; + + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + [ $given ], + ); + + is_deeply( + [ sort { lc $a->[0] cmp lc $b->[0] } @$got ], + $expected, + "expand_groups: $label [single test]", + ); +} + +my @multi_tests = ( + # [ $comment, \@groups, \@output ] +); + +for my $test (@multi_tests) { + my ($label, $given, $expected) = @$test; + + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + $given, + ); + + is_deeply($got, $expected, "expand_groups: $label"); +} + +## + +eval { + Sub::Exporter::_expand_groups('Class', $config, [[ -broken => undef ]]) +}; + +like($@, + qr/did not return a hash/, + "exception on non-hashref groupgen return", +); + +## + +{ + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + [ [ -alphabet => undef ] ], + {}, + ); + + my %code = map { $_->[0] => $_->[1] } @$got; + + my $a = $code{A}; + my $b = $code{b}; + + is($a->(), 'alfa', "generated 'a' sub does what we think"); + is($b->(), 'bravo', "generated 'b' sub does what we think"); +} + +{ + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + [ [ -generated => { xyz => 1 } ] ], + { col1 => { value => 2 } }, + ); + + my %code = map { $_->[0] => $_->[1] } @$got; + + for (qw(foo bar)) { + is_deeply( + $code{$_}->(), + { + name => $_, + class => 'Class', + group => 'generated', + arg => { xyz => 1 }, + collection => { col1 => { value => 2 } }, + }, + "generated foo does what we expect", + ); + } +} + +{ + my $got = Sub::Exporter::_expand_groups( + 'Class', + $config, + [ [ -nested => { xyz => 1 } ] ], + { col1 => { value => 2 } }, + ); + + my %code = map { $_->[0] => $_->[1] } @$got; + + for (qw(foo bar)) { + is_deeply( + $code{$_}->(), + { + name => $_, + class => 'Class', + group => 'generated', + arg => { xyz => 1 }, + collection => { col1 => { value => 2 } }, + }, + "generated foo (via nested group) does what we expect", + ); + } +} diff --git a/t/inherited.t b/t/inherited.t new file mode 100644 index 0000000..005380b --- /dev/null +++ b/t/inherited.t @@ -0,0 +1,33 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests check that the inherited form of a routine is the exported one. + +=cut + +use Test::More tests => 3; + +BEGIN { use_ok('Sub::Exporter'); } + +package E::Parent; +use Sub::Exporter -setup => { exports => [ qw(foo) ] }; + +sub foo { return 1; } + +package E::Child; +use base qw(E::Parent); + +sub foo { return 2; } + +package Test::Sub::Exporter::EPARENT; +E::Parent->import('foo'); + +main::is(foo(), 1, "get result of parent's import"); + +package Test::Sub::Exporter::ECHILD; +E::Child->import('foo'); + +main::is(foo(), 2, "get result of child's import"); diff --git a/t/into-level.t b/t/into-level.t new file mode 100644 index 0000000..1066fec --- /dev/null +++ b/t/into-level.t @@ -0,0 +1,178 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests exercise the "into" and "into_level" special arguments to the built +exporter. + +=cut + +use Test::More tests => 14; + +BEGIN { + use_ok('Sub::Exporter'); +} + +BEGIN { + package Test::SubExport::FROM; + use strict; + use warnings; + use Sub::Exporter -setup => { + exports => [ qw(A B) ], + groups => { + default => [ ':all' ], + a => [ 'A' ], + b => [ 'B' ] + } + }; + + sub A { 'A' } + sub B { 'B' } + + 1; +} + +BEGIN { + package Test::SubExport::HAS_DEFAULT_INTO_LEVEL; + use strict; + use warnings; + use Sub::Exporter -setup => { + exports => [ qw(C) ], + into_level => 1, + }; + + sub C { 'C' } + + 1; +} + +BEGIN { + package Test::SubExport::HAS_DEFAULT_INTO; + use strict; + use warnings; + + use Sub::Exporter -setup => { + exports => [ qw(foo) ], + into => 'Test::SubExport::DEFAULT_INTO', + }; + + sub foo { 'foo' } + + 1; +} + +BEGIN { + package Test::SubExport::INTO; + use strict; + use warnings; + + sub import { + my $package = shift; + my $caller = caller(0); + Test::SubExport::FROM->import( { into => $caller }, @_ ); + } + + 1; +} + +BEGIN { + package Test::SubExport::LEVEL; + use strict; + use warnings; + + sub import { + my $package = shift; + Test::SubExport::FROM->import( { into_level => 1 }, @_ ); + } + + 1; +} + +BEGIN { + package Test::SubExport::DEFAULT_LEVEL; + use strict; + use warnings; + + sub import { + my $package = shift; + Test::SubExport::HAS_DEFAULT_INTO_LEVEL->import(@_); + } + + 1; +} + +package Test::SubExport::INTO::A; +Test::SubExport::INTO->import('A'); + +main::can_ok(__PACKAGE__, 'A' ); +main::cmp_ok( + __PACKAGE__->can('A'), '==', Test::SubExport::FROM->can('A'), + 'sub A was exported' +); + +package Test::SubExport::INTO::ALL; +Test::SubExport::INTO->import(':all'); + +main::can_ok(__PACKAGE__, 'A', 'B' ); + +main::cmp_ok( + __PACKAGE__->can('A'), '==', Test::SubExport::FROM->can('A'), + 'sub A was exported' +); + +main::cmp_ok( + __PACKAGE__->can('B'), '==', Test::SubExport::FROM->can('B'), + 'sub B was exported' +); + +package Test::SubExport::LEVEL::ALL; +Test::SubExport::LEVEL->import(':all'); + +main::can_ok(__PACKAGE__, 'A', 'B' ); + +main::cmp_ok( + __PACKAGE__->can('A'), '==', Test::SubExport::FROM->can('A'), + 'sub A was exported' +); + +main::cmp_ok( + __PACKAGE__->can('B'), '==', Test::SubExport::FROM->can('B'), + 'sub B was exported' +); + +package Test::SubExport::LEVEL::DEFAULT; +Test::SubExport::DEFAULT_LEVEL->import(':all'); + +main::can_ok(__PACKAGE__, 'C'); + +main::cmp_ok( + __PACKAGE__->can('C'), + '==', + Test::SubExport::HAS_DEFAULT_INTO_LEVEL->can('C'), + + 'sub C was exported' +); + +package Test::SubExport::NON_DEFAULT_INTO; + +main::is( + Test::SubExport::DEFAULT_INTO->can('foo'), + undef, + "before import, 'default into' target can't foo", +); + +Test::SubExport::HAS_DEFAULT_INTO->import('-all'); + +main::is( + __PACKAGE__->can('foo'), + undef, + "after import, calling package can't foo", +); + +main::is( + Test::SubExport::DEFAULT_INTO->can('foo'), + \&Test::SubExport::HAS_DEFAULT_INTO::foo, + "after import, calling package can't foo", +); diff --git a/t/lib/Test/SubExporter/DashSetup.pm b/t/lib/Test/SubExporter/DashSetup.pm new file mode 100644 index 0000000..3425322 --- /dev/null +++ b/t/lib/Test/SubExporter/DashSetup.pm @@ -0,0 +1,35 @@ +#!perl +package Test::SubExporter::DashSetup; + +use strict; +use warnings; + +use Sub::Exporter -setup => { + exports => { + xyzzy => undef, + hello_sailor => \&_hs_gen, + }, + groups => { + default => [ qw(xyzzy hello_sailor) ], + sailor => [ + xyzzy => undef, + hello_sailor => { -as => 'hs_works', game => 'zork3' }, + hello_sailor => { -as => 'hs_fails', game => 'zork1' }, + ] + }, + collectors => [ 'defaults' ], +}; + +sub xyzzy { return "Nothing happens." }; + +sub _hs_gen { + my ($class, $name, $arg, $collection) = @_; + + if (($arg->{game}||'') eq 'zork3') { + return sub { return "Something happens!" }; + } else { + return sub { return "Nothing happens yet." }; + } +} + +"y2"; diff --git a/t/lib/Test/SubExporter/Faux.pm b/t/lib/Test/SubExporter/Faux.pm new file mode 100644 index 0000000..a4332e8 --- /dev/null +++ b/t/lib/Test/SubExporter/Faux.pm @@ -0,0 +1,67 @@ + +use strict; +use warnings; +package Test::SubExporter::Faux; + +use base qw(Exporter); + +our @EXPORT = qw(faux_installer exports_ok everything_ok); + +sub faux_installer { + my ($verbose) = @_; + $verbose = 1; + + my @exported; + + my $reset = sub { @exported = () }; + + my $generator = sub { + my ($arg) = @_; + # my ($class, $name, $generator) = @$arg{qw(class name generator)}; + + return $arg; + }; + + my $installer = sub { + my ($arg, $to_export) = @_; + + for (my $i = 0; $i < @$to_export; $i += 2) { + my ($as, $gen_arg) = @$to_export[ $i, $i+1 ]; + + # my ($class, $generator, $name, $arg, $collection, $as, $into) = @_; + my $everything = { + class => $gen_arg->{class}, + generator => $gen_arg->{generator}, + name => $gen_arg->{name}, + arg => $gen_arg->{arg}, + collection => $gen_arg->{col}, + as => $as, + into => $arg->{into}, + }; + + push @exported, [ + $gen_arg->{name}, + ($verbose ? $everything : $gen_arg->{arg}), + ]; + } + }; + + return ($generator, $installer, $reset, \@exported); +} + +sub exports_ok { + my ($got, $expected, $comment) = @_; + my $got_simple = [ map { [ $_->[0], $_->[1]{arg} ] } @$got ]; + my @g = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$got_simple; + my @e = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$expected; + main::is_deeply(\@e, \@g, $comment); +} + +sub everything_ok { + my ($got, $expected, $comment) = @_; + my @g = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$got; + my @e = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @$expected; + main::is_deeply(\@e, \@g, $comment); +} + +1; diff --git a/t/lib/Test/SubExporter/GroupGen.pm b/t/lib/Test/SubExporter/GroupGen.pm new file mode 100644 index 0000000..be95112 --- /dev/null +++ b/t/lib/Test/SubExporter/GroupGen.pm @@ -0,0 +1,57 @@ +#!perl +package Test::SubExporter::GroupGen; + +use strict; +use warnings; + +use Sub::Exporter; + +my $alfa = sub { 'alfa' }; +my $bravo = sub { 'bravo' }; + +my $returner = sub { + my ($class, $group, $arg, $collection) = @_; + + my %given = ( + class => $class, + group => $group, + arg => $arg, + collection => $collection, + ); + + return { + foo => sub { return { name => 'foo', %given }; }, + bar => sub { return { name => 'bar', %given }; }, + }; +}; + +sub gen_group_by_name { + my ($class, $group, $arg, $collection) = @_; + + my %given = ( + class => $class, + group => $group, + arg => $arg, + collection => $collection, + ); + + return { + baz => sub { return { name => 'baz', %given }; }, + }; +} + +my $config = { + exports => [ ], + groups => { + alphabet => sub { { a => $alfa, b => $bravo } }, + generated => $returner, + # symbolic => \&gen_group_by_name, + # symbolic => sub { shift->gen_group_by_name(@_) }, + symbolic => \'gen_group_by_name', + }, + collectors => [ 'col1' ], +}; + +Sub::Exporter::setup_exporter($config); + +"gg"; diff --git a/t/lib/Test/SubExporter/GroupGenSubclass.pm b/t/lib/Test/SubExporter/GroupGenSubclass.pm new file mode 100644 index 0000000..7e34c97 --- /dev/null +++ b/t/lib/Test/SubExporter/GroupGenSubclass.pm @@ -0,0 +1,22 @@ +use strict; +use warnings; + +package Test::SubExporter::GroupGenSubclass; +use base qw(Test::SubExporter::GroupGen); + +sub gen_group_by_name { + my ($class, $group, $arg, $collection) = @_; + + my %given = ( + class => $class, + group => $group, + arg => $arg, + collection => $collection, + ); + + return { + baz => sub { return { name => 'baz-sc', %given }; }, + }; +} + +"power overwhelming"; diff --git a/t/lib/Test/SubExporter/ObjGen.pm b/t/lib/Test/SubExporter/ObjGen.pm new file mode 100644 index 0000000..845d4b4 --- /dev/null +++ b/t/lib/Test/SubExporter/ObjGen.pm @@ -0,0 +1,54 @@ +#!perl +package Test::SubExporter::ObjGen::Obj; + +use strict; +use warnings; + +sub new { + my $class = shift; + my $code = $class->can(shift); + + bless { code => $code } => $class; +} + +sub group { + return { + foo => sub { return 'FOO' }, + bar => sub { return 'BAR' }, + }; +} + +sub baz { + return sub { + return 'BAZ'; + }; +} + +use overload + '&{}' => sub { $_[0]->{code} }, + 'bool' => sub { 1 }; + +package Test::SubExporter::ObjGen; + +my ($group_o, $group_b, $baz, $quux); +BEGIN { + $quux = sub { sub { 'QUUX' } }; + bless $quux => 'Test::SubExporter::Whatever'; + + $group_o = sub { return { + ringo => sub { 'starr' }, + richard => sub { 'starkey' }, + } }; + bless $group_o => 'Test::SubExporter::Whatever'; + + $baz = Test::SubExporter::ObjGen::Obj->new('baz'); + $group_b = Test::SubExporter::ObjGen::Obj->new('group'); +} + +use Sub::Exporter -setup => { + exports => { baz => $baz, quux => $quux }, + groups => { meta => $group_b, ringo => $group_o }, +}; + + +"call me"; diff --git a/t/lib/Test/SubExporter/s_e.pm b/t/lib/Test/SubExporter/s_e.pm new file mode 100644 index 0000000..64c9932 --- /dev/null +++ b/t/lib/Test/SubExporter/s_e.pm @@ -0,0 +1,38 @@ +#!perl +package Test::SubExporter::s_e; + +use strict; +use warnings; + +use Sub::Exporter; + +Sub::Exporter::setup_exporter({ + exports => { + xyzzy => undef, + hello_sailor => \&_hs_gen, + hi_sailor => \"_hs_gen", + }, + groups => { + default => [ qw(xyzzy hello_sailor) ], + sailor => [ + xyzzy => undef, + hello_sailor => { -as => 'hs_works', game => 'zork3' }, + hello_sailor => { -as => 'hs_fails', game => 'zork1' }, + ] + }, + collectors => [ 'defaults' ], +}); + +sub xyzzy { return "Nothing happens." }; + +sub _hs_gen { + my ($class, $name, $arg, $collection) = @_; + + if (($arg->{game}||'') eq 'zork3') { + return sub { return "Something happens!" }; + } else { + return sub { return "Nothing happens yet." }; + } +} + +"y2"; diff --git a/t/real-export-groupgen.t b/t/real-export-groupgen.t new file mode 100644 index 0000000..9ad3d7b --- /dev/null +++ b/t/real-export-groupgen.t @@ -0,0 +1,84 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests check export group expansion, specifically the expansion of groups +that use group generators, more specifically when actually imported. + +=cut + +use Test::More tests => 8; + +use lib 't/lib'; + +use Carp; + +BEGIN { + local $SIG{__DIE__} = sub { Carp::confess @_ }; + use_ok('Test::SubExporter::GroupGen'); + Test::SubExporter::GroupGen->import( + col1 => { value => 2 }, + -generated => { xyz => 1 }, + -generated => { xyz => 5, -prefix => 'five_' }, + -symbolic => { xyz => 2 }, + ); + + use_ok('Test::SubExporter::GroupGenSubclass'); + Test::SubExporter::GroupGenSubclass->import( + col1 => { value => 3 }, + -symbolic => { -prefix => 'subclass_', xyz => 4 }, + ); +} + +for my $routine (qw(foo bar)) { + is_deeply( + main->$routine(), + { + name => $routine, + class => 'Test::SubExporter::GroupGen', + group => 'generated', + arg => { xyz => 1 }, + collection => { col1 => { value => 2 } }, + }, + "generated $routine does what we expect", + ); + + my $five = "five_$routine"; + is_deeply( + main->$five(), + { + name => $routine, + class => 'Test::SubExporter::GroupGen', + group => 'generated', + arg => { xyz => 5 }, + collection => { col1 => { value => 2 } }, + }, + "generated $five does what we expect", + ); +} + +is_deeply( + main->baz(), + { + name => 'baz', + class => 'Test::SubExporter::GroupGen', + group => 'symbolic', + arg => { xyz => 2 }, + collection => { col1 => { value => 2 } }, + }, + "parent class's generated baz does what we expect", +); + +is_deeply( + main->subclass_baz(), + { + name => 'baz-sc', + class => 'Test::SubExporter::GroupGenSubclass', + group => 'symbolic', + arg => { xyz => 4 }, + collection => { col1 => { value => 3 } }, + }, + "inheriting class's generated baz does what we expect", +); diff --git a/t/real-export-href.t b/t/real-export-href.t new file mode 100644 index 0000000..6f97992 --- /dev/null +++ b/t/real-export-href.t @@ -0,0 +1,194 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests exercise the use of Sub::Exporter via its setup_exporter routine. + +They use Test::SubExporter::s_e, bundled in ./t/lib, which uses this calling +style. + +=cut + +use Test::More tests => 48; + +BEGIN { use_ok('Sub::Exporter'); } + +our $exporting_class = 'Test::SubExporter::s_e'; + +use lib 't/lib'; + +for my $iteration (1..2) { + { + package Test::SubExporter::BUILT; + + my $import = Sub::Exporter::build_exporter({ exports => [ 'X' ] }); + + Sub::Exporter::setup_exporter({ + exports => [ 'X' ], + into => 'Test::SubExporter::VIOLATED' . "_$iteration", + as => 'gimme_X_from', + }); + + sub X { return "expected" } + + package Test::SubExporter::BUILT::CONSUMER; + + $import->('Test::SubExporter::BUILT', ':all'); + main::is(X(), "expected", "manually constructed importer worked"); + + eval <<END_TEST; + package Test::SubExporter::VIOLATED_$iteration; + + gimme_X_from('Test::SubExporter::BUILT', ':all'); + main::is(X(), "expected", "manually constructed importer worked"); +END_TEST + } + + package Test::SubExporter::DEFAULT; + main::use_ok($exporting_class); + use subs qw(xyzzy hello_sailor); + + main::is( + xyzzy, + "Nothing happens.", + "DEFAULT: default export xyzzy works as expected" + ); + + main::is( + hello_sailor, + "Nothing happens yet.", + "DEFAULT: default export hello_sailor works as expected" + ); + + package Test::SubExporter::RENAME; + main::use_ok($exporting_class, xyzzy => { -as => 'plugh' }); + use subs qw(plugh); + + main::is( + plugh, + "Nothing happens.", + "RENAME: default export xyzzy=>plugh works as expected" + ); + + package Test::SubExporter::SAILOR; + main::use_ok($exporting_class, ':sailor'); + use subs qw(xyzzy hs_works hs_fails); + + main::is( + xyzzy, + "Nothing happens.", + "SAILOR: default export xyzzy works as expected" + ); + + main::is( + hs_works, + "Something happens!", + "SAILOR: hs_works export works as expected" + ); + + main::is( + hs_fails, + "Nothing happens yet.", + "SAILOR: hs_fails export works as expected" + ); + + package Test::SubExporter::Z3; + main::use_ok( + $exporting_class, + hello_sailor => { game => 'zork3' }, + hi_sailor => undef, + ); + use subs qw(hello_sailor hi_sailor); + + main::is( + hello_sailor, + "Something happens!", + "Z3: custom hello_sailor works as expected" + ); + + main::is( + hi_sailor, + "Nothing happens yet.", + "Z3: hi_sailor, using symbolic import and no args, works as expected" + ); + + package Test::SubExporter::FROTZ_SAILOR; + main::use_ok($exporting_class, -sailor => { -prefix => 'frotz_' }); + use subs map { "frotz_$_" }qw(xyzzy hs_works hs_fails); + + main::is( + frotz_xyzzy, + "Nothing happens.", + "FROTZ_SAILOR: default export xyzzy works as expected" + ); + + main::is( + frotz_hs_works, + "Something happens!", + "FROTZ_SAILOR: hs_works export works as expected" + ); + + main::is( + frotz_hs_fails, + "Nothing happens yet.", + "FROTZ_SAILOR: hs_fails export works as expected" + ); + + package Test::SubExporter::Z3_REF; + + my $hello; + main::use_ok( + $exporting_class, + hello_sailor => { game => 'zork3', -as => \$hello } + ); + + eval "hello_sailor;"; + main::like( + $@, + qr/Bareword "hello_sailor" not allowed/, + "Z3_REF: hello_sailor isn't actually imported to package" + ); + + main::is( + $hello->(), + "Something happens!", + "Z3_REF: hello_sailor properly exported to scalar ref", + ); + + package Test::SubExporter::Z3_BADREF; + + main::require_ok($exporting_class); + + eval { + Test::SubExporter::s_e->import(hello_sailor => { game => 'zork3', -as => {} }); + }; + + main::like( + $@, + qr/invalid reference type/, + "can't pass a non-scalar ref to -as", + ); +} + +sub install_upstream { + Sub::Exporter::setup_exporter({ + exports => [ 'X' ], + as => 'gimme_X_from', + into_level => 1, + }); +} + +package Test::SubExporter::LEVEL_1; + +sub X { return 1 }; + +main::install_upstream; + +package Test::SubExporter::CALLS_LEVEL_1; + +Test::SubExporter::LEVEL_1->gimme_X_from(X => { -as => 'x_from_1' }); +use subs 'x_from_1'; + +main::is(x_from_1(), 1, "imported from uplevel-installed exporter"); diff --git a/t/real-export-setup.t b/t/real-export-setup.t new file mode 100644 index 0000000..de6b4f9 --- /dev/null +++ b/t/real-export-setup.t @@ -0,0 +1,158 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests exercise that the polymorphic exporter-builder used when +Sub::Exporter's -import group is invoked. + +They use Test::SubExporter::DashSetup, bundled in ./t/lib, which uses this +calling style. + +=cut + +use Test::More tests => 40; + +BEGIN { use_ok('Sub::Exporter'); } + +our $exporting_class = 'Test::SubExporter::DashSetup'; + +use lib 't/lib'; + +for my $iteration (1..2) { + { + package Test::SubExporter::SETUP; + use Sub::Exporter -setup => [ qw(X) ]; + + sub X { return "desired" } + + package Test::SubExporter::SETUP::CONSUMER; + + Test::SubExporter::SETUP->import(':all'); + main::is(X(), "desired", "constructed importer (via -setup [LIST]) worked"); + } + + { + package Test::SubExporter::EXPORT_MISSING; + use Sub::Exporter -setup => [ qw(X) ]; + + package Test::SubExporter::SETUP::CONSUMER_OF_MISSING; + + eval { Test::SubExporter::EXPORT_MISSING->import(':all') }; + main::like( + $@, + qr/can't locate export/, + "croak if we're configured to export something that can't be found", + ); + } + + { + package Test::SubExporter::SETUPFAILURE; + eval { Sub::Exporter->import( -setup => sub { 1 }) }; + main::like($@, qr/-setup failed validation/, "only [],{} ok for -setup"); + } + + package Test::SubExporter::DEFAULT; + main::use_ok($exporting_class); + use subs qw(xyzzy hello_sailor); + + main::is( + xyzzy, + "Nothing happens.", + "DEFAULT: default export xyzzy works as expected" + ); + + main::is( + hello_sailor, + "Nothing happens yet.", + "DEFAULT: default export hello_sailor works as expected" + ); + + package Test::SubExporter::RENAME; + main::use_ok($exporting_class, xyzzy => { -as => 'plugh' }); + use subs qw(plugh); + + main::is( + plugh, + "Nothing happens.", + "RENAME: default export xyzzy=>plugh works as expected" + ); + + package Test::SubExporter::SAILOR; + main::use_ok($exporting_class, ':sailor');; + use subs qw(xyzzy hs_works hs_fails); + + main::is( + xyzzy, + "Nothing happens.", + "SAILOR: default export xyzzy works as expected" + ); + + main::is( + hs_works, + "Something happens!", + "SAILOR: hs_works export works as expected" + ); + + main::is( + hs_fails, + "Nothing happens yet.", + "SAILOR: hs_fails export works as expected" + ); + + package Test::SubExporter::Z3; + main::use_ok($exporting_class, hello_sailor => { game => 'zork3' }); + use subs qw(hello_sailor); + + main::is( + hello_sailor, + "Something happens!", + "Z3: custom hello_sailor works as expected" + ); + + package Test::SubExporter::FROTZ_SAILOR; + main::use_ok($exporting_class, -sailor => { -prefix => 'frotz_' }); + use subs map { "frotz_$_" }qw(xyzzy hs_works hs_fails); + + main::is( + frotz_xyzzy, + "Nothing happens.", + "FROTZ_SAILOR: default export xyzzy works as expected" + ); + + main::is( + frotz_hs_works, + "Something happens!", + "FROTZ_SAILOR: hs_works export works as expected" + ); + + main::is( + frotz_hs_fails, + "Nothing happens yet.", + "FROTZ_SAILOR: hs_fails export works as expected" + ); +} + +{ + package Test::SubExporter::SETUPALT; + use Sub::Exporter -setup => { + -as => 'alternimport', + exports => [ qw(Y) ], + }; + + sub X { return "desired" } + sub Y { return "other" } + + package Test::SubExporter::SETUP::ALTCONSUMER; + + Test::SubExporter::SETUPALT->import(':all'); + eval { X() }; + main::like($@, qr/undefined subroutine/i, "X didn't get imported"); + + eval { Y() }; + main::like($@, qr/undefined subroutine/i, "Y didn't get imported"); + + Test::SubExporter::SETUPALT->alternimport(':all'); + main::is(Y(), "other", "other importer (via -setup { -as ...}) worked"); +} diff --git a/t/util-curry.t b/t/util-curry.t new file mode 100644 index 0000000..3434147 --- /dev/null +++ b/t/util-curry.t @@ -0,0 +1,89 @@ +#!perl -T +use strict; +use warnings; + +use Test::More tests => 10; +BEGIN { use_ok("Sub::Exporter"); } + + BEGIN { + package Thing; + BEGIN { main::use_ok('Sub::Exporter::Util', 'curry_class'); } + use Sub::Exporter -setup => { + exports => { + return_invocant => curry_class, + talkback => curry_class('return_invocant'), + }, + }; + + sub new { bless { key => "value" } => $_[0] } + sub return_invocant { return $_[0] } + } + + BEGIN { + package Thing::Subclass; + our @ISA = qw(Thing); + } + +package Test::SubExporter::CURRY::0; + +BEGIN { Thing->import(qw(return_invocant)); } + +main::is( + Thing->return_invocant, + "Thing", + "method call on Thing returns Thing", +); + +main::is( + Thing::Subclass->return_invocant, + "Thing::Subclass", + "method call on Thing::Subclass returns Thing::Subclass", +); + +main::is( + return_invocant(), + 'Thing', + 'return of method class-curried from Thing is Thing' +); + +package Test::SubExporter::CURRY::1; + +BEGIN { Thing::Subclass->import(qw(return_invocant)); } + +main::is( + Thing->return_invocant, + "Thing", + "method call on Thing returns Thing", +); + +main::is( + Thing::Subclass->return_invocant, + "Thing::Subclass", + "method call on Thing::Subclass returns Thing::Subclass", +); + +main::is( + return_invocant(), + 'Thing::Subclass', + 'return of method class-curried from Thing::Subclass is Thing::Subclass' +); + +package Test::SubExporter::CURRY::2; + +BEGIN { Thing->import(qw(talkback)); } + +main::is( + talkback(), + 'Thing', + 'imported talkback acts like return_invocant' +); + +package Test::SubExporter::CURRY::Object; + +BEGIN { Thing->new->import(qw(talkback)); } + +main::isa_ok( + talkback(), + 'Thing', + 'the result of object-curried talkback' +); diff --git a/t/util-currychain.t b/t/util-currychain.t new file mode 100644 index 0000000..2583047 --- /dev/null +++ b/t/util-currychain.t @@ -0,0 +1,68 @@ +#!perl -T +use strict; +use warnings; + +use Test::More tests => 4; + +BEGIN { use_ok("Sub::Exporter::Util", qw(curry_chain)); } + +# So, some packages that we'll chain methods through. +{ + package Test::CurryChain::Head; + sub new { my ($class, @arg) = @_; bless [ @arg ] => $class; } + sub next_obj { shift; return Test::CurryChain::Tail->new(@_); } + sub false { return; } + sub non_invocant { return 1; } + + package Test::CurryChain::Tail; + sub new { my ($class, @arg) = @_; bless [ @arg ] => $class; } + sub rev_guts { return reverse @{shift()}; } +} + +{ + # Then the generator which could be put into a Sub::Exporter -setup. + # This is an optlist. AREF = args; undef = no args; CODE = args generator + my $generator = curry_chain( + next_obj => [ 1, 2, 3 ], + rev_guts => undef, + ); + + my $curried_sub = $generator->('Test::CurryChain::Head'); + my @result = $curried_sub->(); + is_deeply( + \@result, + [ 3, 2, 1], + "simple curried chain behaves as expected" + ); +} + +{ + # This one will fail, beacuse the second call returns false. + my $generator = curry_chain( + new => [ 1, 2, 3 ], + false => undef, + will_fail => undef, + ); + + my $curried_sub = $generator->('Test::CurryChain::Head'); + + eval { $curried_sub->() }; + + like($@, qr/can't call will_fail/, "exception on broken chain"); +} + +{ + # This one will fail, beacuse the second call returns a true non-invocant. + my $generator = curry_chain( + new => [ 1, 2, 3 ], + non_invocant => undef, + will_fail => undef, + ); + + my $curried_sub = $generator->('Test::CurryChain::Head'); + + eval { $curried_sub->() }; + + like($@, qr/can't call will_fail/, "exception on broken chain"); +} + diff --git a/t/util-like.t b/t/util-like.t new file mode 100644 index 0000000..3e72a47 --- /dev/null +++ b/t/util-like.t @@ -0,0 +1,143 @@ +#!perl -T +use strict; +use warnings; + +use Test::More tests => 11; +BEGIN { use_ok("Sub::Exporter"); } + +use lib 't/lib'; +use Test::SubExporter::Faux; + +my ($generator, $installer, $reset, $exports); +BEGIN { ($generator, $installer, $reset, $exports) = faux_installer; } + +my %generator; +BEGIN { + %generator = ( + foo => sub { sub { 1 } }, + bar => sub { sub { 2 } }, + baz => sub { sub { 3 } }, + BAR => sub { sub { 4 } }, + xyzzy => sub { sub { 5 } }, + ); +} + + BEGIN { + isa_ok($installer, 'CODE'); + + package Thing; + BEGIN { main::use_ok('Sub::Exporter::Util', 'like'); } + use Sub::Exporter -setup => { + installer => $installer, + generator => $generator, + collectors => { + -like => like + }, + exports => \%generator, + }; + } + +package main; + +my $code = sub { + $reset->(); + Thing->import(@_); +}; + +$code->(qw(foo xyzzy)); +exports_ok( + $exports, + [ [ foo => {} ], [ xyzzy => {} ] ], + "the basics work normally" +); + +$code->(-like => qr/^b/i); +exports_ok( + $exports, + [ [ BAR => {} ], [ baz => {} ], [ bar => {} ] ], + "give me everything starting with b or B (qr//)" +); + +$code->(-like => [ qr/^b/i ]); +exports_ok( + $exports, + [ [ BAR => {} ], [ baz => {} ], [ bar => {} ] ], + "give me everything starting with b or B ([qr//])" +); + +$code->(-like => [ qr/^b/i => undef ]); +exports_ok( + $exports, + [ [ BAR => {} ], [ baz => {} ], [ bar => {} ] ], + "give me everything starting with b or B ([qr//=>undef])" +); + +# XXX: must use verbose exporter +my %col = ( -like => [ + qr/^b/i => { -prefix => 'like_' }, + qr/zz/i => { -suffix => '_y2' }, +]); + +$code->(%col); + +everything_ok( + $exports, + [ + [ + BAR => { + class => 'Thing', + generator => $generator{BAR}, + name => 'BAR', + arg => {}, + collection => \%col, + as => 'like_BAR', + into => 'main', + }, + ], + [ + bar => { + class => 'Thing', + generator => $generator{bar}, + name => 'bar', + arg => {}, + collection => \%col, + as => 'like_bar', + into => 'main', + }, + ], + [ + baz => { + class => 'Thing', + generator => $generator{baz}, + name => 'baz', + arg => {}, + collection => \%col, + as => 'like_baz', + into => 'main', + }, + ], + [ + xyzzy => { + class => 'Thing', + generator => $generator{xyzzy}, + name => 'xyzzy', + arg => {}, + collection => \%col, + as => 'xyzzy_y2', + into => 'main', + }, + ], + ], + 'give me everything starting with b or B as like_$_ ([qr//=>{...}])' +); + +{ + my $like = Sub::Exporter::Util::like(); + is(ref($like), 'CODE', 'like() gives us a generator'); + + eval { $like->() }; + like($@, qr/no regex supplied/, "exception with no args to like->()"); + + eval { $like->([ "fake*reg{3}exp" => { a => 1 } ]) }; + like($@, qr/not a regex/i, "exception with non qr// pattern in like"); +} diff --git a/t/util-merge.t b/t/util-merge.t new file mode 100644 index 0000000..4b0bbb4 --- /dev/null +++ b/t/util-merge.t @@ -0,0 +1,70 @@ +#!perl -T +use strict; +use warnings; + +use Test::More tests => 8; +BEGIN { use_ok("Sub::Exporter"); } + + BEGIN { + package Thing; + BEGIN { main::use_ok("Sub::Exporter::Util", 'merge_col'); } + + use Sub::Exporter -setup => { + collectors => [ qw(defaults etc) ], + exports => { + merge_col( + defaults => { + stack => sub { my @x = @_; sub { return @x } }, + kcats => \'_kcats_gen', + }, + empty => { + bogus => sub { my @x = @_; sub { return @x } }, + klame => sub { my @x = @_; sub { return @x } }, + }, + etc => { + other => sub { my @x = @_; sub { return @x } }, + }, + ), + plain => sub { my @x = @_; sub { return @x } }, + }, + }; + + sub _kcats_gen { + my @x = @_; + sub { return reverse @x } + } + } + +package Test::SubExporter::MERGE::0; + +my %col; + +BEGIN { + Thing->import( + defaults => ($col{defaults} = { x => 10 }), + etc => ($col{etc} = { home => "Kansas" }), + stack => { x => 20, y => 30 }, + kcats => { y => 3 }, + bogus => undef, + klame => { bar => 99 }, + other => undef, + plain => { foo => 10 }, + ); +} + +my %tests = ( + stack => [ 'Thing', 'stack', { x => 20, y => 30 }, \%col ], + kcats => [ \%col, { x => 10, y => 3 }, 'kcats', 'Thing' ], + bogus => [ 'Thing', 'bogus', {}, \%col ], + klame => [ 'Thing', 'klame', { bar => 99 }, \%col ], + other => [ 'Thing', 'other', { home => "Kansas" }, \%col ], + plain => [ 'Thing', 'plain', { foo => 10 }, \%col ], +); + +while (my ($name, $expected) = each %tests) { + main::is_deeply( + [ __PACKAGE__->$name ], + $expected, + "$name returned proper value", + ); +} diff --git a/t/util-mixin.t b/t/util-mixin.t new file mode 100644 index 0000000..b7cf44e --- /dev/null +++ b/t/util-mixin.t @@ -0,0 +1,133 @@ +#!perl -T +use strict; +use warnings; + +use Test::More; + +BEGIN { + if (eval { require Package::Generator; 1; }) { + plan 'no_plan'; + } else { + plan skip_all => "the mixin exporter requires Package::Generator"; + } +} + +BEGIN { use_ok("Sub::Exporter"); } + + BEGIN { + package Thing; + use Sub::Exporter -setup => { + exports => { + bar => sub { sub { 1 } }, + foo => sub { + my ($c, $n, $a) = @_; + sub { return $c . ($a->{arg}) } + } + }, + }; + } + + BEGIN { + package Thing::Mixin; + BEGIN { main::use_ok("Sub::Exporter::Util", 'mixin_installer'); } + use Sub::Exporter -setup => { + installer => mixin_installer, + exports => { + bar => sub { sub { 1 } }, + foo => sub { + my ($c, $n, $a) = @_; + sub { return $c . ($a->{arg}) } + } + }, + }; + } + +package Test::SubExporter::MIXIN::0; + +BEGIN { + Thing->import( + { installer => Sub::Exporter::Util::mixin_installer }, + -all => { arg => '0' }, + ); +} + +package Test::SubExporter::MIXIN::1; + +BEGIN { + Thing->import( + { installer => Sub::Exporter::Util::mixin_installer }, + -all => { arg => '1' }, + ); +} + +package Test::SubExporter::MIXIN::2; + +BEGIN { + Thing::Mixin->import( + -all => { arg => '2' }, + ); +} + +package Test::SubExporter::MIXIN::3; + +BEGIN { + Thing::Mixin->import( + -all => { arg => '3' }, + ); +} + +package main; + +my @pkg = map { "Test::SubExporter::MIXIN::$_" } (0 .. 3); + +for (0 .. $#pkg) { + my $ext = $_ > 1 ? '::Mixin' : ''; + my $val = eval { $pkg[$_]->foo } || ($@ ? "died: $@" : undef); + + is( + $val, + "Thing$ext$_", + "mixed in method in $pkg[$_] returns correctly" + ); + + is($pkg[$_]->bar, 1, "bar method for $pkg[$_] is ok, too"); +} + +my @super = map {; no strict 'refs'; [ @{$_ . "::ISA"} ] } @pkg; + +for my $x (0 .. $#pkg) { + is(@{$super[$x]}, 1, "one parent for $pkg[$x]: @{$super[$x]}"); + for my $y (($x + 1) .. $#pkg) { + isnt("@{$super[$x]}", "@{$super[$y]}", "parent($x) ne parent($y)") + } +} + +{ + package Test::SubExporter::OBJECT; + + sub new { bless {} => shift } + + sub plugh { "plugh" } +} + +package main; + +my $obj_1 = Test::SubExporter::OBJECT->new; +isa_ok($obj_1, "Test::SubExporter::OBJECT", "first object"); +is(ref $obj_1, "Test::SubExporter::OBJECT", "first object's ref is TSEO"); + +my $obj_2 = Test::SubExporter::OBJECT->new; +isa_ok($obj_2, "Test::SubExporter::OBJECT", "second object"); +is(ref $obj_2, "Test::SubExporter::OBJECT", "second object's ref is TSEO"); + +Thing::Mixin->import({ into => $obj_1 }, qw(bar)); +pass("mixin-exporting to an object didn't die"); + +is( + eval { $obj_1->bar }, + 1, + "now that object has a bar method" +); + +isa_ok($obj_1, "Test::SubExporter::OBJECT"); +isnt(ref $obj_1, "Test::SubExporter::OBJECT", "but its actual class isnt TSEO"); diff --git a/t/util-namemap.t b/t/util-namemap.t new file mode 100644 index 0000000..65cf762 --- /dev/null +++ b/t/util-namemap.t @@ -0,0 +1,28 @@ +#!perl -T +use strict; +use warnings; + +use Test::More skip_all => 'not actually offerring this feature yet'; + +# use Test::More tests => 3; + +BEGIN { use_ok("Sub::Exporter::Util", 'name_map'); } + +is_deeply( + { + name_map( + '_?_gen' => [ qw(fee fie) ], + '_make_?' => [ qw(foo bar) ], + ), + }, + { + fee => \'_fee_gen', + fie => \'_fie_gen', + foo => \'_make_foo', + bar => \'_make_bar', + }, + 'example from docs works just dandy', +); + +eval { name_map(foo => [ qw(bar) ] ) }; +like($@, qr/no \?/, 'exception raised with no ? in template'); diff --git a/t/valid-config.t b/t/valid-config.t new file mode 100644 index 0000000..8351154 --- /dev/null +++ b/t/valid-config.t @@ -0,0 +1,73 @@ +#!perl -T +use strict; +use warnings; + +=head1 TEST PURPOSE + +These tests make sure that invalid configurations passed to +setup/build_exporter throw exceptions. + +=cut + +use Test::More tests => 6; + +BEGIN { use_ok('Sub::Exporter'); } + +eval { + Sub::Exporter::build_exporter({ + exports => [ qw(foo) ], + collectors => [ qw(foo) ], + }) +}; + +like($@, qr/used in both/, "can't use one name in exports and collectors"); + +eval { + Sub::Exporter::build_exporter({ + collections => [ qw(foo) ], # This one gets me all the time. Live & learn. + }) +}; + +like($@, qr/unknown options/, "unknown options raise an exception"); + +eval { + Sub::Exporter::setup_exporter({ + into => 'Your::Face', + into_level => 5, + }) +}; + +like( + $@, + qr/may not both/, + "into and into_level are mutually exclusive (in setup_exporter)" +); + +eval { + Sub::Exporter::build_exporter({})->( + Class => { + into => 'Your::Face', + into_level => 1 + } + ); +}; + +like( + $@, + qr/may not both/, + "into and into_level are mutually exclusive (in exporter)" +); + +eval { + Sub::Exporter::build_exporter({ + into => "This::Doesnt::Matter", + into_level => 0, + }) +}; + +like( + $@, + qr(^into and into_level may not both be supplied to exporter), + "can't use one name in exports and collectors" +); + diff --git a/xt/release/changes_has_content.t b/xt/release/changes_has_content.t new file mode 100644 index 0000000..b3db0de --- /dev/null +++ b/xt/release/changes_has_content.t @@ -0,0 +1,41 @@ +#!perl + +use Test::More tests => 2; + +note 'Checking Changes'; +my $changes_file = 'Changes'; +my $newver = '0.987'; +my $trial_token = '-TRIAL'; + +SKIP: { + ok(-e $changes_file, "$changes_file file exists") + or skip 'Changes is missing', 1; + + ok(_get_changes($newver), "$changes_file has content for $newver"); +} + +done_testing; + +# _get_changes copied and adapted from Dist::Zilla::Plugin::Git::Commit +# by Jerome Quelin +sub _get_changes +{ + my $newver = shift; + + # parse changelog to find commit message + open(my $fh, '<', $changes_file) or die "cannot open $changes_file: $!"; + my $changelog = join('', <$fh>); + close $fh; + + my @content = + grep { /^$newver(?:$trial_token)?(?:\s+|$)/ ... /^\S/ } # from newver to un-indented + split /\n/, $changelog; + shift @content; # drop the version line + + # drop unindented last line and trailing blank lines + pop @content while ( @content && $content[-1] =~ /^(?:\S|\s*$)/ ); + + # return number of non-blank lines + return scalar @content; +} + diff --git a/xt/release/pod-syntax.t b/xt/release/pod-syntax.t new file mode 100644 index 0000000..8a22900 --- /dev/null +++ b/xt/release/pod-syntax.t @@ -0,0 +1,7 @@ +#!perl +use Test::More; + +eval "use Test::Pod 1.41"; +plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; + +all_pod_files_ok(); |