pax_global_header00006660000000000000000000000064135740615650014526gustar00rootroot0000000000000052 comment=5da86b54494363964aaf037c5ecec43f0f8b5ab4 libppix-quotelike-perl-0.008/000077500000000000000000000000001357406156500161445ustar00rootroot00000000000000libppix-quotelike-perl-0.008/Build.PL000066400000000000000000000016201357406156500174370ustar00rootroot00000000000000use strict; use warnings; use 5.006; use lib qw{ inc }; use Module::Build; use My::Module::Build; use My::Module::Meta; use My::Module::Recommend; (my $mbv = Module::Build->VERSION()) =~ s/_//g; my $meta = My::Module::Meta->new(); my %args = ( dist_author => 'Thomas R. Wyant, III F', dist_abstract => 'Parse Perl string literals and string-literal-like things.', module_name => 'PPIx::QuoteLike', build_requires => $meta->build_requires(), requires => $meta->requires( perl => $meta->requires_perl(), ), license => 'perl', add_to_cleanup => [ qw{ cover_db xt/author/optionals } ], ); $mbv >= 0.28 and $args{meta_merge} = $meta->meta_merge(); $mbv >= 0.34 and $args{auto_configure_requires} = 0; # Don't require Module::Build My::Module::Recommend->recommend(); my $bldr = My::Module::Build->new (%args); $bldr->create_build_script (); libppix-quotelike-perl-0.008/Changes000066400000000000000000000050021357406156500174340ustar00rootroot000000000000000.008 2019-08-16 T. R. Wyant Fix broken POD links, and add test to ensure they stay fixed. 0.007 2019-05-31 T. R. Wyant Prohibit interpolation inside \N{...}. Fix error message in eg/pqldump Allow PPIx::QuoteLike::Utils::__variables() to take a PPI::Element (rather than PPI::Node), PPIx::Regexp::Element, PPIx::QuoteLike, or PPIx::QuoteLike::Token. Add eg/variables 0.006 2018-07-09 T. R. Wyant Only standalone graphemes and non-characters allowed as delimiters starting with Perl 5.29.0. Non-ASCII delimiters started working in 5.8.3, so that is what perl_version_introduced() returns for them. Collateral with all this, accept word characters as delimiters, but only with at least one space between the operator and the expression -- that is, 'qq xyx' is OK, but 'qqxyx' is not. 0.005 2016-06-23 T. R. Wyant Fix problem handling nested brackets. Fix various corner cases, including such things as '${^O}', '${]}', and even '$${$_[0]}', which turned out to be '$$' followed by '$_[0]'. Also pulled the variable recognition out into a separate module in anticipation of it being used other places. Dumper message if arg does not parse Recognize "$^O" (e.g.) as interpolating $^O, not $^ followed by a literal "O". 0.004 2016-06-13 T. R. Wyant Require PPI, which was formerly optional. This is because I decided that the variables() method (which needs it) was one of the fundamental points of the module. 0.003 2016-06-12 T. R. Wyant Another attempt to make old Perls work. Version 0.002 assumed I could have other interpolations in a regex with (??{...}), but this turned out not to be the case if Perl was earlier than 5.18.0. This was actually a step in the wrong direction since (?-1) works back to 5.10.0. Add PPIx::QuoteLike::Dumper, redo eg/pqldump to use it. Recognize postderef slice syntax. This is stuff like $x->@[0,2] (array slice) or $x->@{foo,bar} (hash slice). Add methods perl_version_introduced() and perl_version_removed(). As of this release, the former returns '5.000' unless '\F' or postfix dereferencing are detected, and the latter always returns undef. 0.002 2016-06-11 T. R. Wyant Eliminte blockers to running under Perl 5.6. The significant change was replacing (?-1) in a regular expression (introduced in 5.9.5) with (??{...}) (going back to Heaven knows when, and used in Regexp::Common back in 2003). 0.001 2016-06-09 T. R. Wyant Initial release to CPAN. libppix-quotelike-perl-0.008/LICENSES/000077500000000000000000000000001357406156500173515ustar00rootroot00000000000000libppix-quotelike-perl-0.008/LICENSES/Artistic000066400000000000000000000137371357406156500210710ustar00rootroot00000000000000 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. 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 libppix-quotelike-perl-0.008/LICENSES/Copying000066400000000000000000000305301357406156500207050ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy 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. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! libppix-quotelike-perl-0.008/MANIFEST000066400000000000000000000017171357406156500173030ustar00rootroot00000000000000Build.PL Changes eg/README eg/pqldump eg/variables inc/My/Module/Build.pm inc/My/Module/Meta.pm inc/My/Module/Recommend.pm inc/My/Module/Recommend/Any.pm lib/PPIx/QuoteLike.pm lib/PPIx/QuoteLike/Constant.pm lib/PPIx/QuoteLike/Dumper.pm lib/PPIx/QuoteLike/Token.pm lib/PPIx/QuoteLike/Token/Control.pm lib/PPIx/QuoteLike/Token/Delimiter.pm lib/PPIx/QuoteLike/Token/Interpolation.pm lib/PPIx/QuoteLike/Token/String.pm lib/PPIx/QuoteLike/Token/Structure.pm lib/PPIx/QuoteLike/Token/Unknown.pm lib/PPIx/QuoteLike/Token/Whitespace.pm lib/PPIx/QuoteLike/Utils.pm LICENSES/Artistic LICENSES/Copying Makefile.PL MANIFEST This list of files README t/basic.t t/dump.t t/parse.t t/variables.t t/version.t xt/author/carp_not.t xt/author/changes.t xt/author/critic.t xt/author/executable.t xt/author/kwalitee.t xt/author/manifest.t xt/author/minimum_perl.t xt/author/perlcriticrc xt/author/pod.t xt/author/pod_coverage.t xt/author/pod_links.t xt/author/pod_spelling.t META.yml META.json libppix-quotelike-perl-0.008/META.json000066400000000000000000000062461357406156500175750ustar00rootroot00000000000000{ "abstract" : "Parse Perl string literals and string-literal-like things.", "author" : [ "Thomas R. Wyant, III F" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4229", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PPIx-QuoteLike", "no_index" : { "directory" : [ "inc", "t", "xt" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0.88" } }, "runtime" : { "requires" : { "Carp" : "0", "Encode" : "0", "Exporter" : "0", "List::Util" : "0", "PPI::Document" : "1.117", "PPI::Dumper" : "1.117", "Scalar::Util" : "0", "base" : "0", "constant" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } } }, "provides" : { "PPIx::QuoteLike" : { "file" : "lib/PPIx/QuoteLike.pm", "version" : "0.008" }, "PPIx::QuoteLike::Constant" : { "file" : "lib/PPIx/QuoteLike/Constant.pm", "version" : "0.008" }, "PPIx::QuoteLike::Dumper" : { "file" : "lib/PPIx/QuoteLike/Dumper.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token" : { "file" : "lib/PPIx/QuoteLike/Token.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::Control" : { "file" : "lib/PPIx/QuoteLike/Token/Control.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::Delimiter" : { "file" : "lib/PPIx/QuoteLike/Token/Delimiter.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::Interpolation" : { "file" : "lib/PPIx/QuoteLike/Token/Interpolation.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::String" : { "file" : "lib/PPIx/QuoteLike/Token/String.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::Structure" : { "file" : "lib/PPIx/QuoteLike/Token/Structure.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::Unknown" : { "file" : "lib/PPIx/QuoteLike/Token/Unknown.pm", "version" : "0.008" }, "PPIx::QuoteLike::Token::Whitespace" : { "file" : "lib/PPIx/QuoteLike/Token/Whitespace.pm", "version" : "0.008" }, "PPIx::QuoteLike::Utils" : { "file" : "lib/PPIx/QuoteLike/Utils.pm", "version" : "0.008" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "wyant@cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=PPIx-QuoteLike" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/trwyant/perl-PPIx-QuoteLike.git", "web" : "https://github.com/trwyant/perl-PPIx-QuoteLike" } }, "version" : "0.008", "x_serialization_backend" : "JSON::PP version 4.04" } libppix-quotelike-perl-0.008/META.yml000066400000000000000000000040641357406156500174210ustar00rootroot00000000000000--- abstract: 'Parse Perl string literals and string-literal-like things.' author: - 'Thomas R. Wyant, III F' build_requires: Test::More: '0.88' dynamic_config: 1 generated_by: 'Module::Build version 0.4229, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PPIx-QuoteLike no_index: directory: - inc - t - xt provides: PPIx::QuoteLike: file: lib/PPIx/QuoteLike.pm version: '0.008' PPIx::QuoteLike::Constant: file: lib/PPIx/QuoteLike/Constant.pm version: '0.008' PPIx::QuoteLike::Dumper: file: lib/PPIx/QuoteLike/Dumper.pm version: '0.008' PPIx::QuoteLike::Token: file: lib/PPIx/QuoteLike/Token.pm version: '0.008' PPIx::QuoteLike::Token::Control: file: lib/PPIx/QuoteLike/Token/Control.pm version: '0.008' PPIx::QuoteLike::Token::Delimiter: file: lib/PPIx/QuoteLike/Token/Delimiter.pm version: '0.008' PPIx::QuoteLike::Token::Interpolation: file: lib/PPIx/QuoteLike/Token/Interpolation.pm version: '0.008' PPIx::QuoteLike::Token::String: file: lib/PPIx/QuoteLike/Token/String.pm version: '0.008' PPIx::QuoteLike::Token::Structure: file: lib/PPIx/QuoteLike/Token/Structure.pm version: '0.008' PPIx::QuoteLike::Token::Unknown: file: lib/PPIx/QuoteLike/Token/Unknown.pm version: '0.008' PPIx::QuoteLike::Token::Whitespace: file: lib/PPIx/QuoteLike/Token/Whitespace.pm version: '0.008' PPIx::QuoteLike::Utils: file: lib/PPIx/QuoteLike/Utils.pm version: '0.008' requires: Carp: '0' Encode: '0' Exporter: '0' List::Util: '0' PPI::Document: '1.117' PPI::Dumper: '1.117' Scalar::Util: '0' base: '0' constant: '0' perl: '5.006' strict: '0' warnings: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=PPIx-QuoteLike license: http://dev.perl.org/licenses/ repository: git://github.com/trwyant/perl-PPIx-QuoteLike.git version: '0.008' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' libppix-quotelike-perl-0.008/Makefile.PL000066400000000000000000000032051357406156500201160ustar00rootroot00000000000000use 5.006; use strict; use warnings; use lib qw{ inc }; use ExtUtils::MakeMaker; use My::Module::Meta; use My::Module::Recommend; (my $mmv = ExtUtils::MakeMaker->VERSION) =~ s/_//g; my $meta = My::Module::Meta->new(); my %args = ( NAME => 'PPIx::QuoteLike', VERSION_FROM => 'lib/PPIx/QuoteLike.pm', PREREQ_PM => $meta->requires(), PL_FILES => {}, # Prevent old MakeMaker from running Build.PL 'dist' => {COMPRESS => 'gzip', SUFFIX => 'gz'}, AUTHOR => 'Thomas R. Wyant, III F', ABSTRACT => 'Parse Perl string literals and string-literal-like things.', realclean => { FILES => 'cover_db xt/author/optionals' }, ); $mmv >= 6.31 and $args{LICENSE} = 'perl'; $mmv >= 6.4501 and $args{META_MERGE} = $meta->meta_merge(); $mmv >= 6.4701 and $args{MIN_PERL_VERSION} = $meta->requires_perl(); $mmv >= 6.5501 and $args{BUILD_REQUIRES} = $meta->build_requires() or $mmv >= 6.4501 and $args{META_MERGE}{build_requires} = $meta->build_requires(); My::Module::Recommend->recommend(); WriteMakefile (%args); sub MY::postamble { my ( $self, @args ) = @_; my $authortest = $self->test_via_harness( '$(FULLPERLRUN)', '$(AUTHORTEST_FILES)' ); $authortest =~ s/ \s+ \z //smx; $authortest =~ s/ \A \s+ //smx; chomp $authortest; return <<"EOD"; AUTHORTEST_FILES = t/*.t xt/author/*.t xt/author/optionals/*.t authortest :: pure_all \$(FULLPERLRUN) "-Iinc" "-MMy::Module::Recommend" "-e" "My::Module::Recommend->make_optional_modules_tests()" AUTHOR_TESTING=1 $authortest testcover :: pure_all cover -test -ignore_re=inc/ -ignore_re=eg/ EOD } # ex: set textwidth=72 : libppix-quotelike-perl-0.008/README000066400000000000000000000032071357406156500170260ustar00rootroot00000000000000PPIx-QuoteLike is Copyright (C) 2016-2019 by Thomas R. Wyant, III DESCRIPTION This Perl module parses Perl-syntax quote-like strings in a manner more or less consistent with PPI. The PPIx::QuoteLike object is instantiated using new(), passing either one of the relevant PPI objects or a string representation. See the eg/ directory for samples. INSTALLATION This module is best installed using your favorite CPAN client: cpan, cpanp, or cpanm. ActivePerl users can try their ppm. Failing that, you can use one of the two usual incantations: gunzip PPIx-QuoteLike-9.999.tar.gz tar -xf PPIx-QuoteLike-9.999.tar perl Makefile.PL make make test make install or gunzip PPIx-QuoteLike-9.999.tar.gz tar -xf PPIx-QuoteLike-9.999.tar perl Build.PL ./Build ./Build test ./Build install You should substitute the appropriate program name for 'make', eg nmake (typically) under MSWin32, or mms or mmk under VMS. See ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe for a copy of nmake for MSWin32 if you need it. Of course, since it's pure Perl, you can just expand the kit and drop SpaceTrack.pm and the SpaceTrack folder into the Astro directory (creating it if necessary) in the appropriate place in your @INC directories. LICENSING INFORMATION This package is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. libppix-quotelike-perl-0.008/eg/000077500000000000000000000000001357406156500165375ustar00rootroot00000000000000libppix-quotelike-perl-0.008/eg/README000066400000000000000000000014521357406156500174210ustar00rootroot00000000000000This directory contains sample Perl scripts that make use of the PPIx::QuoteLike modules. Specifically it contains: README This file pqldump This script dumps quotelike things from its argument, which can be either the name of a Perl file or a literal string. In the former case the file is run through PPI::Document and anything looking like a string is dumped. In the latter case the content of the argument is dumped. Regular expressions are not dumped by this script; see eg/predump in the PPIx-Regexp distribution for that. variables This script lists all variables used by the file or literal Perl code given in its argument. Variables will be found in regular expressions only if PPIx::Regexp can be loaded. # ex: set filetype=text textwidth=72 autoindent : libppix-quotelike-perl-0.008/eg/pqldump000077500000000000000000000070221357406156500201500ustar00rootroot00000000000000#!/usr/bin/env perl use 5.006; use strict; use warnings; use Getopt::Long 2.33 qw{ :config auto_version }; use Pod::Usage; use PPIx::QuoteLike::Dumper; our $VERSION = '0.008'; my %opt; GetOptions( \%opt, qw{ encoding=s indent=i margin=i perl_version|perl-version! ppi! significant! tokens! variables! }, 'whitespace!' => sub { $opt{significant} = !$_[1]; return; }, help => sub { pod2usage( { -verbose => 2 } ) }, ) or pod2usage( { -verbose => 0 } ); defined $opt{encoding} and binmode STDOUT, ":encoding($opt{encoding})"; my @dumper_arg = map { $_ => $opt{$_} } qw{ encoding indent margin perl_version ppi significant tokens variables }; foreach my $arg ( @ARGV ) { print PPIx::QuoteLike::Dumper->dump( $arg, @dumper_arg, none => "$arg not recognized by PPIx::QuoteLike" ); } __END__ =head1 TITLE pqldump - Dump a quotelike thing =head1 SYNOPSIS pqldump '"foo$bar"' pqldump fubar.pl pqldump -help pqldump -version =head1 OPTIONS =head2 -encoding -encoding utf-8 This option specifies the encoding of the entities to be parsed, and of the output. If unspecified, no encoding is assumed unless the input is a file, in which case the file's encoding is derived from its PPI parse. =head2 -help This option displays the documentation for this script. The script then exits. =head2 -indent -indent 4 This option controls the number of spaces each level of structure is indented. The default is C<-indent 2>. =head2 -margin -margin 2 This option controls the number of spaces of left margin. The default is C<-margin 0>. =head2 -perl-version If asserted, this option causes the minimum Perl version (and the maximum if applicable) to be dumped. The defualt is C<-noperl-version>. =head2 -ppi If asserted, this option causes a PPI dump on any interpolations found. L must be installed for this to work. The default is C<-noppi>. =head2 -significant If this option is asserted, only significant tokens are dumped. As of version 0.004, this only has effect in combination with C<-tokens>, since all tokens interior to the string are significant. The default is C<-nosignificant>. =head2 -tokens If asserted, an unstructured dump of the tokens found is done. The default is C<-notokens>. =head2 -variables If asserted, this option causes the names of variables interpolated by any interpolations found to be dumped. L must be installed for this to work. The default is C<-novariables>. =head2 -version This option displays the version of this script. The script then exits. =head2 -whitespace This option is the inverse of L<-significant|/-significant>, and is added for quasi-compatibility with the L C tool. The default is (and must be) C<-whitespace>. =head1 DETAILS This Perl script is a command-line interface to L's L method. The arguments can be either literals or files. For files, all literals in the file are dumped. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/eg/variables000077500000000000000000000045241357406156500204420ustar00rootroot00000000000000#!/usr/bin/env perl use 5.006; use strict; use warnings; use Getopt::Long 2.33 qw{ :config auto_version }; use Pod::Usage; use PPI::Document; use PPIx::QuoteLike::Utils qw{ __variables }; our $VERSION = '0.008'; my %opt; GetOptions( \%opt, help => sub { pod2usage( { -verbose => 2 } ) }, ) and @ARGV == 1 or pod2usage( { -verbose => 0 } ); my $doc = PPI::Document->new( -e $ARGV[0] ? $ARGV[0] : \$ARGV[0] ); { local $\ = "\n"; print for map { $_->[0] } sort { $a->[2] cmp $b->[2] || $a->[1] cmp $b->[1] } map { [ $_, substr( $_, 0, 1 ), substr( $_, 1 ) ] } __variables( $doc ); } __END__ =head1 TITLE variables - List the variables in a chunk of Perl =head1 SYNOPSIS variables eg/variables variables 'qr/foo$bar/smx' variables -help variables -version =head1 OPTIONS =head2 -help This option displays the documentation for this script. The script then exits. =head2 -version This option displays the version of this script. The script then exits. =head1 DETAILS This Perl script lists the variables in the chunk of Perl specified as the only command argument. This can be either the name of a file or literal Perl code; the choice is a pragmatic one based on whether a file by the given name actually exists. The output is in alphabetical order by variable name, and within variable name by sigil. In the case of subscripted variables, the sigil displayed will be that of the underlying variable. That is, if C<$foo[0]> appears, C<@foo> will be displayed. This script will find variables appearing in the code, and variables interpolated into strings. If L can be loaded, variables interpolated into regular expressions will also be found. The heavy lifting is done by L subroutine L<__variables()|PPIx::QuoteLike::Utils/__variables>. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/inc/000077500000000000000000000000001357406156500167155ustar00rootroot00000000000000libppix-quotelike-perl-0.008/inc/My/000077500000000000000000000000001357406156500173025ustar00rootroot00000000000000libppix-quotelike-perl-0.008/inc/My/Module/000077500000000000000000000000001357406156500205275ustar00rootroot00000000000000libppix-quotelike-perl-0.008/inc/My/Module/Build.pm000066400000000000000000000043321357406156500221260ustar00rootroot00000000000000package My::Module::Build; use strict; use warnings; use Module::Build; our @ISA = qw{ Module::Build }; use Carp; # use lib 'inc'; # Already done because this module is running. use My::Module::Recommend; sub ACTION_authortest { my ( $self, @args ) = @_; local $ENV{AUTHOR_TESTING} = 1; my @depends_on = ( qw{ build } ); -e 'META.json' or push @depends_on, 'distmeta'; $self->depends_on( @depends_on ); $self->test_files( qw{ t xt/author }, My::Module::Recommend->make_optional_modules_tests(), ); $self->depends_on( 'test' ); return; } 1; __END__ =head1 NAME My::Module::Build - Extend Module::Build for PPIx::QuoteLike =head1 SYNOPSIS perl Build.PL ./Build ./Build test ./Build authortest # supplied by this module ./Build install =head1 DESCRIPTION This extension of L adds the following action to those provided by L: authortest =head1 ACTIONS This module provides the following action: =over =item authortest This action runs not only those tests which appear in the F directory, but those that appear in the F directory. The F tests are provided for information only, since some of them (notably F and F) are very sensitive to the configuration under which they run. Some of the F tests require modules that are not named as requirements. These should disable themselves if the required modules are not present. This test is sensitive to the C argument, but not to the C<--test_files> argument. =back =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/inc/My/Module/Meta.pm000066400000000000000000000100701357406156500217510ustar00rootroot00000000000000package My::Module::Meta; use 5.006; use strict; use warnings; use Carp; sub new { my ( $class ) = @_; ref $class and $class = ref $class; my $self = { distribution => $ENV{MAKING_MODULE_DISTRIBUTION}, }; bless $self, $class; return $self; } sub build_requires { return +{ 'Test::More' => 0.88, # Because of done_testing(). }; } sub distribution { my ( $self ) = @_; return $self->{distribution}; } sub meta_merge { return { 'meta-spec' => { version => 2, }, no_index => { directory => [ qw{ inc t xt } ], }, resources => { bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=PPIx-QuoteLike', mailto => 'wyant@cpan.org', }, license => 'http://dev.perl.org/licenses/', repository => { type => 'git', url => 'git://github.com/trwyant/perl-PPIx-QuoteLike.git', web => 'https://github.com/trwyant/perl-PPIx-QuoteLike', }, } }; } sub requires { my ( $self, @extra ) = @_; ## if ( ! $self->distribution() ) { ## } return +{ 'Carp' => 0, 'Encode' => 0, 'Exporter' => 0, 'List::Util' => 0, 'PPI::Document' => 1.117, 'PPI::Dumper' => 1.117, 'Scalar::Util' => 0, 'base' => 0, 'constant' => 0, 'strict' => 0, 'warnings' => 0, @extra, }; } sub requires_perl { return 5.006; } 1; __END__ =head1 NAME My::Module::Meta - Information needed to build PPIx::QuoteLike =head1 SYNOPSIS use lib qw{ inc }; use My::Module::Meta; my $meta = My::Module::Meta->new(); use YAML; print "Required modules:\n", Dump( $meta->requires() ); =head1 DETAILS This module centralizes information needed to build C. It is private to the C package, and may be changed or retracted without notice. =head1 METHODS This class supports the following public methods: =head2 new my $meta = My::Module::Meta->new(); This method instantiates the class. =head2 build_requires use YAML; print Dump( $meta->build_requires() ); This method computes and returns a reference to a hash describing the modules required to build the C package, suitable for use in a F C key, or a F C<< {META_MERGE}->{build_requires} >> or C key. =head2 distribution if ( $meta->distribution() ) { print "Making distribution\n"; } else { print "Not making distribution\n"; } This method returns the value of the environment variable C at the time the object was instantiated. =head2 requires use YAML; print Dump( $meta->requires() ); This method computes and returns a reference to a hash describing the modules required to run the C package, suitable for use in a F C key, or a F C key. Any additional arguments will be appended to the generated hash. In addition, unless L is true, configuration-specific modules may be added. =head2 requires_perl print 'This package requires Perl ', $meta->requires_perl(), "\n"; This method returns the version of Perl required by the package. =head1 ATTRIBUTES This class has no public attributes. =head1 ENVIRONMENT =head2 MAKING_MODULE_DISTRIBUTION This environment variable should be set to a true value if you are making a distribution. This ensures that no configuration-specific information makes it into F. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/inc/My/Module/Recommend.pm000066400000000000000000000077221357406156500230060ustar00rootroot00000000000000package My::Module::Recommend; use strict; use warnings; use Carp; use My::Module::Recommend::Any qw{ __any }; my @optionals = ( __any( 'PPIx::Regexp' => <<'EOD' ), This module is needed to find variables inside nested regular expressions. EOD ); sub make_optional_modules_tests { eval { require Test::Without::Module; 1; } or return; my $dir = 'xt/author/optionals'; -d $dir or mkdir $dir or die "Can not create $dir: $!\n"; opendir my $dh, 't' or die "Can not access t/: $!\n"; while ( readdir $dh ) { m/ \A [.] /smx and next; m/ [.] t \z /smx or next; my $fn = "$dir/$_"; -e $fn and next; print "Creating $fn\n"; open my $fh, '>:encoding(utf-8)', $fn or die "Can not create $fn: $!\n"; print { $fh } <<"EOD"; package main; use strict; use warnings; use Test::More 0.88; use lib qw{ inc }; use My::Module::Recommend; BEGIN { eval { require Test::Without::Module; Test::Without::Module->import( My::Module::Recommend->optionals() ); 1; } or plan skip_all => 'Test::Without::Module not available'; } do 't/$_'; 1; __END__ # ex: set textwidth=72 : EOD } closedir $dh; return $dir; } sub optionals { return ( map { $_->modules() } @optionals ); } sub recommend { my $need_some; foreach my $mod ( @optionals ) { defined( my $msg = $mod->recommend() ) or next; $need_some++ or warn <<'EOD'; The following optional modules were not available: EOD warn "\n$msg"; } $need_some and warn <<'EOD'; It is not necessary to install these now. If you decide to install them later, this software will make use of them when it finds them. EOD return; } 1; =head1 NAME My::Module::Recommend - Recommend modules to install. =head1 SYNOPSIS use lib qw{ inc }; use My::Module::Recommend; My::Module::Recommend->recommend(); =head1 DETAILS This package generates the recommendations for optional modules. It is intended to be called by the build system. The build system's own mechanism is not used because we find its output on the Draconian side. =head1 METHODS This class supports the following public methods: =head2 make_optional_modules_tests My::Module::Recommend->make_optional_modules_tests() This static method creates the optional module tests. These are stub files in F that use C to hide all the optional modules and then invoke the normal tests in F. The aim of these tests is to ensure that we get no test failures if the optional modules are missing. This method is idempotent; that is, it only creates the directory and the individual stub files if they are missing. On success this method returns the name of the optional tests directory. If C can not be loaded this method returns nothing. If the directory or any file can not be created, an exception is thrown. =head2 optionals say for My::Module::Recommend->optionals(); This static method simply returns the names of the optional modules. =head2 recommend My::Module::Recommend->recommend(); This static method examines the current Perl to see which optional modules are installed. If any are not installed, a message is printed to standard error explaining the benefits to be gained from installing the module, and any possible problems with installing it. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2014-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut __END__ # ex: set textwidth=72 : libppix-quotelike-perl-0.008/inc/My/Module/Recommend/000077500000000000000000000000001357406156500224405ustar00rootroot00000000000000libppix-quotelike-perl-0.008/inc/My/Module/Recommend/Any.pm000066400000000000000000000103521357406156500235260ustar00rootroot00000000000000package My::Module::Recommend::Any; use 5.006; use strict; use warnings; use Carp; use Exporter; # Beause the Perl 5.6 Exporter does not export import(). BEGIN { *import = \&Exporter::import; } our $VERSION = '0.008'; our @EXPORT_OK = qw{ __any }; use constant RECOMMEND_TEMPLATE_SINGLE => " * %s is not available.\n"; use constant RECOMMEND_TEMPLATE_MULTI => " * None of %s is available.\n"; sub __any { my ( @args ) = @_; return __PACKAGE__->new( @args ); } sub new { my ( $class, @modules ) = @_; @modules > 1 or croak 'Must specify at least one module and a message'; my $msg = pop @modules; $msg =~ s/ ^\s* / /smxg; return bless { modules => \@modules, message => $msg, }, ref $class || $class; } sub check { my ( $self ) = @_; my @missing; foreach my $m ( $self->modules() ) { eval "require $m; 1" and return; push @missing, $m; } return @missing; } sub modules { my ( $self ) = @_; return @{ $self->{modules} }; } sub recommend { my ( $self ) = @_; my @missing = $self->check() or return; my $tplt = @missing > 1 ? $self->RECOMMEND_TEMPLATE_MULTI() : $self->RECOMMEND_TEMPLATE_SINGLE(); return sprintf( $tplt, join ', ', @missing ) . $self->{message}; } 1; __END__ =head1 NAME My::Module::Recommend::Any - Recommend unless any of a list of modules is installed. =head1 SYNOPSIS use My::Module::Recommend::Any qw{ __any }; my $rec = __any( Fubar => <<'EOD' ); This module is needed to frozz a gaberbucket. If your gaberbucket does not need frozzing you do not need this module. EOD print $rec->recommend(); =head1 DESCRIPTION This module is private to this package, and may be changed or retracted without notice. Documentation is for the benefit of the author only. This module checks whether B modules in given list are installed. If not, it is capable of generating an explanatory message. I am using this rather than the usual install tools' recommendation machinery for greater flexibility, and because I personally have found their output rather Draconian, and my correspondance indicates that my users do too. =head1 METHODS This class supports the following methods which are private to this package and can be changed or retracted without notice. =head2 new my $rec = My::Module::Recommend::Any->new( Foo => "bar\n" ); This static method instantiates the object. The arguments are module names, of which at least one must be installed. The last argument, however, is text giving the reason you need one of the modules. =head2 __any my $rec = __any( Foo => "bar\n" ); This convenience subroutine (B method) wraps L. It is not exported by default, but can be requested explicitly. =head2 check $rec->check() and warn 'Modules are missing'; This method checks to see if any of the given modules are installed. The check is by C on each module. If at least one of the modules are installed it returns nothing. If not, it returns the names of the missing modules in list context, and the number of missing modules in scalar context. =head2 modules say 'Optional modules: ', join ', ', $rec->modules(); This method just returns the names of the modules with which the object was initialized. =head2 recommend my $msg; defined( $msg = $rec->recommend() ) and print $msg; This method computes and returns a recommendation on modules to install. This will consist of a line of text listing the missing modules followed by the explanatory text with which the object was initialized. If no modules are needed it returns nothing. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Tom Wyant (wyant at cpan dot org) =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/000077500000000000000000000000001357406156500167125ustar00rootroot00000000000000libppix-quotelike-perl-0.008/lib/PPIx/000077500000000000000000000000001357406156500175325ustar00rootroot00000000000000libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike.pm000066400000000000000000000670441357406156500220050ustar00rootroot00000000000000package PPIx::QuoteLike; use 5.006; use strict; use warnings; use Carp; use Encode (); use List::Util (); use PPIx::QuoteLike::Constant qw{ MINIMUM_PERL VARIABLE_RE @CARP_NOT }; use PPIx::QuoteLike::Token::Control; use PPIx::QuoteLike::Token::Delimiter; use PPIx::QuoteLike::Token::Interpolation; use PPIx::QuoteLike::Token::String; use PPIx::QuoteLike::Token::Structure; use PPIx::QuoteLike::Token::Unknown; use PPIx::QuoteLike::Token::Whitespace; use Scalar::Util (); our $VERSION = '0.008'; use constant CODE_REF => ref sub {}; use constant ILLEGAL_FIRST => 'Tokenizer found illegal first characters'; use constant MISMATCHED_DELIM => 'Tokenizer found mismatched delimiters'; $PPIx::QuoteLike::DEFAULT_POSTDEREF = 1; { my $match_sq = _match_enclosed( qw< ' > ); my $match_dq = _match_enclosed( qw< " > ); my $match_bt = _match_enclosed( qw< ` > ); sub new { ## no critic (RequireArgUnpacking) my ( $class, $source, %arg ) = @_; my @children; defined $arg{postderef} or $arg{postderef} = $PPIx::QuoteLike::DEFAULT_POSTDEREF; my $self = { children => \@children, encoding => $arg{encoding}, failures => 0, postderef => ( $arg{postderef} ? 1 : 0 ), source => $source, }; bless $self, ref $class || $class; defined( my $string = $self->_stringify_source( $source ) ) or return; my ( $type, $gap, $content, $end_delim, $start_delim ); $arg{trace} and warn "Initial match of $string\n"; # q<>, qq<>, qx<> if ( $string =~ m/ \A \s* ( q [qx]? ) ( \s* ) ( . ) /smxgc ) { ( $type, $gap, $start_delim ) = ( $1, $2, $3 ); not $gap and $start_delim =~ m< \A \w \z >smx and return $self->_link_elems( $self->_unknown( $string, ILLEGAL_FIRST ) ); $arg{trace} and warn "Initial match '$type$start_delim'\n"; $self->{interpolates} = 'qq' eq $type || 'qx' eq $type && q<'> ne $start_delim; $content = substr $string, ( pos $string || 0 ); $end_delim = _matching_delimiter( $start_delim ); if ( $end_delim eq substr $content, -1 ) { chop $content; } else { $end_delim = ''; } # here doc # Note that the regexp used here is slightly wrong in that white # space between the '<<' and the termination string is not # allowed if the termination string is not quoted in some way. } elsif ( $string =~ m/ \A \s* ( << ) ( \s* ) ( \w+ | $match_sq | $match_dq | $match_bt ) \n /smxgc ) { ( $type, $gap, $start_delim ) = ( $1, $2, $3 ); $arg{trace} and warn "Initial match '$type$start_delim$gap'\n"; $self->{interpolates} = $start_delim !~ m/ \A ' /smx; $content = substr $string, ( pos $string || 0 ); $end_delim = _unquote( $start_delim ); if ( $content =~ s/ ^ \Q$end_delim\E \n? \z //smx ) { } else { $end_delim = ''; } $self->{start} = [ PPIx::QuoteLike::Token::Delimiter->__new( content => $start_delim, ), PPIx::QuoteLike::Token::Whitespace->__new( content => "\n", ), ]; $self->{finish} = [ PPIx::QuoteLike::Token::Delimiter->__new( content => $end_delim, ), PPIx::QuoteLike::Token::Whitespace->__new( content => "\n", ), ]; # ``, '', "", <> } elsif ( $string =~ m/ \A \s* ( [`'"<] ) /smxgc ) { ( $type, $gap, $start_delim ) = ( '', '', $1 ); $arg{trace} and warn "Initial match '$type$start_delim'\n"; $self->{interpolates} = q<'> ne $start_delim; $content = substr $string, ( pos $string || 0 ); $end_delim = _matching_delimiter( $start_delim ); if ( $end_delim eq substr $content, -1 ) { chop $content; } else { $end_delim = ''; } # Something we do not recognize } else { $arg{trace} and warn "No initial match\n"; return $self->_link_elems( $self->_unknown( $string, ILLEGAL_FIRST ) ); } $self->{interpolates} = $self->{interpolates} ? 1 : 0; $self->{type} = [ PPIx::QuoteLike::Token::Structure->__new( content => $type, ), length $gap ? PPIx::QuoteLike::Token::Whitespace->__new( content => $gap, ) : () ]; $self->{start} ||= [ PPIx::QuoteLike::Token::Delimiter->__new( content => $start_delim, ), ]; $arg{trace} and warn "Without delimiters: '$content'\n"; if ( $self->{interpolates} ) { { # Single-iteration loop if ( $content =~ m/ \G ( \\ [ULulQEF] ) /smxgc ) { push @children, PPIx::QuoteLike::Token::Control->__new( content => "$1", # Remove magic ); redo; } # Handle \N{...} separately because it can not contain # an interpolation even inside of an # otherwise-interpolating string. That is to say, # "\N{$foo}" is simply invalid, and does not even try to # interpolate $foo. { if ( $content =~ m/ \G ( \\ N [{] ( [^}]+ ) [}] ) /smxgc ) { my ( $seq, $name ) = ( $1, $2 ); # TODO The Regexp is certainly too permissive. For # the moment all I am doing is disallowing # interpolation. push @children, $name =~ m/ [\$\@] /smx ? $self->_unknown( $seq, "Unknown charname '$name'" ) : PPIx::QuoteLike::Token::String->__new( content => $seq, ); redo; } if ( $content =~ m/ \G ( [\$\@] \#? \$* ) /smxgc ) { push @children, $self->_interpolation( "$1", $content ); redo; } if ( $content =~ m/ \G ( \\ . | [^\\\$\@]+ ) /smxgc ) { my $content = $1; @children and $children[-1]->isa( 'PPIx::QuoteLike::Token::String' ) and $content = ( pop @children )->content() . $content; push @children, PPIx::QuoteLike::Token::String->__new( content => $content, ); redo; } } # We might have consecutive strings if _interpolation() # generated a string rather than an interpolation. Merge # these. my @rslt; foreach my $elem ( @children ) { if ( $elem->isa( 'PPIx::QuoteLike::Token::String' ) && @rslt && $rslt[-1]->isa( 'PPIx::QuoteLike::Token::String' ) ) { push @rslt, PPIx::QuoteLike::Token::String->__new( content => join( '', map { $_->content() } pop @rslt, $elem ), ); } else { push @rslt, $elem; } } @children = @rslt; } else { length $content and push @children, PPIx::QuoteLike::Token::String->__new( content => $content, ); } $self->{finish} ||= [ PPIx::QuoteLike::Token::Delimiter->__new( content => $end_delim, ), ]; ref $_[1] and pos( $_[1] ) = pos $string; return $self->_link_elems(); } } sub child { my ( $self, $number ) = @_; return $self->{children}[$number]; } sub children { my ( $self ) = @_; return @{ $self->{children} }; } sub content { my ( $self ) = @_; return join '', map { $_->content() } grep { $_ } $self->elements(); } sub delimiters { my ( $self ) = @_; return join '', grep { defined } map { $self->_get_value_scalar( $_ ) } qw{ start finish }; } sub _get_value_scalar { my ( $self, $method ) = @_; defined( my $val = $self->$method() ) or return; return ref $val ? $val->content() : $val; } sub elements { my ( $self ) = @_; return @{ $self->{elements} ||= [ map { $self->$_() } qw{ type start children finish } ] }; } sub encoding { my ( $self ) = @_; return $self->{encoding}; } sub failures { my ( $self ) = @_; return $self->{failures}; } sub find { my ( $self, $target ) = @_; my $check = CODE_REF eq ref $target ? $target : ref $target ? croak 'find() target may not be ' . ref $target : sub { $_[0]->isa( $target ) }; my @found; foreach my $elem ( $self, $self->elements() ) { $check->( $elem ) and push @found, $elem; } @found or return 0; return \@found; } sub finish { my ( $self, $inx ) = @_; $self->{finish} or return; wantarray and return @{ $self->{finish} }; return $self->{finish}[ $inx || 0 ]; } sub handles { my ( $self, $string ) = @_; return $self->_stringify_source( $string, test => 1 ); } sub interpolates { my ( $self ) = @_; return $self->{interpolates}; } sub perl_version_introduced { my ( $self ) = @_; return List::Util::max( grep { defined $_ } MINIMUM_PERL, $self->{perl_version_introduced}, map { $_->perl_version_introduced() } $self->elements() ); } sub perl_version_removed { my ( $self ) = @_; my $max; foreach my $elem ( $self->elements() ) { if ( defined ( my $ver = $elem->perl_version_removed() ) ) { if ( defined $max ) { $ver < $max and $max = $ver; } else { $max = $ver; } } } return $max; } sub postderef { my ( $self ) = @_; return $self->{postderef}; } sub schild { my ( $self, $inx ) = @_; $inx ||= 0; my @kids = $self->schildren(); return $kids[$inx]; } sub schildren { my ( $self ) = @_; return ( grep { $_->significant() } $self->children() ); } sub source { my ( $self ) = @_; return $self->{source}; } sub start { my ( $self, $inx ) = @_; $self->{start} or return; wantarray and return @{ $self->{start} }; return $self->{start}[ $inx || 0 ]; } sub type { my ( $self, $inx ) = @_; $self->{type} or return; wantarray and return @{ $self->{type} }; return $self->{type}[ $inx || 0 ]; } sub variables { my ( $self ) = @_; $self->interpolates() or return; my %var; foreach my $kid ( $self->children() ) { $kid->can( 'variables' ) or next; foreach my $sym ( $kid->variables() ) { $var{$sym} = 1; } } return ( keys %var ); } sub _chop { my ( $middle ) = @_; my $left = substr $middle, 0, 1, ''; my $right = substr $middle, -1, 1, ''; return ( $left, $middle, $right ); } # decode data using the object's {encoding} # It is anticipated that if I make PPIx::Regexp depend on this package, # that this will be called there. sub __decode { my ( $self, $data, $encoding ) = @_; $encoding ||= $self->{encoding}; defined $encoding and _encode_available() or return $data; return Encode::decode( $encoding, $data ); } { my $encode_available; sub _encode_available { defined $encode_available and return $encode_available; return ( $encode_available = eval { require Encode; 1; } ? 1 : 0 ); } } { my ( $cached_doc, $cached_encoding ); # These are the byte order marks documented as being recognized by # PPI. Only utf-8 is documented as supported. my %known_bom = ( 'EFBBBF' => 'utf-8', '0000FEFF' => 'utf-32be', 'FFFE0000' => 'utf-32le', 'FEFF' => 'utf-16be', 'FFFE' => 'utf-16le', ); sub _get_ppi_encoding { my ( $elem ) = @_; my $doc = $elem->top() or return; $cached_doc and $doc == $cached_doc and return $cached_encoding; my $bom = $doc->first_element() or return; Scalar::Util::weaken( $cached_doc = $doc ); if ( $bom->isa( 'PPI::Token::BOM' ) ) { return ( $cached_encoding = $known_bom{ uc unpack 'H*', $bom->content() } ); } $cached_encoding = undef; foreach my $use ( @{ $doc->find( 'PPI::Statement::Include' ) || [] } ) { 'use' eq $use->type() or next; defined( my $module = $use->module() ) or next; 'utf8' eq $module or next; $cached_encoding = 'utf-8'; last; } return $cached_encoding; } } # This subroutine was created in an attempt to simplify control flow. # Argument 2 (from 0) is not unpacked because the caller needs to see # the side effects of matches made on it. { my %special = ( '$$' => sub { # Process ID. my ( $content ) = @_; return PPIx::QuoteLike::Token::Interpolation->__new( content => $content, ); }, '$' => sub { # Called if we find (e.g.) '$@' my ( $content ) = @_; $_[1] =~ m/ \G ( [\@] ) /smxgc or return; return PPIx::QuoteLike::Token::Interpolation->__new( content => "$content$1", ); }, '@' => sub { # Called if we find '@@'. my ( $content ) = @_; return PPIx::QuoteLike::Token::String->__new( content => $content, ); }, ); sub _interpolation { ## no critic (RequireArgUnpacking) my ( $self, $sigil ) = @_; if ( $_[2] =~ m/ \G (?= \{ ) /smxgc ) { my $delim_re = _match_enclosed( qw< { > ); $_[2] =~ m/ \G ( $delim_re ) /smxgc and return PPIx::QuoteLike::Token::Interpolation->__new( content => "$sigil$1", ); $_[2] =~ m/ \G ( .* ) /smxgc and return $self->_unknown( "$sigil$1", MISMATCHED_DELIM ); confess 'Failed to match /./'; } if ( $_[2] =~ m< \G ( @{[ VARIABLE_RE ]} ) >smxgco ) { my $interp = "$sigil$1"; my $deref = $self->postderef() ? qr{ -> \@ | (?: -> )? }smx : qr{ (?: -> )? }smx; while ( $_[2] =~ m/ \G ( $deref ) (?= ( [[{] ) ) /smxgc ) { # }] my $lead_in = $1; my $delim_re = _match_enclosed( $2 ); if ( $_[2] =~ m/ \G ( $delim_re ) /smxgc ) { $interp .= "$lead_in$1"; } else { $_[2] =~ m/ ( .* ) /smxgc; return ( PPIx::QuoteLike::Token::Interpolation->__new( content => $interp, ), $self->_unknown( "$1", MISMATCHED_DELIM ), ); } } # Postfix dereferencing $self->postderef() and $_[2] =~ m/ \G ( -> (?: \$ \# | [\$\@] ) [*] ) /smxgc and $interp .= $1; return PPIx::QuoteLike::Token::Interpolation->__new( content => $interp, ); } my $code; $code = $special{$sigil} and my $elem = $code->( $sigil, $_[2] ) or return $self->_unknown( $sigil, 'Sigil without interpolation' ); return $elem; } } sub _link_elems { my ( $self, @arg ) = @_; push @{ $self->{children} }, @arg; foreach my $key ( qw{ type start children finish } ) { my $prev; foreach my $elem ( @{ $self->{$key} } ) { Scalar::Util::weaken( $elem->{parent} = $self ); if ( $prev ) { Scalar::Util::weaken( $elem->{previous_sibling} = $prev ); Scalar::Util::weaken( $prev->{next_sibling} = $elem ); } $prev = $elem; } } return $self; } { our %REGEXP_CACHE; my %matching_bracket = qw/ ( ) [ ] { } < > /; sub _match_enclosed { my ( $left ) = @_; my $ql = quotemeta $left; $REGEXP_CACHE{$ql} and return $REGEXP_CACHE{$ql}; if ( my $right = $matching_bracket{$left} ) { =begin comment return ( $REGEXP_CACHE{$left} = qr/ ( \Q$left\E (?: (?> [^\\\Q$left$right\E]+ ) | (?> \$ [\Q$left$right\E] ) | (?> \\ . ) | (?-1) )* \Q$right\E ) /smx ); =end comment =cut # Based on Regexp::Common $RE{balanced} 2.113 (because I # can't use (?-1) my $ql = quotemeta $left; my $qr = quotemeta $right; my $pkg = __PACKAGE__; my $r = "(??{ \$${pkg}::REGEXP_CACHE{'$ql'} })"; my @parts = ( "(?>[^\\\\$ql$qr]+)", "(?>\\\$[$ql$qr])", '(?>\\\\.)', $r, ); { use re qw{ eval }; local $" = '|'; $REGEXP_CACHE{$ql} = qr/($ql(?:@parts)*$qr)/; } return $REGEXP_CACHE{$ql}; } else { # Based on Regexp::Common $RE{delimited}{-delim=>'`'} return ( $REGEXP_CACHE{$ql} ||= qr< (?: (?: \Q$left\E ) (?: [^\\\Q$left\E]* (?: \\ . [^\\\Q$left\E]* )* ) (?: \Q$left\E ) ) >smx ); } } sub _matching_delimiter { my ( $left ) = @_; my $right = $matching_bracket{$left} or return $left; return $right; } } sub _stringify_source { my ( $self, $string, %opt ) = @_; if ( Scalar::Util::blessed( $string ) ) { $string->isa( 'PPI::Element' ) or return; foreach my $class ( qw{ PPI::Token::Quote PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Readline } ) { $string->isa( $class ) or next; $opt{test} and return 1; my $encoding = _get_ppi_encoding( $string ); return $self->__decode( $string->content(), $encoding ); } if ( $string->isa( 'PPI::Token::HereDoc' ) ) { $opt{test} and return 1; my $encoding = _get_ppi_encoding( $string ); my $heredoc = join '', map { $self->__decode( $_, $encoding) } $string->heredoc(); my $terminator = $self->__decode( $string->terminator(), $encoding ); $terminator =~ s/ (?<= \n ) \z /\n/smx; return $self->__decode( $string->content(), $encoding ) . "\n" . $heredoc . $terminator; } return; } ref $string and return; $string =~ m/ \A \s* (?: q [qx]? | << | [`'"<] ) /smx and return $opt{test} ? 1 : $string; return; } sub _unknown { my ( $self, $content, $error ) = @_; $self->{failures}++; return PPIx::QuoteLike::Token::Unknown->__new( content => $content, error => $error, ); } sub _unquote { my ( $string ) = @_; $string =~ s/ \A ['"] //smx and chop $string; $string =~ s/ \\ (?= . ) //smxg; return $string; } 1; __END__ =head1 NAME PPIx::QuoteLike - Parse Perl string literals and string-literal-like things. =head1 SYNOPSIS use PPIx::QuoteLike; my $str = PPIx::QuoteLike->new( q<"fu$bar"> ); say $str->interpolates() ? 'interpolates' : 'does not interpolate'; =head1 DESCRIPTION This Perl class parses Perl string literals and things that are reasonably like string literals. Its real reason for being is to find interpolated variables for L policies and similar code. =head1 INHERITANCE C is not descended from any other class. C has no descendants. =head1 METHODS This class supports the following public methods: =head2 new my $str = PPIx::QuoteLike->new( $source, %arg ); This static method parses the argument, and returns a new object containing the parse. The C<$source> argument can be either a scalar or an appropriate L object. If the C<$source> argument is a scalar, it is presumed to represent a quote-like literal of some sort, provided it begins like one. Otherwise this method will return nothing. The scalar representation of a here document is a multi-line string whose first line consists of the leading C< << > and the start delimiter, and whose subsequent lines consist of the content of the here document and the end delimiter. C classes that can be handled are L, L, L, L, and L. Any other object will cause C to return nothing. Additional optional arguments can be passed as name/value pairs. Supported arguments are: =over =item encoding This is the encoding of the C<$source>. If this is specified as something other than C, the C<$source> will be decoded before processing. If the C<$source> is a C, this encoding is used only if the document that contains the element has neither a byte order mark nor C<'use utf8'>. =item postderef This Boolean argument determines whether postfix dereferencing is recognized in interpolation. If unspecified, or specified as C, it defaults to the value of C<$PPIx::QuoteLike::DEFAULT_POSTDEREF>. This variable is not exported, and is true by default. If you change the value, the change should be properly localized: local $PPIx::QuoteLike::DEFAULT_POSTDEREF = 0; =item trace This Boolean argument causes a trace of the parse to be written to standard out. Setting this to a true value is unsupported in the sense that the author makes no representation as to what will happen if you do it, and reserves the right to make changes to the functionality, or retract it completely, without notice. =back All other arguments are unsupported and reserved to the author. =head2 child my $kid = $str->child( 0 ); This method returns the child element whose index is given as the argument. Children do not include the L, or the L or L delimiters. Negative indices are valid, and given the usual Perl interpretation. =head2 children my @kids = $str->children(); This method returns all child elements. Children do not include the L, or the L or L delimiters. =head2 content say $str->content(); This method returns the content of the object. If the original argument was a valid Perl string, this should be the same as the originally-parsed string. =head2 delimiters say $str->delimiters(); This method returns the delimiters of the object, as a string. This will be two characters unless the argument to L was a here document, missing its end delimiter, or an invalid string. In the latter case the return might be anything. =head2 elements my @elem = $str->elements(); This method returns all elements of the object. This includes L, L, L, and L, in that order. =head2 failures say $str->failures(); This method returns the number of parse failures found. These are instances where the parser could not figure out what was going on, and should be the same as the number of L objects returned by L. =head2 find for ( @{[ $str->find( $criteria ) || [] } ) { ... } This method finds and returns a reference to an array of all elements that meet the given criteria. If nothing is found, a false value is returned. The C<$criteria> can be either the name of a L class, or a code reference. In the latter case, the code is called for each element in L, with the element as the only argument. The element is included in the output if the code returns a true value. =head2 finish say map { $_->content() } $str->finish(); This method returns the finishing elements of the parse. It is actually an array, with the first element being a L. If the parse is of a here document there will be a second element, which will be a L containing the trailing new line character. If called in list context you get the whole array. If called in scalar context you get the element whose index is given in the argument, or element zero if no argument is specified. =head2 handles say PPIx::QuoteLike->handles( $string ) ? "We can handle $string" : "We can not handle $string"; This convenience static method returns a true value if this package can be expected to handle the content of C<$string> (be it scalar or object), and a false value otherwise. =head2 interpolates say $str->interpolates() ? 'The string interpolates' : 'The string does not interpolate'; This method returns a true value if the parsed string interpolates, and a false value if it does not. This does B indicate whether any interpolation actually takes place, only whether the string is double-quotish or single-quotish. =head2 perl_version_introduced This method returns the maximum value of C returned by any of its elements. In other words, it returns the minimum version of Perl under which this quote-like object is valid. If there are no elements, 5.000 is returned, since that is the minimum value of Perl supported by this package. =head2 perl_version_removed This method returns the minimum defined value of C returned by any of the quote-like object's elements. In other words, it returns the lowest version of Perl in which this object is C valid. If there are no elements, or if no element has a defined C, C is returned. =head2 schild my $skid = $str->schild( 0 ); This method returns the significant child elements whose index is given by the argument. Negative indices are interpreted in the usual way. =head2 schildren my @skids = $str->schildren(); This method returns the significant children. =head2 source my $source = $str->source(); This method returns the C<$source> argument to L, whatever it was. =head2 start say map { $_->content() } $str->start(); This method returns the starting elements of the parse. It is actually an array, with the first element being a L. If the parse is of a here document there will be a second element, which will be a L containing the trailing new line character. If called in list context you get the whole array. If called in scalar context you get the element whose index is given in the argument, or element zero if no argument is specified. =head2 type my $type = $str->type(); This method returns the type object. This will be a L if the parse was successful; otherwise it might be C. Its contents will be everything up to the start delimiter, and will typically be C<'q'>, C<'qq'>, C<'qx'>, C< '<<' > (for here documents), or C<''> (for quoted strings). The type data are actually an array. If the second element is present it will be the white space (if any) separating the actual type from the value. If called in list context you get the whole array. If called in scalar context you get the element whose index is given in the argument, or element zero if no argument is specified. =head2 variables say "Interpolates $_" for $str->variables(); This convenience method returns all interpolated variables. Each is returned only once, and they are returned in no particular order. If the object does not represent a string that interpolates, nothing is returned. =head1 RESTRICTIONS By the nature of this module, it is never going to get everything right. Many of the known problem areas involve interpolations one way or another. =head2 Changes in Syntax Sometimes the introduction of new syntax changes the way a string is parsed. For example, the C<\F> (fold case) case control was introduced in Perl 5.15.8. But it did not represent a syntax error prior to that version of Perl, it was simply parsed as C. So $ perl -le 'print "Foo\FBar"' prints C<"FooFBar"> under Perl 5.14.4, but C<"Foobar"> under 5.16.0. C generally assumes the more modern parse in cases like this. =head2 Static Parsing It is well known that Perl can not be statically parsed. That is, you can not completely parse a piece of Perl code without executing that same code. Nevertheless, this class is trying to statically parse quote-like things. I do not have any examples of where the parse of a quote-like thing would change based on what is interpolated, but neither can I rule it out. I. =head2 Non-Standard Syntax There are modules out there that alter the syntax of Perl. If the syntax of a quote-like string is altered, this module has no way to understand that it has been altered, much less to adapt to the alteration. The following modules are known to cause problems: L, which renders Perl as XML. C, which causes Perl to interpret suffixed empty brackets as dereferencing the thing they suffix. This module by Ben Morrow (C) appears to have been retracted. L, which recognizes ANSI C trigraphs, allowing Perl to be written in the ISO 646 character set. L. Enough said. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/000077500000000000000000000000001357406156500214345ustar00rootroot00000000000000libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Constant.pm000066400000000000000000000071161357406156500235700ustar00rootroot00000000000000package PPIx::QuoteLike::Constant; use 5.006; use strict; use warnings; use Carp; use base qw{ Exporter }; our $VERSION = '0.008'; our @CARP_NOT = qw{ PPIx::QuoteLike PPIx::QuoteLike::Constant PPIx::QuoteLike::Dumper PPIx::QuoteLike::Token PPIx::QuoteLike::Token::Control PPIx::QuoteLike::Token::Delimiter PPIx::QuoteLike::Token::Interpolation PPIx::QuoteLike::Token::String PPIx::QuoteLike::Token::Structure PPIx::QuoteLike::Token::Unknown PPIx::QuoteLike::Token::Whitespace PPIx::QuoteLike::Utils }; our @EXPORT_OK = qw{ MINIMUM_PERL HAVE_PPIX_REGEXP SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS VARIABLE_RE @CARP_NOT }; # We can't depend on PPIx::Regexp without getting into a circular # dependency. I think. But we can sure use it if we can come by it. use constant HAVE_PPIX_REGEXP => do { local $@ = undef; eval { ## no critic (RequireCheckingReturnValueOfEval) require PPIx::Regexp; 1; }; }; use constant MINIMUM_PERL => '5.000'; use constant SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS => $] ge '5.008003'; # Match the name of a variable. The user of this needs to anchor it # right after the sigil. The line noise is [[:punct:]] as documented in # perlrecharclass, less anything that needs to be excluded (currently # only '@' and '*'). use constant VARIABLE_RE => qr/ [[:alpha:]_]\w* (?: :: [[:alpha:]_] \w* )* | \^ [A-Z_] | [0-9]+ | [-!"#\$%&'()+,.\/:;<=>?[\\\]^_`{|}~] /smx; 1; __END__ =head1 NAME PPIx::QuoteLike::Constant - Constants needed by PPIx-QuoteLike =head1 SYNOPSIS This package is private to the C distribution. =head1 DESCRIPTION This module is private to the C package. Documentation is for the benefit of the author, who reserves the right to change or revoke anything here, including the entire module, without notice. This module provides importable manifest constants used by multiple modules in the C package. Nothing is exported by default. =head1 CONSTANTS The following importable constants are provided: =head2 @CARP_NOT This global variable contains the names of all modules in the package. It's not a constant in the sense of C, but needs to live here for heredity reasons. =head2 MINIMUM_PERL The minimum version of Perl understood by this parser, as a string. It is currently set to C<'5.000'>, since that is the minimum version of Perl accessible to the author. =head2 SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS A Boolean which is true if the running version of Perl has UTF-8 support sufficient for our purposes. Currently that means C<5.8.3> or greater, with the specific requirements being C, C, and the ability to parse things like C. =head2 VARIABLE_RE This constant is a regular expression object that matches Perl variable names, without the leading sigil. Nothing is captured. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Dumper.pm000066400000000000000000000265441357406156500232410ustar00rootroot00000000000000package PPIx::QuoteLike::Dumper; use 5.006; use strict; use warnings; use Carp; use PPI::Document; use PPI::Dumper; use PPIx::QuoteLike; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; use Scalar::Util (); our $VERSION = '0.008'; use constant SCALAR_REF => ref \0; { my $default = { encoding => undef, file => undef, indent => 2, margin => 0, perl_version => 0, ppi => 0, significant => 0, tokens => 0, variables => 0, }; sub new { my ( $class, $source, %arg ) = @_; my $self = { %{ $default }, object => undef, source => $source, }; foreach my $key ( keys %{ $default } ) { defined $arg{$key} and $self->{$key} = $arg{$key}; } $self->{object} = _isa( $source, 'PPIx::QuoteLike' ) ? $source : PPIx::QuoteLike->new( $source, map { $_ => $arg{$_} } qw{ encoding postderef }, ) or return; return bless $self, ref $class || $class; } } sub dump : method { ## no critic (ProhibitBuiltinHomonyms) my ( $class, $source, %arg ) = @_; my $rslt; my $margin = ' ' x ( $arg{margin} || 0 ); my $none = delete $arg{none}; foreach my $obj ( $class->_source_to_dumpers( $source, %arg ) ) { my $src = $obj->{object}->source(); $rslt .= "\n$margin$src"; if ( _isa( $src, 'PPI::Element' ) and my $loc = $src->location() ) { $rslt .= sprintf ' %s line %d column %d', _dor( $loc->[4], $obj->{file}, '?' ), $loc->[0], $loc->[1]; } $rslt .= "\n" . $obj->string(); } defined $rslt and return $rslt; defined $none or return; $none =~ s/ (?: \A | (?{object}; my @rslt; my $selector; if ( $self->{tokens} ) { $indent = ''; $selector = sub { return @{ $obj->find( 'PPIx::QuoteLike::Token' ) || [] }; }; } else { $indent = ' ' x $self->{indent}; my $string = sprintf '%s%s...%s', map { _format_content( $obj, $_ ) } qw{ type start finish }; push @rslt, join "\t", ref $obj, $string, _format_attr( $obj, qw{ encoding failures interpolates } ), $self->_perl_version( $obj ), $self->_variables( $obj ), ; $selector = sub { return $obj->children() }; } foreach my $elem ( $selector->() ) { $self->{significant} and not $elem->significant() and next; my @line = ( ref $elem, _quote( $elem->content() ), $self->_perl_version( $elem ), $self->_variables( $elem ), ); my @ppi; @ppi = $self->_ppi( $elem, $split ) and push @line, shift @ppi; push @rslt, map { "$indent$_" } join( "\t", @line ), @ppi; } return @rslt; } sub print : method { ## no critic (ProhibitBuiltinHomonyms) my ( $self ) = @_; print $self->string(); return; } sub string { my ( $self ) = @_; my $margin = ' ' x $self->{margin}; return join '', map { "$margin$_\n" } $self->list( 1 ); } { # We have to hold a reference to the PPI document until we're done # with all its elements, otherwise they evaporate. Holding it here # works as long as we actually format the dump for all elements # before calling this again. my $doc; sub _doc_to_dumper { my ( $class, $path, %arg ) = @_; $doc = PPI::Document->new( $path ) or return; ref $path or $arg{file} = $path; $doc->index_locations(); return map { $class->new( $_, %arg ) } @{ $doc->find( 'PPI::Token' ) || [] }; } } sub _dor { my @arg = @_; foreach my $a ( @arg ) { defined $a and return $a; } return; } sub _format_attr { my ( $obj, @arg ) = @_; my @rslt; foreach my $attr ( @arg ) { defined( my $val = $obj->$attr() ) or next; push @rslt, sprintf '%s=%s', $attr, _quote( $val ); } return @rslt; } sub _format_content { my ( $obj, $method, @arg ) = @_; my $val = $obj->$method( @arg ); ref $val and $val = $val->content(); return defined $val ? $val : '?'; } sub _isa { my ( $arg, $class ) = @_; Scalar::Util::blessed( $arg ) or return 0; return $arg->isa( $class ); } sub _perl_version { my ( $self, $elem ) = @_; $self->{perl_version} or return; my $intro = $elem->perl_version_introduced(); my $remov = $elem->perl_version_removed(); return defined $remov ? "$intro <= \$] < $remov" : "$intro <= \$]"; } sub _ppi { my ( $self, $elem, $split ) = @_; $self->{ppi} and $elem->can( 'ppi' ) or return; my $dumper = PPI::Dumper->new( $elem->ppi(), map { $_ => $self->{$_} } qw{ indent }, ); my $str = $dumper->string(); chomp $str; $split and return split qr{ \n }smx, $str; return $str; } sub _quote { my ( $val ) = @_; ref $val and $val = $val->content(); defined $val or return 'undef'; Scalar::Util::looks_like_number( $val ) and return $val; if ( $val =~ m/ \A << /smx ) { chomp $val; return "<<'__END_OF_HERE_DOCUMENT' $val __END_OF_HERE_DOCUMENT "; } =begin comment $val =~ m/ [{}] /smx or return "q{$val}"; $val =~ m{ / }smx or return "q/$val/"; =end comment =cut $val =~ s/ (?= [\\'] )/\\/smxg; return "'$val'"; } sub _source_to_dumpers { my ( $class, $path, %arg ) = @_; if ( Scalar::Util::blessed( $path ) ) { if ( _isa( $path, 'PPI::Node' ) ) { return map { PPIx::QuoteLike->handles( $_ ) ? $class->new( $_, %arg ) : () } @{ $path->find( 'PPI::Token' ) || [] }; } elsif ( _isa( $path, 'PPI::Element' ) ) { PPIx::QuoteLike->handles( $path ) and return $class->new( $path, %arg ); } } elsif ( my $ref = ref $path ) { SCALAR_REF eq $ref or return; return $class->_doc_to_dumper( $path, %arg ); } else { -f $path or return $class->new( $path, %arg ); -T _ or return; unless ( $path =~ m/ [.] (?: (?i: pl ) | pm | t ) \z /smx ) { open my $fh, '<', $path or return; defined( local $_ = <$fh> ) or return; close $fh; m/ perl /smx or return; } return $class->_doc_to_dumper( $path, %arg ); } return; } sub _variables { my ( $self, $elem ) = @_; $self->{variables} and $elem->can( 'variables' ) or return; return join ',', sort $elem->variables(); } 1; __END__ =head1 NAME PPIx::QuoteLike::Dumper - Dump the results of parsing quotelike things =head1 SYNOPSIS use PPIx::QuoteLike::Dumper; PPIx::QuoteLike::Dumper->new( '"foo$bar baz"' ) ->print(); =head1 DESCRIPTION This class generates a formatted dump of a L object, or a string that can be made into such an object. =head1 METHODS This class supports the following public methods. Methods not documented here are private, and unsupported in the sense that the author reserves the right to change or remove them without notice. =head2 new my $dumper = PPIx::QuoteLike::Dumper->new( '"foo$bar baz"', variables => 1, ); This static method instantiates the dumper. It takes the string or L object to be dumped as the first argument. Optional further arguments may be passed as name/value pairs. The following optional arguments are recognized: =over =item encoding name This argument is the encoding of the object to be dumped. It is passed through to L L unless the first argument was a L object, in which case it is ignored. =item indent number This argument specifies the number of additional spaces to indent each level of the parse hierarchy. This is ignored if the C argument is true. The default is C<2>. =item margin number This argument is the number of additional spaces to indent the parse hierarchy, over those specified by the margin. The default is C<0>. =item perl_version Boolean This argument specifies whether or not the perl versions introduced and removed are included in the dump. The default is C<0> (i.e. false). =item postderef Boolean This argument specifies whether or not postfix dereferences are recognized in interpolations. It is passed through to L L unless the first argument was a L object, in which case it is ignored. =item ppi Boolean This argument specifies whether or not a PPI dump is provided for interpolations. The default is C<0> (i.e. false). =item tokens boolean If true, this argument causes an unstructured dump of tokens found in the parse. The default is C<0> (i.e. false). =item variables Boolean If true, this argument causes all variables actually interpolated by any interpolations to be dumped. The default is C<0> (i.e. false). =back =head2 dump print PPIx::Regexp::Dumper->dump( 'foo/bar.pl', variables => 1, ); This static method returns a string that represents a dump of its first argument. It takes the same optional arguments as L. This method differs from L in its interpretation of the first argument. =over =item * If the first argument is the name of a file, or is a SCALAR reference, it is made into a L and all strings in the document are dumped. =item * If the first argument is a L all strings in the node are dumped. Note that a L is a L. =back Otherwise the first argument is handled just like L would handle it. The return is the string representation of the dump. In addition to the optional arguments accepted by L, the following can be specified: =over =item none This argument specifies a string to return if no dump can be produced (typically because the first argument is neither a file name nor text that is recognized by this package). If unspecified, or specified as C, nothing is returned in this case. =back The output for an individual quote-like object differs from the L output on the same object in that it is preceded by the literal sting being dumped, and file and location information if that can be determined. =head2 list print map { "$_\n" } $dumper->list(); This method returns an array containing the dump output. one line per element. The output has no left margin applied, and no trailing newlines. Embedded newlines are probable if the C argument was specified when the dumper was instantiated. =head2 print $dumper->print(); This method simply prints the result of L to standard out. =cut sub print : method { ## no critic (ProhibitBuiltinHomonyms) my ( $self ) = @_; print $self->string(); return; } =head2 string print $dumper->string(); This method adds left margin and newlines to the output of L, concatenates the result into a single string, and returns that string. =cut =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token.pm000066400000000000000000000125251357406156500230570ustar00rootroot00000000000000package PPIx::QuoteLike::Token; use 5.006; use strict; use warnings; use Carp; use PPIx::QuoteLike::Constant qw{ MINIMUM_PERL @CARP_NOT }; our $VERSION = '0.008'; # Private to this package. sub __new { my ( $self, %arg ) = @_; defined $arg{content} or croak 'Content required'; return bless \%arg, ref $self || $self; } sub content { my ( $self ) = @_; return $self->{content}; } sub error { my ( $self ) = @_; return $self->{error}; } sub parent { my ( $self ) = @_; return $self->{parent}; } sub next_sibling { my ( $self ) = @_; $self->{next_sibling} or return; return $self->{next_sibling}; } sub perl_version_introduced { my ( $self ) = @_; # TODO use '//' when we can require Perl 5.10. defined $self->{perl_version_introduced} and return $self->{perl_version_introduced}; my $vers = $self->__perl_version_introduced(); defined $vers or $vers = MINIMUM_PERL; return ( $self->{perl_version_introduced} = $vers ); } sub __perl_version_introduced { return; } sub perl_version_removed { return undef; ## no critic (ProhibitExplicitReturnUndef) } sub previous_sibling { my ( $self ) = @_; $self->{previous_sibling} or return; return $self->{previous_sibling}; } sub significant { return 1; } sub snext_sibling { my ( $sib ) = @_; while ( $sib = $sib->next_sibling() ) { $sib->significant() and return $sib; } return; } sub sprevious_sibling { my ( $sib ) = @_; while ( $sib = $sib->previous_sibling() ) { $sib->significant() and return $sib; } return; } 1; __END__ =head1 NAME PPIx::QuoteLike::Token - Represent any token. =head1 SYNOPSIS This is an abstract class, and should not be instantiated by the user. =head1 DESCRIPTION This Perl module represents the base of the token hierarchy. =head1 INHERITANCE C is not descended from any other class. C is the parent of L, L, L, L, L and L. =head1 METHODS This class supports the following public methods: =head2 content say $token->content(); This method returns the text that makes up the token. =head2 error say $token->error(); This method returns the error text. This will be C unless the token actually represents an error. =head2 parent my $parent = $token->parent(); This method returns the token's parent, which will be the L object that contains it. =head2 next_sibling my $next = $token->next_sibling(); This method returns the token after the invocant, or nothing if there is none. =head2 perl_version_introduced This method returns the version of Perl in which the element was introduced. This will be at least 5.000. Before 5.006 I am relying on the F, F, and F documentation, since I have been unable to build earlier Perls. Since I have found no documentation before 5.003, I assume that anything found in 5.003 is also in 5.000. Since this all depends on my ability to read and understand masses of documentation, the results of this method should be viewed with caution, if not downright skepticism. There are also cases which are ambiguous in various ways. For those see L, and especially L. =head2 perl_version_removed This method returns the version of Perl in which the element was removed. If the element is still valid the return is C. All the I to L apply here also, though perhaps less severely since although many features have been introduced since 5.0, few have been removed. =head2 previous_sibling my $prev = $token->previous_sibling(); This method returns the token before the invocant, or nothing if there is none. =head2 significant $token->significant() and say 'significant'; This Boolean method returns a true value if the token is significant, and a false one otherwise. =head2 snext_sibling my $next = $token->snext_sibling(); This method returns the significant token after the invocant, or nothing if there is none. =head2 sprevious_sibling my $prev = $token->sprevious_sibling(); This method returns the significant token before the invocant, or nothing if there is none. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/000077500000000000000000000000001357406156500225145ustar00rootroot00000000000000libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/Control.pm000066400000000000000000000034321357406156500244740ustar00rootroot00000000000000package PPIx::QuoteLike::Token::Control; use 5.006; use strict; use warnings; use base qw{ PPIx::QuoteLike::Token }; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; our $VERSION = '0.008'; { # TODO make this a state variable when we can require Perl 5.10. my $introduced = { '\\F' => '5.015008', }; sub __perl_version_introduced { my ( $self ) = @_; return $introduced->{ $self->content() }; } } 1; __END__ =head1 NAME PPIx::QuoteLike::Token::Control - Represent case and quote control =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C has no descendants. =head1 DESCRIPTION This Perl class represents one of the case-control or quote-control sequences in a quote-like string, That is, things like C<\Q>, C<\E>, C<\U>, C<\u>, C<\L>, C<\l>, and C<\F>. =head1 METHODS This class supports no public methods in addition to those of its superclass. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/Delimiter.pm000066400000000000000000000065351357406156500250010ustar00rootroot00000000000000package PPIx::QuoteLike::Token::Delimiter; use 5.006; use strict; use warnings; use base qw{ PPIx::QuoteLike::Token::Structure }; use PPIx::QuoteLike::Constant qw{ MINIMUM_PERL @CARP_NOT }; our $VERSION = '0.008'; # Perl 5.29.0 disallows unassigned code points and combining code points # as delimiters. Unfortunately for me non-characters and illegal # characters are explicitly allowed. Still more unfortunately, these # match /\p{Unassigned}/. So before I match a deprecated characer, I # have to assert that the character is neither a non-character # (\p{Noncharacter_code_point}) nor an illegal Unicode character # (\P{Any}). use constant WEIRD_CHAR_RE => eval ## no critic (ProhibitStringyEval,RequireCheckingReturnValueOfEval) 'qr< (?! [\p{Noncharacter_code_point}\P{Any}] ) [\p{Unassigned}\p{Mark}] >smx'; =head2 perl_version_introduced Experimentation with weird delimiters shows that they did not actually work until Perl 5.8.3, so we return C<'5.008003'> for such delimiters. =cut sub perl_version_introduced { my ( $self ) = @_; $self->content() =~ m/ \A [[:^ascii:]] \z /smx and return '5.008003'; return MINIMUM_PERL; } =head2 perl_version_removed Perl 5.29.0 made fatal the use of non-standalone graphemes as string delimiters. Because non-characters and permanently unassigned code points are still allowed per F, I take this to mean characters that match C (i.e. combining diacritical marks). But this regular expression does not compile under Perl 5.6. So: This method returns C<'5.029'> for such delimiters B the requisite regular expression compiles. Otherwise it return C. =cut sub perl_version_removed { my ( $self ) = @_; WEIRD_CHAR_RE and $self->content() =~ WEIRD_CHAR_RE and return '5.029'; # I respectfully disagree with Perl Best Practices on the # following. When this method is called in list context it MUST # return undef if that's the right answer, NOT an empty list. # Otherwise hash constructors have the wrong number of elements. return undef; ## no critic (ProhibitExplicitReturnUndef) } 1; __END__ =head1 NAME PPIx::QuoteLike::Token::Delimiter - Represent a string delimiter =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C has no descendants. =head1 DESCRIPTION This token represents the delimiters of the string. =head1 METHODS This class supports no public methods in addition to those of its superclass. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/Interpolation.pm000066400000000000000000000062431357406156500257060ustar00rootroot00000000000000package PPIx::QuoteLike::Token::Interpolation; use 5.006; use strict; use warnings; use Carp; use PPI::Document; use PPIx::QuoteLike::Constant qw{ VARIABLE_RE @CARP_NOT }; use PPIx::QuoteLike::Utils qw{ __variables }; use base qw{ PPIx::QuoteLike::Token }; our $VERSION = '0.008'; sub ppi { my ( $self ) = @_; unless ( $self->{ppi} ) { ## The following code is tempting, but I really, really want to ## avoid enabling it, because I may hit uses of ${something} that ## it does not cover. ## ( my $content = $self->content() ) =~ ## s/ \A ( [\$\@] (?: \# \$? | \$* ) ) ## \{ ( @{[ VARIABLE_RE ]} ) \} \z /$1$2/smxo; my $content = $self->content(); $self->{ppi} = PPI::Document->new( \$content, readonly => 1 ); } return $self->{ppi}; } sub variables { my ( $self ) = @_; return __variables( $self->ppi() ); } sub __perl_version_introduced { my ( $self ) = @_; $self->content() =~ m/ -> (?: \@ [[{*] | % [*] ) /smx and return '5.019005'; return; } 1; __END__ =head1 NAME PPIx::QuoteLike::Token::Interpolation - Represent an interpolation =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C has no descendants. =head1 DESCRIPTION This Perl class represents an interpolation into a quote-like string. =head1 METHODS This class supports the following public methods in addition to those of its superclass: =head2 ppi my $ppi = $elem->ppi(); This convenience method returns the L representing the content. This document should be considered read only. An exception will be thrown if L can not be loaded. Note that the content of the returned L may not be the same as the content of the original C. This can happen because interpolated variable names may be enclosed in curly brackets, but this does not happen in normal code. For example, in C, the content of the C object will be C<'${foo}'>, but the content of the C will be C<'$foo'>. =head2 variables say "Interpolates $_" for $elem->variables(); This convenience method returns all interpolated variables. Each is returned only once, and they are returned in no particular order. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/String.pm000066400000000000000000000027001357406156500243170ustar00rootroot00000000000000package PPIx::QuoteLike::Token::String; use 5.006; use strict; use warnings; use base qw{ PPIx::QuoteLike::Token }; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; our $VERSION = '0.008'; 1; __END__ =head1 NAME PPIx::QuoteLike::Token::String - Represent an uninterpolated string =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C has no descendants. =head1 DESCRIPTION This Perl class represents a literal, uninterpolated string. =head1 METHODS This class supports no public methods in addition to those of its superclass. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/Structure.pm000066400000000000000000000033231357406156500250530ustar00rootroot00000000000000package PPIx::QuoteLike::Token::Structure; use 5.006; use strict; use warnings; use base qw{ PPIx::QuoteLike::Token }; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; our $VERSION = '0.008'; 1; __END__ =head1 NAME PPIx::QuoteLike::Token::Structure - Represent the structure of the string. =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C is the parent of L. =head1 DESCRIPTION This Perl class represents the initial token in the string; that is, the C<'q'>, C<'qq'>, C<'qx'>, or (for here documents) C< '<<' >, together with any trailing space. For strings that have no initial token (that is, those simply enclosed in quotes) this will be the empty string. =head1 METHODS This class supports the following public methods: =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/Unknown.pm000066400000000000000000000027741357406156500245230ustar00rootroot00000000000000package PPIx::QuoteLike::Token::Unknown; use 5.006; use strict; use warnings; use base qw{ PPIx::QuoteLike::Token }; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; our $VERSION = '0.008'; 1; __END__ =head1 NAME PPIx::QuoteLike::Token::Unknown - An unknown token =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C has no descendants. =head1 DESCRIPTION Perl class represents something that could not be identified by the parser. It should not appear in an object that represents valid Perl. =head1 METHODS This class supports no public methods in addition to those of its superclass. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Token/Whitespace.pm000066400000000000000000000031331357406156500251460ustar00rootroot00000000000000package PPIx::QuoteLike::Token::Whitespace; use 5.006; use strict; use warnings; use base qw{ PPIx::QuoteLike::Token }; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; our $VERSION = '0.008'; sub significant { return 0; } 1; __END__ =head1 NAME PPIx::QuoteLike::Token::Whitespace - Represent insignificant white space. =head1 SYNOPSIS This class should not be instantiated by the user. See below for public methods. =head1 INHERITANCE C is a L. C has no descendants. =head1 DESCRIPTION This Perl class represents insignificant white space. =head1 METHODS This class supports no public methods in addition to those of its superclass. However, the following methods have been overridden: =head2 significant This method returns a false value. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/lib/PPIx/QuoteLike/Utils.pm000066400000000000000000000271651357406156500231050ustar00rootroot00000000000000package PPIx::QuoteLike::Utils; use 5.006; use strict; use warnings; use base qw{ Exporter }; use Carp; use PPIx::QuoteLike::Constant qw{ HAVE_PPIX_REGEXP VARIABLE_RE @CARP_NOT }; use Scalar::Util (); use constant LEFT_CURLY => q<{>; use constant RIGHT_CURLY => q<}>; our @EXPORT_OK = qw{ __variables }; our $VERSION = '0.008'; require PPIx::QuoteLike; { # TODO make these state varables once we can require Perl 5.10. my $postderef = { map { $_ => 1 } qw{ @* %* } }; my $cast_allowed_for_bare_bracketed_variable = { map { $_ => 1 } qw{ @ $ % } }; sub __variables { my ( $ppi ) = @_; Scalar::Util::blessed( $ppi ) or croak 'Argument must be an object'; # TODO the following two lines are a crock, but there does not # seem to be a good alternative. Bad alternatives: # * Introduce PPIx::QuoteLike::Element. But it seems stupid to # introduce a class simply to mark these as members of the # PPIx::QuoteLike family. # If I go this way at all, PPIx::QuoteLike::Element should be # analogous to PPIx::Regexp::Element in that it carries at # least the navigational and Perl version methods. # * Use DOES(). But that was not introduced until 5.10. So I # could: # - Depend on UNIVERSAL::DOES. This kindly steps aside if # UNIVERSAL::DOES() exists, but it seems stupid to introduce # a dependency that is only needed under really old Perls. # - Same as above, only make the dependence conditional on the # version of Perl. This may actually be the best # alternative, but it's still pretty crufty. $ppi->isa( 'PPIx::QuoteLike' ) and return $ppi->variables(); $ppi->isa( 'PPIx::QuoteLike::Token' ) and return $ppi->variables(); my %var; $ppi->isa( 'PPIx::Regexp::Element' ) and do { foreach my $code ( @{ $ppi->find( 'PPIx::Regexp::Token::Code' ) || [] } ) { foreach my $name ( __variables( $code->ppi() ) ) { $var{ $name } = 1; } } return keys %var; }; $ppi->isa( 'PPI::Element' ) or croak 'Argument must be a PPI::Element, ', 'PPIx::Regexp::Element, PPIx::QuoteLike, or ', 'PPIx::QuoteLike::Token'; foreach my $sym ( _find( $ppi, 'PPI::Token::Symbol' ) ) { # The problem we're solving here is that PPI parses postfix # dereference as though it makes reference to non-existent # punctuation variables '@*' or '%*'. The following # statement omits these from output if they are preceded by # the '->' operator. my $prev; $postderef->{ $sym->content() } and $prev = $sym->sprevious_sibling() and $prev->isa( 'PPI::Token::Operator' ) and '->' eq $prev->content() and next; # Eliminate rogue subscripts _is_bareword_subscript( $sym ) and next; if ( defined( my $name = _name_from_misparsed_magic( $sym ) ) ) { # We're $${name}, which is a dereference of $name $var{$name} = 1; } else { # PPI got it right. $var{ $sym->symbol() } = 1; } } # For some reason, PPI parses '$#foo' as a # PPI::Token::ArrayIndex. $#$foo is parsed as a Cast followed # by a Symbol, so as long as nobody decides the '$#' cast causes # $elem->symbol() to return something other than '$foo', we're # cool. foreach my $elem ( _find( $ppi, 'PPI::Token::ArrayIndex' ) ) { my $name = $elem->content(); $name =~ s/ \A \$ [#] /@/smx or next; $var{$name} = 1; } # Occasionally you see something like ${foo} outside quotes. # This is legitimate, though PPI parses it as a cast followed by # a block. On the assumption that there are fewer blocks than # words in most Perl, we start at the top and work down. Perl # also handles punctuation variables specified this way, but # since PPI goes berserk when it sees this, we won't bother. foreach my $elem ( _find( $ppi, 'PPI::Structure::Block' ) ) { my $previous = $elem->sprevious_sibling() or next; $previous->isa( 'PPI::Token::Cast' ) or next; my $sigil = $previous->content(); $cast_allowed_for_bare_bracketed_variable->{ $sigil } or next; if ( my @kids = $elem->schildren() ) { # The simple case: we parsed a block whose contents, # however they were parsed, are the contents of the # token. 1 == @kids or next; $kids[0]->isa( 'PPI::Statement' ) or next; ( my $name = join '', map { $_->content() } $kids[0]->children() ) =~ m/ \A @{[ VARIABLE_RE ]} \z /smxo or next; $var{ "$sigil$name" } = 1; } else { # The downright ugly case. We have something like ${]} # where PPI can't find the terminator. To solve this we # need to go blundering through the parse until we find # the closing terminator. my $stmt = $elem->statement() or next; if ( my $finish = $elem->finish() ) { # If we appear to have a terminated block, we may # {{ # have ${}}, which is the same as $} my $next = $stmt->next_sibling() or next; $next->isa( 'PPI::Statement::UnmatchedBrace' ) and RIGHT_CURLY eq $next->content() or next; $var{ $sigil . $finish->content() } = 1; } else { # Otherwise we have something like # [ # ${]} my $next = $stmt->next_sibling() or next; my $finish = $next->next_sibling() or next; $finish->isa( 'PPI::Statement::UnmatchedBrace' ) and RIGHT_CURLY eq $finish->content() or next; $var{ $sigil . $next->content() } = 1; } } } # Yes, we might have nested string literals, like # "... @{[ qq<$foo> ]} ..." foreach my $class ( qw{ PPI::Token::Quote PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Readline PPI::Token::HereDoc } ) { foreach my $elem ( _find( $ppi, $class ) ) { my $ql = PPIx::QuoteLike->new( $elem ) or next; $ql->interpolates() or next; foreach my $sym ( $ql->variables() ) { $var{ $sym } = 1; } } } # By the same token we might have a regexp # TODO for consistency's sake, give PPIx::Regexp a variables() # method. if ( HAVE_PPIX_REGEXP ) { foreach my $class ( qw{ PPI::Token::QuoteLike::Regexp PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute } ) { foreach my $elem ( _find( $ppi, $class ) ) { my $re = PPIx::Regexp->new( $elem ) or next; foreach my $code ( @{ $re->find( 'PPIx::Regexp::Token::Code' ) || [] } ) { foreach my $name ( __variables( $code->ppi() ) ) { $var{ $name } = 1; } } } } } return ( keys %var ); } } # We want __variables to work when passed a single token. So we go # through this to do what we wish PPI did -- return an array for a # PPI::Node, or return either the element itself or nothing otherwise. sub _find { my ( $elem, $class ) = @_; $elem->isa( 'PPI::Node' ) and return @{ $elem->find( $class ) || [] }; $elem->isa( $class ) and return $elem; return; } # The problem this solves is that PPI can parse '{_}' as containing a # PPI::Token::Magic (which is a PPI::Token::Symbol), not a # PPI::Token::Word. This code also returns true for '${_}', which is not # a subscript but has the same basic problem. The latter gets caught # later. sub _is_bareword_subscript { my ( $elem ) = @_; $elem->content() =~ m/ \A \w+ \z /smx or return; my $parent; $parent = $elem->parent() and $parent->isa( 'PPI::Statement' ) and 1 == $parent->children() or return; $parent = $parent->parent() and ( $parent->isa( 'PPI::Structure::Subscript' ) or $parent->isa( 'PPI::Structure::Block' ) ) and 1 == $parent->children() or return; my $start; $start = $parent->start() and $start->isa( 'PPI::Token::Structure' ) and q<{> eq $start->content() or return; return 1; } # This handles two known cases where PPI misparses bracketed variable # names. # * $${foo} is parsed as '$$' when it is really a dereference of $foo. # The argument is the '$$' # * ${$} is parsed as an unterminated block followed by '$}'. The # argument is the '$}'. { my $special = { '$$' => sub { # $${foo},$${$_[0]} my ( $elem ) = @_; my $next; $next = $elem->snext_sibling() and $next->isa( 'PPI::Structure::Subscript' ) or return; my $start; $start = $next->start() and LEFT_CURLY eq $start->content() or return; my @kids = $next->schildren(); 1 == @kids and $kids[0]->isa( 'PPI::Statement' ) and @kids = $kids[0]->schildren(); if ( 1 == @kids ) { # The $${foo} case return join '', '$', map { $_->content() } @kids; } else { # The $${$_[0]} case. In this case the curly brackets # are really a block, as # $ perl -MO=Deparse -e '$${$_[0]}' makes clear. So we # just return the '$$', since the '$_' will turn up in # the course of things. return $elem->content(); } }, # { '$}' => sub { # ${$} my ( $elem ) = @_; my $stmt; $stmt = $elem->parent() and $stmt->isa( 'PPI::Statement' ) or return; my $block; $block = $stmt->parent() and $block->isa( 'PPI::Structure::Block' ) and not $block->finish() or return; my $sigil; $sigil = $block->sprevious_sibling() and $sigil->isa( 'PPI::Token::Cast' ) or return; my $name = join '', map { $_->content() } $sigil, $stmt->children(); chop $name; return $name; }, }; sub _name_from_misparsed_magic { my ( $elem ) = @_; $elem->isa( 'PPI::Token::Magic' ) or return; my $code = $special->{ $elem->content() } or return; return $code->( $elem ); } } 1; __END__ =head1 NAME PPIx::QuoteLike::Utils - Utility subroutines for PPIx::QuoteLike; =head1 SYNOPSIS use PPIx::QuoteLike::Utils qw{ __variables }; say for __variables( PPI::Document->new( \'$foo' ); =head1 DESCRIPTION This Perl module holds code for L that did not seem to fit anywhere else. =head1 SUBROUTINES This module supports the following public subroutines: =head2 __variables say for __variables( PPI::Document->new( \'$foo' ); Despite the leading underscores, this exportable subroutine is public and supported. The underscores are so it will not appear to be public code to various tools when imported into other code. This subroutine takes as its only argument a L, and returns the names of all variables found in that element, in no particular order. Scope is not taken into account. In addition to reporting variables parsed as such by L, and various corner cases such as C<${]}> where PPI is blind to the use of the variable, this subroutine looks inside the following PPI classes: PPI::Token::Quote PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Readline PPI::Token::HereDoc If L is installed, it will also look inside PPI::Token::QuoteLike::Regexp PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute Unfortunately I can not make C a requirement for this module, because of the possibility of a circular dependency. =head1 SUPPORT Support is by the author. Please file bug reports at L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2019 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. 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. =cut # ex: set textwidth=72 : libppix-quotelike-perl-0.008/t/000077500000000000000000000000001357406156500164075ustar00rootroot00000000000000libppix-quotelike-perl-0.008/t/basic.t000066400000000000000000000020151357406156500176530ustar00rootroot00000000000000package main; use strict; use warnings; use Test::More 0.88; require_ok 'PPIx::QuoteLike::Constant' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Utils' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::Control' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::Delimiter' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::Interpolation' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::String' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::Structure' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::Unknown' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Token::Whitespace' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike' or BAIL_OUT $@; my $ms = eval { PPIx::QuoteLike->new( q<''> ) }; isa_ok $ms, 'PPIx::QuoteLike' or BAIL_OUT $@; require_ok 'PPIx::QuoteLike::Dumper'; my $dmp = eval { PPIx::QuoteLike::Dumper->new( q<''> ) }; isa_ok $dmp, 'PPIx::QuoteLike::Dumper' or BAIL_OUT $@; done_testing; 1; libppix-quotelike-perl-0.008/t/dump.t000066400000000000000000000046221357406156500175450ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); use PPIx::QuoteLike::Dumper; is _dump( '"foo$bar"' ), <<'EOD', 'Dump "foo$bar"'; "foo$bar" PPIx::QuoteLike "..." failures=0 interpolates=1 PPIx::QuoteLike::Token::String 'foo' PPIx::QuoteLike::Token::Interpolation '$bar' EOD is _dump( \<<'EOF', perl_version => 1, variables => 1 ), use strict; use warnings; my $bar = 'buzz'; my $baz = "Burfle"; my $name = q ; my $speed = qq{light}; print "foo$bar->@*\F$baz\E\n"; print < ? line 6 column 12 PPIx::QuoteLike q<...> failures=0 interpolates=0 5.000 <= $] PPIx::QuoteLike::Token::String 'Bright' 5.000 <= $] qq{light} ? line 7 column 13 PPIx::QuoteLike qq{...} failures=0 interpolates=1 5.000 <= $] PPIx::QuoteLike::Token::String 'light' 5.000 <= $] "foo$bar->@*\F$baz\E\n" ? line 9 column 7 PPIx::QuoteLike "..." failures=0 interpolates=1 5.019005 <= $] $bar,$baz PPIx::QuoteLike::Token::String 'foo' 5.000 <= $] PPIx::QuoteLike::Token::Interpolation '$bar->@*' 5.019005 <= $] $bar PPIx::QuoteLike::Token::Control '\\F' 5.015008 <= $] PPIx::QuoteLike::Token::Interpolation '$baz' 5.000 <= $] $baz PPIx::QuoteLike::Token::Control '\\E' 5.000 <= $] PPIx::QuoteLike::Token::String '\\n' 5.000 <= $] <dump( @arg ); } 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/t/parse.t000066400000000000000000001476241357406156500177240ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use PPIx::QuoteLike; use PPIx::QuoteLike::Constant qw{ SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS }; BEGIN { if ( SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS ) { # Have to prevent Perl from parsing 'open' as 'CORE::open'. require 'open.pm'; 'open'->import( qw{ :std :encoding(utf-8) } ); } } use Test::More 0.88; # Because of done_testing(); use charnames qw{ :full }; my $obj; $obj = PPIx::QuoteLike->new( q{''} ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 0, q; is $obj->content(), q{''}, q; is $obj->__get_value( 'type' ), q{}, q; is $obj->delimiters(), q{''}, q; is $obj->__get_value( 'start' ), q{'}, q; is $obj->__get_value( 'finish' ), q{'}, q; is $obj->encoding(), undef, q<'' encoding>; is_deeply [ sort $obj->variables() ], [ qw{ } ], q<'' interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<'' postderef>; cmp_ok scalar $obj->elements(), '==', 3, q; cmp_ok scalar $obj->children(), '==', 0, q; } $obj = PPIx::QuoteLike->new( q{qq xyx} ); if ( ok $obj, q{Able to parse qq xyx} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing qq xyx}; cmp_ok $obj->interpolates(), '==', 1, q{Does qq xyx interpolate}; is $obj->content(), q{qq xyx}, q{Can recover qq xyx}; is $obj->__get_value( 'type' ), q{qq}, q{Type of qq xyx}; is $obj->delimiters(), q{xx}, q{Delimiters of qq xyx}; is $obj->__get_value( 'start' ), q{x}, q{Start delimiter of qq xyx}; is $obj->__get_value( 'finish' ), q{x}, q{Finish delimiter of qq xyx}; is $obj->encoding(), undef, q{qq xyx encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ } ], q{qq xyx interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{qq xyx postderef}; cmp_ok scalar $obj->elements(), '==', 5, q{Number of elements of qq xyx}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of qq xyx}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{qq xyx child 0 class}; is $kid->content(), q{y}, q{qq xyx child 0 content}; is $kid->error(), undef, q{qq xyx child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{qq xyx child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{qq xyx child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{qq xyx child 0 next sibling}; } } $obj = PPIx::QuoteLike->new( q{"foo\"bar"} ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q{"foo\"bar"}, q; is $obj->__get_value( 'type' ), q{}, q; is $obj->delimiters(), q{""}, q; is $obj->__get_value( 'start' ), q{"}, q; is $obj->__get_value( 'finish' ), q{"}, q; is $obj->encoding(), undef, q<"foo\"bar" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ } ], q<"foo\"bar" interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<"foo\"bar" postderef>; cmp_ok scalar $obj->elements(), '==', 4, q; cmp_ok scalar $obj->children(), '==', 1, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q<"foo\"bar" child 0 class>; is $kid->content(), q{foo\"bar}, q<"foo\"bar" child 0 content>; is $kid->error(), undef, q<"foo\"bar" child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<"foo\"bar" child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<"foo\"bar" child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<"foo\"bar" child 0 next sibling>; } } $obj = PPIx::QuoteLike->new( q/q{\Qx}/ ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 0, q; is $obj->content(), q/q{\Qx}/, q; is $obj->__get_value( 'type' ), q{q}, q; is $obj->delimiters(), q/{}/, q; is $obj->__get_value( 'start' ), q/{/, q; is $obj->__get_value( 'finish' ), q/}/, q; is $obj->encoding(), undef, q; is_deeply [ sort $obj->variables() ], [ qw{ } ], q; cmp_ok $obj->postderef(), '==', 1, q; cmp_ok scalar $obj->elements(), '==', 4, q; cmp_ok scalar $obj->children(), '==', 1, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q; is $kid->content(), q{\Qx}, q; is $kid->error(), undef, q; cmp_ok $kid->parent(), '==', $obj, q; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q; } } $obj = PPIx::QuoteLike->new( q/qq {\Qx}/ ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q/qq {\Qx}/, q; is $obj->__get_value( 'type' ), q{qq}, q; is $obj->delimiters(), q/{}/, q; is $obj->__get_value( 'start' ), q/{/, q; is $obj->__get_value( 'finish' ), q/}/, q; is $obj->encoding(), undef, q; is_deeply [ sort $obj->variables() ], [ qw{ } ], q; cmp_ok $obj->postderef(), '==', 1, q; cmp_ok scalar $obj->elements(), '==', 6, q; cmp_ok scalar $obj->children(), '==', 2, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Control' ), q; is $kid->content(), q{\Q}, q; is $kid->error(), undef, q; cmp_ok $kid->parent(), '==', $obj, q; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q; is $kid->content(), q{x}, q; is $kid->error(), undef, q; cmp_ok $kid->parent(), '==', $obj, q; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q; } } $obj = PPIx::QuoteLike->new( q{qx '$foo'} ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 0, q; is $obj->content(), q{qx '$foo'}, q; is $obj->__get_value( 'type' ), q{qx}, q; is $obj->delimiters(), q{''}, q; is $obj->__get_value( 'start' ), q{'}, q; is $obj->__get_value( 'finish' ), q{'}, q; is $obj->encoding(), undef, q; is_deeply [ sort $obj->variables() ], [ qw{ } ], q; cmp_ok $obj->postderef(), '==', 1, q; cmp_ok scalar $obj->elements(), '==', 5, q; cmp_ok scalar $obj->children(), '==', 1, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q; is $kid->content(), q{$foo}, q; is $kid->error(), undef, q; cmp_ok $kid->parent(), '==', $obj, q; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q; } } $obj = PPIx::QuoteLike->new( q{"$foo"} ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q{"$foo"}, q; is $obj->__get_value( 'type' ), q{}, q; is $obj->delimiters(), q{""}, q; is $obj->__get_value( 'start' ), q{"}, q; is $obj->__get_value( 'finish' ), q{"}, q; is $obj->encoding(), undef, q<"$foo" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q<"$foo" interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<"$foo" postderef>; cmp_ok scalar $obj->elements(), '==', 4, q; cmp_ok scalar $obj->children(), '==', 1, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<"$foo" child 0 class>; is $kid->content(), q{$foo}, q<"$foo" child 0 content>; is $kid->error(), undef, q<"$foo" child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<"$foo" child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<"$foo" child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<"$foo" child 0 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q<"$foo" child 0 interpolated variables>; } } $obj = PPIx::QuoteLike->new( q{"$$foo"} ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q{"$$foo"}, q; is $obj->__get_value( 'type' ), q{}, q; is $obj->delimiters(), q{""}, q; is $obj->__get_value( 'start' ), q{"}, q; is $obj->__get_value( 'finish' ), q{"}, q; is $obj->encoding(), undef, q<"$$foo" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q<"$$foo" interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<"$$foo" postderef>; cmp_ok scalar $obj->elements(), '==', 4, q; cmp_ok scalar $obj->children(), '==', 1, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<"$$foo" child 0 class>; is $kid->content(), q{$$foo}, q<"$$foo" child 0 content>; is $kid->error(), undef, q<"$$foo" child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<"$$foo" child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<"$$foo" child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<"$$foo" child 0 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q<"$$foo" child 0 interpolated variables>; } } $obj = PPIx::QuoteLike->new( q/qx{${foo}bar}/ ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q/qx{${foo}bar}/, q; is $obj->__get_value( 'type' ), q{qx}, q; is $obj->delimiters(), q/{}/, q; is $obj->__get_value( 'start' ), q/{/, q; is $obj->__get_value( 'finish' ), q/}/, q; is $obj->encoding(), undef, q; is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q; cmp_ok $obj->postderef(), '==', 1, q; cmp_ok scalar $obj->elements(), '==', 5, q; cmp_ok scalar $obj->children(), '==', 2, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q; is $kid->content(), q/${foo}/, q; is $kid->error(), undef, q; cmp_ok $kid->parent(), '==', $obj, q; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q; is $kid->content(), q{bar}, q; is $kid->error(), undef, q; cmp_ok $kid->parent(), '==', $obj, q; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q; } } $obj = PPIx::QuoteLike->new( q{<$foo>} ); if ( ok $obj, q> ) { cmp_ok $obj->failures(), '==', 0, q>; cmp_ok $obj->interpolates(), '==', 1, q interpolate>; is $obj->content(), q{<$foo>}, q>; is $obj->__get_value( 'type' ), q{}, q>; is $obj->delimiters(), q{<>}, q>; is $obj->__get_value( 'start' ), q{<}, q>; is $obj->__get_value( 'finish' ), q{>}, q>; is $obj->encoding(), undef, q<<$foo> encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q<<$foo> interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<<$foo> postderef>; cmp_ok scalar $obj->elements(), '==', 4, q>; cmp_ok scalar $obj->children(), '==', 1, q>; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<<$foo> child 0 class>; is $kid->content(), q{$foo}, q<<$foo> child 0 content>; is $kid->error(), undef, q<<$foo> child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<<$foo> child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<<$foo> child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<<$foo> child 0 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q<<$foo> child 0 interpolated variables>; } } $obj = PPIx::QuoteLike->new( q/"foo@{[ qq<$bar$baz> ]}buzz"/ ); if ( ok $obj, q ]}buzz"> ) { cmp_ok $obj->failures(), '==', 0, q ]}buzz">; cmp_ok $obj->interpolates(), '==', 1, q ]}buzz" interpolate>; is $obj->content(), q/"foo@{[ qq<$bar$baz> ]}buzz"/, q ]}buzz">; is $obj->__get_value( 'type' ), q{}, q ]}buzz">; is $obj->delimiters(), q{""}, q ]}buzz">; is $obj->__get_value( 'start' ), q{"}, q ]}buzz">; is $obj->__get_value( 'finish' ), q{"}, q ]}buzz">; is $obj->encoding(), undef, q<"foo@{[ qq<$bar$baz> ]}buzz" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $bar $baz } ], q<"foo@{[ qq<$bar$baz> ]}buzz" interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<"foo@{[ qq<$bar$baz> ]}buzz" postderef>; cmp_ok scalar $obj->elements(), '==', 6, q ]}buzz">; cmp_ok scalar $obj->children(), '==', 3, q ]}buzz">; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 0 class>; is $kid->content(), q{foo}, q<"foo@{[ qq<$bar$baz> ]}buzz" child 0 content>; is $kid->error(), undef, q<"foo@{[ qq<$bar$baz> ]}buzz" child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<"foo@{[ qq<$bar$baz> ]}buzz" child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 0 next sibling>; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 class>; is $kid->content(), q/@{[ qq<$bar$baz> ]}/, q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 content>; is $kid->error(), undef, q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 error>; cmp_ok $kid->parent(), '==', $obj, q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $bar $baz } ], q<"foo@{[ qq<$bar$baz> ]}buzz" child 1 interpolated variables>; } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 2 class>; is $kid->content(), q{buzz}, q<"foo@{[ qq<$bar$baz> ]}buzz" child 2 content>; is $kid->error(), undef, q<"foo@{[ qq<$bar$baz> ]}buzz" child 2 error>; cmp_ok $kid->parent(), '==', $obj, q<"foo@{[ qq<$bar$baz> ]}buzz" child 2 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 2 - 1 ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 2 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 2 + 1 ), q<"foo@{[ qq<$bar$baz> ]}buzz" child 2 next sibling>; } } $obj = PPIx::QuoteLike->new( q{"$foo::$bar"} ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q{"$foo::$bar"}, q; is $obj->__get_value( 'type' ), q{}, q; is $obj->delimiters(), q{""}, q; is $obj->__get_value( 'start' ), q{"}, q; is $obj->__get_value( 'finish' ), q{"}, q; is $obj->encoding(), undef, q<"$foo::$bar" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $bar $foo } ], q<"$foo::$bar" interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<"$foo::$bar" postderef>; cmp_ok scalar $obj->elements(), '==', 6, q; cmp_ok scalar $obj->children(), '==', 3, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<"$foo::$bar" child 0 class>; is $kid->content(), q{$foo}, q<"$foo::$bar" child 0 content>; is $kid->error(), undef, q<"$foo::$bar" child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<"$foo::$bar" child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<"$foo::$bar" child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<"$foo::$bar" child 0 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q<"$foo::$bar" child 0 interpolated variables>; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q<"$foo::$bar" child 1 class>; is $kid->content(), q{::}, q<"$foo::$bar" child 1 content>; is $kid->error(), undef, q<"$foo::$bar" child 1 error>; cmp_ok $kid->parent(), '==', $obj, q<"$foo::$bar" child 1 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q<"$foo::$bar" child 1 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q<"$foo::$bar" child 1 next sibling>; } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<"$foo::$bar" child 2 class>; is $kid->content(), q{$bar}, q<"$foo::$bar" child 2 content>; is $kid->error(), undef, q<"$foo::$bar" child 2 error>; cmp_ok $kid->parent(), '==', $obj, q<"$foo::$bar" child 2 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 2 - 1 ), q<"$foo::$bar" child 2 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 2 + 1 ), q<"$foo::$bar" child 2 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $bar } ], q<"$foo::$bar" child 2 interpolated variables>; } } $obj = PPIx::QuoteLike->new( q/"@{$x[$i]}"/ ); if ( ok $obj, q ) { cmp_ok $obj->failures(), '==', 0, q; cmp_ok $obj->interpolates(), '==', 1, q; is $obj->content(), q/"@{$x[$i]}"/, q; is $obj->__get_value( 'type' ), q{}, q; is $obj->delimiters(), q{""}, q; is $obj->__get_value( 'start' ), q{"}, q; is $obj->__get_value( 'finish' ), q{"}, q; is $obj->encoding(), undef, q<"@{$x[$i]}" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $i @x } ], q<"@{$x[$i]}" interpolated variables>; cmp_ok $obj->postderef(), '==', 1, q<"@{$x[$i]}" postderef>; cmp_ok scalar $obj->elements(), '==', 4, q; cmp_ok scalar $obj->children(), '==', 1, q; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q<"@{$x[$i]}" child 0 class>; is $kid->content(), q/@{$x[$i]}/, q<"@{$x[$i]}" child 0 content>; is $kid->error(), undef, q<"@{$x[$i]}" child 0 error>; cmp_ok $kid->parent(), '==', $obj, q<"@{$x[$i]}" child 0 parent>; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q<"@{$x[$i]}" child 0 previous sibling>; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q<"@{$x[$i]}" child 0 next sibling>; is_deeply [ sort $kid->variables() ], [ qw{ $i @x } ], q<"@{$x[$i]}" child 0 interpolated variables>; } } $obj = PPIx::QuoteLike->new( q/"\N{$foo}"/ ); if ( ok $obj, q{Able to parse "\N{$foo}"} ) { cmp_ok $obj->failures(), '==', 1, q{Failures parsing "\N{$foo}"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "\N{$foo}" interpolate}; is $obj->content(), q/"\N{$foo}"/, q{Can recover "\N{$foo}"}; is $obj->__get_value( 'type' ), q{}, q{Type of "\N{$foo}"}; is $obj->delimiters(), q{""}, q{Delimiters of "\N{$foo}"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "\N{$foo}"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "\N{$foo}"}; is $obj->encoding(), undef, q{"\N{$foo}" encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ } ], q{"\N{$foo}" interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{"\N{$foo}" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "\N{$foo}"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "\N{$foo}"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Unknown' ), q{"\N{$foo}" child 0 class}; is $kid->content(), q/\N{$foo}/, q{"\N{$foo}" child 0 content}; is $kid->error(), q{Unknown charname '$foo'}, q{"\N{$foo}" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"\N{$foo}" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"\N{$foo}" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"\N{$foo}" child 0 next sibling}; } } $obj = PPIx::QuoteLike->new( <<'__END_OF_HERE_DOCUMENT' << "EOD" $foo->{bar}bazzle EOD __END_OF_HERE_DOCUMENT ); if ( ok $obj, q{Able to parse << "EOD" $foo->{bar}bazzle EOD } ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing << "EOD" $foo->{bar}bazzle EOD }; cmp_ok $obj->interpolates(), '==', 1, q{Does << "EOD" $foo->{bar}bazzle EOD interpolate}; is $obj->content(), <<'__END_OF_HERE_DOCUMENT' << "EOD" $foo->{bar}bazzle EOD __END_OF_HERE_DOCUMENT , q{Can recover << "EOD" $foo->{bar}bazzle EOD }; is $obj->__get_value( 'type' ), '<<', q{Type of << "EOD" $foo->{bar}bazzle EOD }; is $obj->delimiters(), q{"EOD"EOD}, q{Delimiters of << "EOD" $foo->{bar}bazzle EOD }; is $obj->__get_value( 'start' ), q{"EOD"}, q{Start delimiter of << "EOD" $foo->{bar}bazzle EOD }; is $obj->__get_value( 'finish' ), q{EOD}, q{Finish delimiter of << "EOD" $foo->{bar}bazzle EOD }; is $obj->encoding(), undef, q{<< "EOD" $foo->{bar}bazzle EOD encoding}; is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q{<< "EOD" $foo->{bar}bazzle EOD interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{<< "EOD" $foo->{bar}bazzle EOD postderef}; cmp_ok scalar $obj->elements(), '==', 8, q{Number of elements of << "EOD" $foo->{bar}bazzle EOD }; cmp_ok scalar $obj->children(), '==', 2, q{Number of children of << "EOD" $foo->{bar}bazzle EOD }; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{<< "EOD" $foo->{bar}bazzle EOD child 0 class}; is $kid->content(), q/$foo->{bar}/, q{<< "EOD" $foo->{bar}bazzle EOD child 0 content}; is $kid->error(), undef, q{<< "EOD" $foo->{bar}bazzle EOD child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{<< "EOD" $foo->{bar}bazzle EOD child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{<< "EOD" $foo->{bar}bazzle EOD child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{<< "EOD" $foo->{bar}bazzle EOD child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q{<< "EOD" $foo->{bar}bazzle EOD child 0 interpolated variables}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{<< "EOD" $foo->{bar}bazzle EOD child 1 class}; is $kid->content(), q{bazzle }, q{<< "EOD" $foo->{bar}bazzle EOD child 1 content}; is $kid->error(), undef, q{<< "EOD" $foo->{bar}bazzle EOD child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{<< "EOD" $foo->{bar}bazzle EOD child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{<< "EOD" $foo->{bar}bazzle EOD child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{<< "EOD" $foo->{bar}bazzle EOD child 1 next sibling}; } } $obj = PPIx::QuoteLike->new( q{"@@x"} ); if ( ok $obj, q{Able to parse "@@x"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "@@x"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "@@x" interpolate}; is $obj->content(), q{"@@x"}, q{Can recover "@@x"}; is $obj->__get_value( 'type' ), q{}, q{Type of "@@x"}; is $obj->delimiters(), q{""}, q{Delimiters of "@@x"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "@@x"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "@@x"}; is $obj->encoding(), undef, q{"@@x" encoding}; is_deeply [ sort $obj->variables() ], [ qw{ @x } ], q{"@@x" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"@@x" postderef}; cmp_ok scalar $obj->elements(), '==', 5, q{Number of elements of "@@x"}; cmp_ok scalar $obj->children(), '==', 2, q{Number of children of "@@x"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"@@x" child 0 class}; is $kid->content(), q{@}, q{"@@x" child 0 content}; is $kid->error(), undef, q{"@@x" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"@@x" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"@@x" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"@@x" child 0 next sibling}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"@@x" child 1 class}; is $kid->content(), q{@x}, q{"@@x" child 1 content}; is $kid->error(), undef, q{"@@x" child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{"@@x" child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{"@@x" child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{"@@x" child 1 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ @x } ], q{"@@x" child 1 interpolated variables}; } } $obj = PPIx::QuoteLike->new( q{"x@*y"} ); if ( ok $obj, q{Able to parse "x@*y"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "x@*y"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "x@*y" interpolate}; is $obj->content(), q{"x@*y"}, q{Can recover "x@*y"}; is $obj->__get_value( 'type' ), q{}, q{Type of "x@*y"}; is $obj->delimiters(), q{""}, q{Delimiters of "x@*y"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "x@*y"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "x@*y"}; is $obj->encoding(), undef, q{"x@*y" encoding}; is_deeply [ sort $obj->variables() ], [ qw{ } ], q{"x@*y" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"x@*y" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "x@*y"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "x@*y"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"x@*y" child 0 class}; is $kid->content(), q{x@*y}, q{"x@*y" child 0 content}; is $kid->error(), undef, q{"x@*y" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"x@*y" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"x@*y" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"x@*y" child 0 next sibling}; } } $obj = PPIx::QuoteLike->new( q{"$@"} ); if ( ok $obj, q{Able to parse "$@"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "$@"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "$@" interpolate}; is $obj->content(), q{"$@"}, q{Can recover "$@"}; is $obj->__get_value( 'type' ), q{}, q{Type of "$@"}; is $obj->delimiters(), q{""}, q{Delimiters of "$@"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "$@"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "$@"}; is $obj->encoding(), undef, q{"$@" encoding}; is_deeply [ sort $obj->variables() ], [ qw{ $@ } ], q{"$@" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"$@" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "$@"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "$@"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"$@" child 0 class}; is $kid->content(), q{$@}, q{"$@" child 0 content}; is $kid->error(), undef, q{"$@" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"$@" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"$@" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"$@" child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $@ } ], q{"$@" child 0 interpolated variables}; } } $obj = PPIx::QuoteLike->new( q/"${x}[0]"/ ); if ( ok $obj, q{Able to parse "${x}[0]"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "${x}[0]"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "${x}[0]" interpolate}; is $obj->content(), q/"${x}[0]"/, q{Can recover "${x}[0]"}; is $obj->__get_value( 'type' ), q{}, q{Type of "${x}[0]"}; is $obj->delimiters(), q{""}, q{Delimiters of "${x}[0]"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "${x}[0]"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "${x}[0]"}; is $obj->encoding(), undef, q{"${x}[0]" encoding}; is_deeply [ sort $obj->variables() ], [ qw{ $x } ], q{"${x}[0]" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"${x}[0]" postderef}; cmp_ok scalar $obj->elements(), '==', 5, q{Number of elements of "${x}[0]"}; cmp_ok scalar $obj->children(), '==', 2, q{Number of children of "${x}[0]"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"${x}[0]" child 0 class}; is $kid->content(), q/${x}/, q{"${x}[0]" child 0 content}; is $kid->error(), undef, q{"${x}[0]" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"${x}[0]" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"${x}[0]" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"${x}[0]" child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $x } ], q{"${x}[0]" child 0 interpolated variables}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"${x}[0]" child 1 class}; is $kid->content(), q{[0]}, q{"${x}[0]" child 1 content}; is $kid->error(), undef, q{"${x}[0]" child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{"${x}[0]" child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{"${x}[0]" child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{"${x}[0]" child 1 next sibling}; } } $obj = PPIx::QuoteLike->new( q{"$x[$[]"} ); if ( ok $obj, q{Able to parse "$x[$[]"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "$x[$[]"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "$x[$[]" interpolate}; is $obj->content(), q{"$x[$[]"}, q{Can recover "$x[$[]"}; is $obj->__get_value( 'type' ), q{}, q{Type of "$x[$[]"}; is $obj->delimiters(), q{""}, q{Delimiters of "$x[$[]"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "$x[$[]"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "$x[$[]"}; is $obj->encoding(), undef, q{"$x[$[]" encoding}; is_deeply [ sort $obj->variables() ], [ qw{ $[ @x } ], q{"$x[$[]" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"$x[$[]" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "$x[$[]"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "$x[$[]"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"$x[$[]" child 0 class}; is $kid->content(), q{$x[$[]}, q{"$x[$[]" child 0 content}; is $kid->error(), undef, q{"$x[$[]" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"$x[$[]" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"$x[$[]" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"$x[$[]" child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $[ @x } ], q{"$x[$[]" child 0 interpolated variables}; } } $obj = PPIx::QuoteLike->new( q/"$${foo}"/ ); if ( ok $obj, q{Able to parse "$${foo}"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "$${foo}"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "$${foo}" interpolate}; is $obj->content(), q/"$${foo}"/, q{Can recover "$${foo}"}; is $obj->__get_value( 'type' ), q{}, q{Type of "$${foo}"}; is $obj->delimiters(), q{""}, q{Delimiters of "$${foo}"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "$${foo}"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "$${foo}"}; is $obj->encoding(), undef, q{"$${foo}" encoding}; is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q{"$${foo}" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"$${foo}" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "$${foo}"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "$${foo}"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"$${foo}" child 0 class}; is $kid->content(), q/$${foo}/, q{"$${foo}" child 0 content}; is $kid->error(), undef, q{"$${foo}" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"$${foo}" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"$${foo}" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"$${foo}" child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q<"$${foo}" child 0 interpolated variables>; } } $obj = PPIx::QuoteLike->new( q/"${$}"/ ); if ( ok $obj, q{Able to parse "${$}"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "${$}"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "${$}" interpolate}; is $obj->content(), q/"${$}"/, q{Can recover "${$}"}; is $obj->__get_value( 'type' ), q{}, q{Type of "${$}"}; is $obj->delimiters(), q{""}, q{Delimiters of "${$}"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "${$}"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "${$}"}; is $obj->encoding(), undef, q<"${$}" encoding>; is_deeply [ sort $obj->variables() ], [ qw{ $$ } ], q{"${$}" interpolated variables}; cmp_ok $obj->postderef(), '==', 1, q{"${$}" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "${$}"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "${$}"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"${$}" child 0 class}; is $kid->content(), q/${$}/, q{"${$}" child 0 content}; is $kid->error(), undef, q{"${$}" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"${$}" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"${$}" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"${$}" child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $$ } ], q{"${$}" child 0 interpolated variables}; } } $obj = PPIx::QuoteLike->new( q/"@{[ ${ foo } ]}"/ ); if ( ok $obj, q{Able to parse "@{[ ${ foo } ]}"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "@{[ ${ foo } ]}"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "@{[ ${ foo } ]}" interpolate}; is $obj->content(), q/"@{[ ${ foo } ]}"/, q{Can recover "@{[ ${ foo } ]}"}; is $obj->__get_value( 'type' ), q{}, q{Type of "@{[ ${ foo } ]}"}; is $obj->delimiters(), q{""}, q{Delimiters of "@{[ ${ foo } ]}"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "@{[ ${ foo } ]}"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "@{[ ${ foo } ]}"}; is $obj->encoding(), undef, q{"@{[ ${ foo } ]}" encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ $foo } ], q{"@{[ ${ foo } ]}" interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{"@{[ ${ foo } ]}" postderef}; cmp_ok scalar $obj->elements(), '==', 4, q{Number of elements of "@{[ ${ foo } ]}"}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of "@{[ ${ foo } ]}"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"@{[ ${ foo } ]}" child 0 class}; is $kid->content(), q/@{[ ${ foo } ]}/, q{"@{[ ${ foo } ]}" child 0 content}; is $kid->error(), undef, q{"@{[ ${ foo } ]}" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"@{[ ${ foo } ]}" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"@{[ ${ foo } ]}" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"@{[ ${ foo } ]}" child 0 next sibling}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q{"@{[ ${ foo } ]}" child 0 interpolated variables}; } } } $obj = PPIx::QuoteLike->new( q{"<$a->@*>"} ); if ( ok $obj, q{Able to parse "<$a->@*>"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "<$a->@*>"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "<$a->@*>" interpolate}; is $obj->content(), q{"<$a->@*>"}, q{Can recover "<$a->@*>"}; is $obj->__get_value( 'type' ), q{}, q{Type of "<$a->@*>"}; is $obj->delimiters(), q{""}, q{Delimiters of "<$a->@*>"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "<$a->@*>"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "<$a->@*>"}; is $obj->encoding(), undef, q{"<$a->@*>" encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ $a } ], q{"<$a->@*>" interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{"<$a->@*>" postderef}; cmp_ok scalar $obj->elements(), '==', 6, q{Number of elements of "<$a->@*>"}; cmp_ok scalar $obj->children(), '==', 3, q{Number of children of "<$a->@*>"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"<$a->@*>" child 0 class}; is $kid->content(), q{<}, q{"<$a->@*>" child 0 content}; is $kid->error(), undef, q{"<$a->@*>" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"<$a->@*>" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"<$a->@*>" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"<$a->@*>" child 0 next sibling}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"<$a->@*>" child 1 class}; is $kid->content(), q{$a->@*}, q{"<$a->@*>" child 1 content}; is $kid->error(), undef, q{"<$a->@*>" child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{"<$a->@*>" child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{"<$a->@*>" child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{"<$a->@*>" child 1 next sibling}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $kid->variables() ], [ qw{ $a } ], q{"<$a->@*>" child 1 interpolated variables}; } } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"<$a->@*>" child 2 class}; is $kid->content(), q{>}, q{"<$a->@*>" child 2 content}; is $kid->error(), undef, q{"<$a->@*>" child 2 error}; cmp_ok $kid->parent(), '==', $obj, q{"<$a->@*>" child 2 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 2 - 1 ), q{"<$a->@*>" child 2 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 2 + 1 ), q{"<$a->@*>" child 2 next sibling}; } } $obj = PPIx::QuoteLike->new( q{"<$a->@[0..2]>"} ); if ( ok $obj, q{Able to parse "<$a->@[0..2]>"} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing "<$a->@[0..2]>"}; cmp_ok $obj->interpolates(), '==', 1, q{Does "<$a->@[0..2]>" interpolate}; is $obj->content(), q{"<$a->@[0..2]>"}, q{Can recover "<$a->@[0..2]>"}; is $obj->__get_value( 'type' ), q{}, q{Type of "<$a->@[0..2]>"}; is $obj->delimiters(), q{""}, q{Delimiters of "<$a->@[0..2]>"}; is $obj->__get_value( 'start' ), q{"}, q{Start delimiter of "<$a->@[0..2]>"}; is $obj->__get_value( 'finish' ), q{"}, q{Finish delimiter of "<$a->@[0..2]>"}; is $obj->encoding(), undef, q{"<$a->@[0..2]>" encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ $a } ], q{"<$a->@[0..2]>" interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{"<$a->@[0..2]>" postderef}; cmp_ok scalar $obj->elements(), '==', 6, q{Number of elements of "<$a->@[0..2]>"}; cmp_ok scalar $obj->children(), '==', 3, q{Number of children of "<$a->@[0..2]>"}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"<$a->@[0..2]>" child 0 class}; is $kid->content(), q{<}, q{"<$a->@[0..2]>" child 0 content}; is $kid->error(), undef, q{"<$a->@[0..2]>" child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{"<$a->@[0..2]>" child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{"<$a->@[0..2]>" child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{"<$a->@[0..2]>" child 0 next sibling}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{"<$a->@[0..2]>" child 1 class}; is $kid->content(), q{$a->@[0..2]}, q{"<$a->@[0..2]>" child 1 content}; is $kid->error(), undef, q{"<$a->@[0..2]>" child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{"<$a->@[0..2]>" child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{"<$a->@[0..2]>" child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{"<$a->@[0..2]>" child 1 next sibling}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $kid->variables() ], [ qw{ $a } ], q{"<$a->@[0..2]>" child 1 interpolated variables}; } } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{"<$a->@[0..2]>" child 2 class}; is $kid->content(), q{>}, q{"<$a->@[0..2]>" child 2 content}; is $kid->error(), undef, q{"<$a->@[0..2]>" child 2 error}; cmp_ok $kid->parent(), '==', $obj, q{"<$a->@[0..2]>" child 2 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 2 - 1 ), q{"<$a->@[0..2]>" child 2 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 2 + 1 ), q{"<$a->@[0..2]>" child 2 next sibling}; } } SKIP: { SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS or skip 'Truly weird delimiters test requires Perl 5.8.3 or above', 2; $ENV{AUTHOR_TESTING} or skip 'Truly weird delimiters are noisy, therefore author tests', 2; no warnings qw{ utf8}; # Because of truly weird characters my $delim = "\N{U+FFFE}"; # Permanent noncharacter $obj = PPIx::QuoteLike->new( qq{qq ${delim}y$delim} ); if ( ok $obj, q{Able to parse qq ?y? with noncharacter delimiter} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing qq ?y? with noncharacter delimiter}; cmp_ok $obj->interpolates(), '==', 1, q{Does qq ?y? with noncharacter delimiter interpolate}; is $obj->content(), qq{qq ${delim}y$delim}, q{Can recover qq ?y? with noncharacter delimiter}; is $obj->__get_value( 'type' ), q{qq}, q{Type of qq ?y? with noncharacter delimiter}; is $obj->delimiters(), qq{$delim$delim}, q{Delimiters of qq ?y? with noncharacter delimiter}; is $obj->__get_value( 'start' ), $delim, q{Start delimiter of qq ?y? with noncharacter delimiter}; is $obj->__get_value( 'finish' ), $delim, q{Finish delimiter of qq ?y? with noncharacter delimiter}; is $obj->encoding(), undef, q{qq ?y? with noncharacter delimiter encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ } ], q{qq ?y? with noncharacter delimiter interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{qq ?y? with noncharacter delimiter postderef}; cmp_ok scalar $obj->elements(), '==', 5, q{Number of elements of qq ?y? with noncharacter delimiter}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of qq ?y? with noncharacter delimiter}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{qq ?y? with noncharacter delimiter child 0 class}; is $kid->content(), q{y}, q{qq ?y? with noncharacter delimiter child 0 content}; is $kid->error(), undef, q{qq ?y? with noncharacter delimiter child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{qq ?y? with noncharacter delimiter child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{qq ?y? with noncharacter delimiter child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{qq ?y? with noncharacter delimiter child 0 next sibling}; } } $delim = "\N{U+11FFFF}"; # Illegal character $obj = PPIx::QuoteLike->new( qq{qq ${delim}y$delim} ); if ( ok $obj, q{Able to parse qq ?y? with illegal character delimiter} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing qq ?y? with illegal character delimiter}; cmp_ok $obj->interpolates(), '==', 1, q{Does qq ?y? with illegal character delimiter interpolate}; is $obj->content(), qq{qq ${delim}y$delim}, q{Can recover qq ?y? with illegal character delimiter}; is $obj->__get_value( 'type' ), q{qq}, q{Type of qq ?y? with illegal character delimiter}; is $obj->delimiters(), qq{$delim$delim}, q{Delimiters of qq ?y? with illegal character delimiter}; is $obj->__get_value( 'start' ), $delim, q{Start delimiter of qq ?y? with illegal character delimiter}; is $obj->__get_value( 'finish' ), $delim, q{Finish delimiter of qq ?y? with illegal character delimiter}; is $obj->encoding(), undef, q{qq ?y? with illegal character delimiter encoding}; if ( eval { require PPI::Document; 1 } ) { is_deeply [ sort $obj->variables() ], [ qw{ } ], q{qq ?y? with illegal character delimiter interpolated variables}; } cmp_ok $obj->postderef(), '==', 1, q{qq ?y? with illegal character delimiter postderef}; cmp_ok scalar $obj->elements(), '==', 5, q{Number of elements of qq ?y? with illegal character delimiter}; cmp_ok scalar $obj->children(), '==', 1, q{Number of children of qq ?y? with illegal character delimiter}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{qq ?y? with illegal character delimiter child 0 class}; is $kid->content(), q{y}, q{qq ?y? with illegal character delimiter child 0 content}; is $kid->error(), undef, q{qq ?y? with illegal character delimiter child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{qq ?y? with illegal character delimiter child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{qq ?y? with illegal character delimiter child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{qq ?y? with illegal character delimiter child 0 next sibling}; } } } done_testing; sub PPIx::QuoteLike::__get_value { my ( $self, $method, @arg ) = @_; my $val = $self->$method( @arg ); return ref $val ? $val->content() : $val; } sub PPIx::QuoteLike::__kid { my ( $self, $inx ) = @_; $inx >= 0 and $inx < @{ $self->{children} } and return $self->{children}[$inx]; return 0; } 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/t/variables.t000066400000000000000000000042201357406156500205420ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use PPI::Document; use PPIx::QuoteLike::Constant qw{ HAVE_PPIX_REGEXP }; use PPIx::QuoteLike::Utils qw{ __variables }; use Test::More 0.88; # Because of done_testing(); sub check (@); sub check_class (@); sub check_token (@); check q<"foo$bar">, qw< $bar >; check q<'foo$bar'>; check_token q<"foo$bar">, qw< $bar >; check_token q<'foo$bar'>; check_class q<"foo$bar">, qw< PPIx::QuoteLike $bar >; # Note -- the following was done using the trinary operator rather than # if/else because I hoped that with the former implementation, when I # added tests I would do so correctly. note HAVE_PPIX_REGEXP ? 'PPIx::Regexp is installed; we can find variables in Regexps' : 'PPIx::Regexp is not installed; we can not find variables in Regexps'; check q, HAVE_PPIX_REGEXP ? qw< $bar $burfle $foo > : qw< $bar $foo >; check q, HAVE_PPIX_REGEXP ? qw< $bar > : (); check_token q, HAVE_PPIX_REGEXP ? qw{ $1 @bar } : (); if ( HAVE_PPIX_REGEXP ) { check_class q, qw< PPIx::Regexp $bar >; } done_testing; sub check (@) { my ( $expr, @want ) = @_; my $doc = PPI::Document->new( \$expr ); my @got = sort( __variables( $doc ) ); @_ = ( \@got, [ sort @want ], "Variables in q<$expr>" ); goto &is_deeply; } sub check_class (@) { my ( $expr, $class, @want ) = @_; ( my $fn = "$class.pm" ) =~ s| :: |/|smxg; require $fn; my $obj = $class->new( $expr ); my @got = sort( __variables( $obj ) ); @_ = ( \@got, [ sort @want ], "Variables in $class q<$expr>" ); goto &is_deeply; } sub check_token (@) { my ( $expr, @want ) = @_; my $doc = PPI::Document->new( \$expr ); my ( $elem ) = @{ $doc->find( sub { $_[1]->significant() && ! $_[1]->isa( 'PPI::Node' ) } ) || [] }; if ( $elem ) { my @got = sort( __variables( $elem ) ); @_ = ( \@got, [ sort @want ], "Variables in first token of q<$expr>" ); goto &is_deeply; } else { @_ = ( "No tokens found in q<$expr>" ); goto &fail; } } 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/t/version.t000066400000000000000000000074131357406156500202660ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use PPIx::QuoteLike; use PPIx::QuoteLike::Constant qw{ SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS }; use PPIx::QuoteLike::Token::Control; use PPIx::QuoteLike::Token::Delimiter; use PPIx::QuoteLike::Token::Interpolation; use PPIx::QuoteLike::Token::String; BEGIN { if ( SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS ) { # Have to prevent Perl from parsing 'open' as 'CORE::open'. require 'open.pm'; 'open'->import( qw{ :std :encoding(utf-8) } ); } } use Test::More 0.88; # Because of done_testing(); use charnames qw{ :full }; my $tok; $tok = PPIx::QuoteLike::Token::String->__new( content => 'foo' ); is $tok->perl_version_introduced(), '5.000', 'String was introduced in 5.0'; is $tok->perl_version_removed(), undef, 'String is still here'; $tok = PPIx::QuoteLike::Token::Control->__new( content => '\U' ); is $tok->perl_version_introduced(), '5.000', '\\U was introduced in 5.0'; is $tok->perl_version_removed(), undef, '\\U is still here'; $tok = PPIx::QuoteLike::Token::Control->__new( content => '\F' ); is $tok->perl_version_introduced(), '5.015008', '\\F was introduced in 5.15.8'; is $tok->perl_version_removed(), undef, '\\F is still here'; $tok = PPIx::QuoteLike::Token::Delimiter->__new( content => q<'> ); is $tok->perl_version_introduced(), '5.000', q{Delimiter q<'> was introduced in 5.0}; is $tok->perl_version_removed(), undef, q{Delimiter q<'> is still here}; SKIP: { SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS or skip 'Weird delimiters test requires Perl 5.8.3 or above', 2; $tok = PPIx::QuoteLike::Token::Delimiter->__new( content => qq<\N{COMBINING CIRCUMFLEX ACCENT}> ); is $tok->perl_version_introduced(), '5.008003', q[Delimiter qq<\N{COMBINING CIRCUMFLEX ACCENT}> was introduced in 5.8.3 (kinda)]; is $tok->perl_version_removed(), '5.029', q[Delimiter qq<\N{COMBINING CIRCUMFLEX ACCENT}> removed in 5.029]; } SKIP: { SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS or skip 'Truly weird delimiters test requires Perl 5.8.3 or above', 2; $ENV{AUTHOR_TESTING} or skip 'Truly weird delimiters are noisy, therefore author tests', 2; no warnings qw{ utf8 }; # Because of truly weird characters $tok = PPIx::QuoteLike::Token::Delimiter->__new( content => qq<\N{U+FFFE}> ); # permanent noncharacter is $tok->perl_version_introduced(), '5.008003', q[Delimiter qq<\N{U+FFFE}> was introduced in 5.8.3 (kinda)]; is $tok->perl_version_removed(), undef, q[Delimiter qq<\N{U+FFFE}> is still here]; $tok = PPIx::QuoteLike::Token::Delimiter->__new( content => qq<\N{U+11FFFF}> ); # illegal character is $tok->perl_version_introduced(), '5.008003', q[Delimiter qq<\N{U+11FFFF}> was introduced in 5.8.3 (kinda)]; is $tok->perl_version_removed(), undef, q[Delimiter qq<\N{U+11FFFF}> is still here]; } $tok = PPIx::QuoteLike::Token::Interpolation->__new( content => '$x' ); is $tok->perl_version_introduced(), '5.000', 'Interpolation was introduced in 5.0'; is $tok->perl_version_removed(), undef, 'Interpolation is still here'; $tok = PPIx::QuoteLike::Token::Interpolation->__new( content => '$x->@*' ); is $tok->perl_version_introduced(), '5.019005', 'Postfix dereference was introduced in 5.19.5'; is $tok->perl_version_removed(), undef, 'Postfix dereference is still here'; my $obj; $obj = PPIx::QuoteLike->new( '"foo$bar"' ); is $obj->perl_version_introduced(), '5.000', 'Double-quoted string was introduced in 5.0'; is $obj->perl_version_removed(), undef, 'Double-quoted string is still here'; $obj = PPIx::QuoteLike->new( '"foo\\F$bar"' ); is $obj->perl_version_introduced(), '5.015008', 'Case-folded string was introduced in 5.15.8'; is $obj->perl_version_removed(), undef, 'Case-folded string is still here'; done_testing; 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/000077500000000000000000000000001357406156500165775ustar00rootroot00000000000000libppix-quotelike-perl-0.008/xt/author/000077500000000000000000000000001357406156500201015ustar00rootroot00000000000000libppix-quotelike-perl-0.008/xt/author/carp_not.t000066400000000000000000000013641357406156500220770ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use ExtUtils::Manifest qw{ maniread }; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; use Test::More 0.88; # Because of done_testing(); my @modules; foreach my $fn ( sort keys %{ maniread() } ) { local $_ = $fn; s< \A lib/ ><>smx or next; s< [.] pm \z ><>smx or next; s< / ><::>smxg; push @modules, $_; local $/ = undef; open my $fh, '<:encoding(utf-8)', $fn or do { fail "Unable to open $fn: $!"; next; }; my $content = <$fh>; close $fh; ok $content =~ m/ \@CARP_NOT \b /smx, "$_ assigns \@CARP_NOT"; } is_deeply \@CARP_NOT, \@modules, 'Ensure that @PPIx::QuoteLike::Constant::CARP_NOT is correct'; done_testing; 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/changes.t000066400000000000000000000006021357406156500216740ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); BEGIN { eval { require Test::CPAN::Changes; Test::CPAN::Changes->import(); 1; } or do { plan skip_all => 'Unable to load Test::CPAN::Changes'; exit; }; } changes_file_ok( Changes => { next_token => 'next_release' } ); done_testing; 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/critic.t000066400000000000000000000010601357406156500215400ustar00rootroot00000000000000package main; use strict; use warnings; use File::Spec; use Test::More 0.88; BEGIN { eval { require PPI; PPI->VERSION( 1.215 ); 1; } or do { print "1..0 # skip PPI 1.215 or greater required to criticize code.\n"; exit; }; eval { require Test::Perl::Critic; # TODO package profile. Test::Perl::Critic->import( -profile => File::Spec->catfile(qw{xt author perlcriticrc}), ); 1; } or do { print "1..0 # skip Test::Perl::Critic required to criticize code.\n"; exit; }; } all_critic_ok(); 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/executable.t000066400000000000000000000011141357406156500224040ustar00rootroot00000000000000package main; use strict; use warnings; use ExtUtils::Manifest qw{maniread}; use Test::More 0.88; my $manifest = maniread(); foreach ( sort keys %{ $manifest } ) { m{ \A bin / }smx and next; m{ \A eg / }smx and next; m{ \A tools / }smx and next; ok ! is_executable(), "$_ should not be executable"; } done_testing; sub is_executable { my @stat = stat $_; $stat[2] & oct(111) and return 1; open my $fh, '<', $_ or die "Unable to open $_: $!\n"; local $_ = <$fh>; close $fh; return m{ \A [#]! .* perl }smx; } 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/kwalitee.t000066400000000000000000000005321357406156500220730ustar00rootroot00000000000000package main; use 5.006002; use strict; use warnings; use Test::More 0.96; eval { require Test::Kwalitee; Test::Kwalitee->import(); -f 'Debian_CPANTS.txt' # Don't know what this is, and unlink 'Debian_CPANTS.txt'; # but _I_ didn't order it. 1; } or plan skip_all => 'Test::Kwalitee not found'; 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/manifest.t000066400000000000000000000006231357406156500220750ustar00rootroot00000000000000package main; use strict; use warnings; use Test::More 0.88; BEGIN { eval { require ExtUtils::Manifest; 1; } or do { plan skip_all => 'Can not load ExtUtils::Manifest'; exit; }; } my @got = ExtUtils::Manifest->manicheck(); ok @got == 0, 'Missing files per MANIFEST'; @got = ExtUtils::Manifest->filecheck(); ok @got == 0, 'Files not in MANIFEST or MANIFEST.SKIP'; done_testing; 1; libppix-quotelike-perl-0.008/xt/author/minimum_perl.t000066400000000000000000000026261357406156500227710ustar00rootroot00000000000000package main; use 5.006; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); eval { require ExtUtils::Manifest; 1; } or plan skip_all => 'Unable to load ExtUtils::Manifest'; eval { require Perl::MinimumVersion; 1; } or plan skip_all => 'Unable to load Perl::MinimumVersion'; eval { require version; 1; } or plan skip_all => 'Unable to load version'; use lib qw{ inc }; use My::Module::Meta; my $min_perl = My::Module::Meta->requires_perl(); my $min_perl_vers = version->parse( $min_perl ); my $manifest = ExtUtils::Manifest::maniread(); foreach my $fn ( sort keys %{ $manifest } ) { $fn =~ m{ \A xt/ }smx and next; is_perl( $fn ) or next; my $doc = Perl::MinimumVersion->new( $fn ); cmp_ok $doc->minimum_version(), 'le', $min_perl, "$fn works under Perl $min_perl"; my $ppi_doc = $doc->Document(); foreach my $inc ( @{ $ppi_doc->find( 'PPI::Statement::Include' ) || [] } ) { my $vers = $inc->version() or next; cmp_ok( version->parse( $vers ), '==', $min_perl_vers, "$fn has use $min_perl, rather than some other version" ); last; } } done_testing; sub is_perl { my ( $fn ) = @_; $fn =~ m/ [.] (?: pm | t | pod | (?i: pl ) ) \z /smx and return 1; -f $fn and -T _ or return 0; open my $fh, '<', $fn or return 0; local $_ = <$fh>; close $fh; return m/ perl /smx; } 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/perlcriticrc000066400000000000000000000035141357406156500225140ustar00rootroot00000000000000severity = stern theme = core [Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval] allow_includes = 1 [Perl::Critic::Policy::Documentation::PodSpelling] spell_command = aspell list [Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval] # The default is 3 ('harsh'), but I think this is more severe than that. severity = stern [Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest] # Perl::Critic and Perl Best Practices prefer the IO::Interactive # is_interactive() subroutine to -T STDIN. But that assumes that # ARGV is used for input, and that you don't want to be interactive # if output goes to a pipe. I do not want these assumptions, but # rather than disable them in the code I am simply assigning them # a severity slightly higher than I currently use. severity = harsh [Perl::Critic::Policy::InputOutput::RequireCheckedOpen] # For some reason the default is 3 ('harsh'). But IM(NS)HO this # kind of thing should be a 5. So: severity = gentle [Perl::Critic::Policy::Subroutines::RequireArgUnpacking] short_subroutine_statements = 3 [Perl::Critic::Policy::Subroutines::RequireFinalReturn] terminal_funcs = CORE::exit [Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict] allow = refs [Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings] allow = exiting once substr uninitialized [Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma] # Perl::Critic and Perl Best Practices do not like the 'constant' # pragma because it does not interpolate. It really does, the # syntax is just different. Rather than disable the things in the # source, I'm just assigning them a severity slightly greater than # I customarily use. severity = harsh [Perl::Critic::Policy::Variables::ProhibitUnusedVarsStricter] add_themes = core allow_unused_subroutine_arguments = 0 severity = stern libppix-quotelike-perl-0.008/xt/author/pod.t000066400000000000000000000005051357406156500210500ustar00rootroot00000000000000package main; use strict; use warnings; use Test::More 0.88; BEGIN { eval { require Test::Pod; Test::Pod->VERSION (1.00); Test::Pod->import(); 1; } or do { print <VERSION(1.00); Test::Pod::Coverage->import(); 1; } or do { print < [ qr{^[[:upper:]\d_]+$}, ], coverage_class => 'Pod::Coverage::CountParents' }); 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/pod_links.t000066400000000000000000000005071357406156500222520ustar00rootroot00000000000000package main; use 5.008; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); eval { require Test::Pod::LinkCheck::Lite; 1; } or plan skip_all => 'Unable to load Test::Pod::LinkCheck::Lite'; Test::Pod::LinkCheck::Lite->new()->all_pod_files_ok(); done_testing; 1; # ex: set textwidth=72 : libppix-quotelike-perl-0.008/xt/author/pod_spelling.t000066400000000000000000000006111357406156500227430ustar00rootroot00000000000000package main; use strict; use warnings; BEGIN { eval { require Test::Spelling; 1; } or do { print "1..0 # skip Test::Spelling not available.\n"; exit; }; Test::Spelling->import(); } add_stopwords (); all_pod_files_spelling_ok (); 1; __DATA__ graphemes merchantability quotelike postderef postfix ppi ppix quotish schild schildren trigraphs uninterpolated Wyant