PPIx-QuoteLike-0.019000755000765000024 014144504537 13335 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/Build.PL000444000765000024 205414144504537 14767 0ustar00tomstaff000000000000use 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 = ( add_to_cleanup => $meta->add_to_cleanup(), build_requires => $meta->build_requires(), configure_requires => $meta->configure_requires(), dist_abstract => $meta->abstract(), dist_author => $meta->author(), dist_name => $meta->dist_name(), license => $meta->license(), module_name => $meta->module_name(), requires => $meta->requires( perl => $meta->requires_perl(), ), script_files => $meta->script_files(), ); if ( $mbv >= 0.28 ) { $args{meta_merge} = $meta->meta_merge(); $args{no_index} = $meta->no_index(); $args{meta_add} = { $meta->provides(), }, } $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 (); PPIx-QuoteLike-0.019/CONTRIBUTING000444000765000024 271614144504537 15332 0ustar00tomstaff000000000000I welcome bug reports, patches, and suggestions. My preferred way to recieve these is via the RT system at https://rt.cpan.org/Public/Dist/Display.html?Name=PPIx-QuoteLike, but I happily accept them either through GitHub at https://github.com/trwyant/perl-PPIx-QuoteLike, by electronic mail to WYANT AT cpan DOT org, or any other way that works for you, though I can not accept owls because I have no facilities to house them. Non-RT requests may be turned into RT tickets by me unless you specifically request otherwise. The bug report, patch, or suggestion (if acted on) will also be acknowledged in the Changes file unless you specifically request othewise. Requests for information probably do not need to be tickets in RT or GitHub, and my preferred route for these is by electronic mail, but again anything that works for you is probably fine with me. I try hard never to reject a bug report outright, though I may edit patches, believe that a different fix is more in line with my vision for the code, or even that the report is due to a misunderstanding and address it with a documentation change. Whatever I decide I will give you time to respond (typically a week or so), and whatever I actually do I will give you time to see if it meets your needs before I do a production release. GitHub pull requests should be made on a topic branch rather than the master branch. If you have something big in mind I would appreciate a heads-up in some form prior to the pull request. PPIx-QuoteLike-0.019/Changes000444000765000024 1354614144504537 15016 0ustar00tomstaff0000000000000.019 2021-11-15 T. R. Wyant Add CONTRIBUTING file. Try to quell weird Win32 test failures which seem to occur only in tests where I am using 'use open' to put the standard handles into UTF-8 mode. The fix (I hope) is to do this to the Test::Harness handles at run time instead of to the standard handles at compile time. 0.018 2021-10-22 T. R. Wyant Argument postderef is now fatal. Correct generation of 'provides' metadata. Thanks to Favio Poletti for blogging https://github.polettix.it/ETOOBUSY/2021/06/15/the-real-pause-workaround/, and ultimately to Joel Berger for the pointer to https://metacpan.org/pod/CPAN::Meta::Spec#no_index 0.017 2021-04-16 T. R. Wyant All uses of the postderef argument to new() now warn. 0.016 2021-03-26 T. R. Wyant Add rt.cpan.org back to bug reporting methods. Long live RT! Get prerequisites up to snuff, and add xt/author/prereq.t to ensure they stay that way. Refactor authortest into three, so I do not have to generate stub files to test without optional modules. 0.015 2021-02-05 T. R. Wyant Handle <<\EOD and <<~\EOD, which are equivalent to <<'EOD' and <<~'EOD', respectively. Recognize indented here documents. Thanks to Olaf Alders (oalders) for alerting me to this omission. 0.014 2021-01-14 T. R. Wyant Add Travis CI testing. Use GitHub as bug tracker. R.I.P. rt.cpan.org. 0.013 2020-10-09 T. R. Wyant Warn on first use of attribute 'postderef'. 0.012 2020-07-28 T. R. Wyant Remove prototypes from testing subroutines defined in t/*.t. 0.011 2020-03-31 T. R. Wyant Normalize interpolation before feeding to PPI. This produces a more-easily-analyzed PPI parse. The ->variables() method is now discouraged. It was written to support Perl::Critic::Policy::Variables::ProhibitUnusedVarsStricter, but turned out to be inadequate for the job. Deprecate new() argument postderef. At this stage it is only documented as deprecated. In the first release after October 1 2020 it will warn on the first use. Eventually it will be retracted, and postfix dereferences will always be recognized. This is the default behavior now. Correct bracket matchers to accept multiple lines. This was, in some cases, causing interpolations to be misclassified as unknown tokens. 0.010 2020-03-09 T. R. Wyant Remove redundant and poorly-performing code introduced in version 0.009. 0.009 2020-02-27 T. R. Wyant Add new() argument index_locations which causes locations to be indexed during the parse. This defaults based on whether a location argument was provided, and whether the string being parsed is a PPI::Element. Add method statement(), which returns the PPI statement containing the string element, or nothing if none. Add PPI::Element location methods, to wit: location(), column_number(), line_number(), logical_filename(), logical_line_number(), and visual_column_number(). Add PPIx::QuoteLike::Utils::is_ppi_quotelike_element() which returns true if the argument is a PPI::Element of interest to us. All objects now have a variables() method inherited from PPIx::QuoteLike::Token. This method returns nothing unless overridden. It was added to eliminate $elem->can( 'variables' ) ad-hocery. Eliminate redirections in POD URL links 0.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. PPIx-QuoteLike-0.019/MANIFEST000444000765000024 203314144504537 14621 0ustar00tomstaff000000000000Build.PL Changes CONTRIBUTING eg/pqldump eg/README 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 META.json META.yml README t/basic.t t/dump.t t/locations.t t/normalize_interpolation_for_ppi.t t/parse.t t/unit-adhoc.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 xt/author/prereq.t PPIx-QuoteLike-0.019/META.json000444000765000024 667614144504537 15132 0ustar00tomstaff000000000000{ "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.4231", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PPIx-QuoteLike", "no_index" : { "directory" : [ "eg", "inc", "t", "xt" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0.88", "charnames" : "0" } }, "configure" : { "requires" : { "lib" : "0", "strict" : "0", "warnings" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Encode" : "0", "Exporter" : "0", "List::Util" : "0", "PPI::Document" : "1.117", "PPI::Dumper" : "1.117", "Readonly" : "0", "Scalar::Util" : "0", "Text::Tabs" : "0", "base" : "0", "constant" : "0", "perl" : "5.006", "re" : "0", "strict" : "0", "warnings" : "0" } } }, "provides" : { "PPIx::QuoteLike" : { "file" : "lib/PPIx/QuoteLike.pm", "version" : "0.019" }, "PPIx::QuoteLike::Constant" : { "file" : "lib/PPIx/QuoteLike/Constant.pm", "version" : "0.019" }, "PPIx::QuoteLike::Dumper" : { "file" : "lib/PPIx/QuoteLike/Dumper.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token" : { "file" : "lib/PPIx/QuoteLike/Token.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::Control" : { "file" : "lib/PPIx/QuoteLike/Token/Control.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::Delimiter" : { "file" : "lib/PPIx/QuoteLike/Token/Delimiter.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::Interpolation" : { "file" : "lib/PPIx/QuoteLike/Token/Interpolation.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::String" : { "file" : "lib/PPIx/QuoteLike/Token/String.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::Structure" : { "file" : "lib/PPIx/QuoteLike/Token/Structure.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::Unknown" : { "file" : "lib/PPIx/QuoteLike/Token/Unknown.pm", "version" : "0.019" }, "PPIx::QuoteLike::Token::Whitespace" : { "file" : "lib/PPIx/QuoteLike/Token/Whitespace.pm", "version" : "0.019" }, "PPIx::QuoteLike::Utils" : { "file" : "lib/PPIx/QuoteLike/Utils.pm", "version" : "0.019" } }, "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.019", "x_serialization_backend" : "JSON::PP version 4.06" } PPIx-QuoteLike-0.019/META.yml000444000765000024 426714144504537 14754 0ustar00tomstaff000000000000--- abstract: 'Parse Perl string literals and string-literal-like things.' author: - 'Thomas R. Wyant, III F' build_requires: Test::More: '0.88' charnames: '0' configure_requires: lib: '0' strict: '0' warnings: '0' dynamic_config: 1 generated_by: 'Module::Build version 0.4231, 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: - eg - inc - t - xt provides: PPIx::QuoteLike: file: lib/PPIx/QuoteLike.pm version: '0.019' PPIx::QuoteLike::Constant: file: lib/PPIx/QuoteLike/Constant.pm version: '0.019' PPIx::QuoteLike::Dumper: file: lib/PPIx/QuoteLike/Dumper.pm version: '0.019' PPIx::QuoteLike::Token: file: lib/PPIx/QuoteLike/Token.pm version: '0.019' PPIx::QuoteLike::Token::Control: file: lib/PPIx/QuoteLike/Token/Control.pm version: '0.019' PPIx::QuoteLike::Token::Delimiter: file: lib/PPIx/QuoteLike/Token/Delimiter.pm version: '0.019' PPIx::QuoteLike::Token::Interpolation: file: lib/PPIx/QuoteLike/Token/Interpolation.pm version: '0.019' PPIx::QuoteLike::Token::String: file: lib/PPIx/QuoteLike/Token/String.pm version: '0.019' PPIx::QuoteLike::Token::Structure: file: lib/PPIx/QuoteLike/Token/Structure.pm version: '0.019' PPIx::QuoteLike::Token::Unknown: file: lib/PPIx/QuoteLike/Token/Unknown.pm version: '0.019' PPIx::QuoteLike::Token::Whitespace: file: lib/PPIx/QuoteLike/Token/Whitespace.pm version: '0.019' PPIx::QuoteLike::Utils: file: lib/PPIx/QuoteLike/Utils.pm version: '0.019' requires: Carp: '0' Encode: '0' Exporter: '0' List::Util: '0' PPI::Document: '1.117' PPI::Dumper: '1.117' Readonly: '0' Scalar::Util: '0' Text::Tabs: '0' base: '0' constant: '0' perl: '5.006' re: '0' 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.019' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PPIx-QuoteLike-0.019/Makefile.PL000444000765000024 527414144504537 15454 0ustar00tomstaff000000000000use 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 = ( ABSTRACT => $meta->abstract(), AUTHOR => $meta->author(), DISTNAME => $meta->dist_name(), EXE_FILES => $meta->script_files(), NAME => $meta->module_name(), PREREQ_PM => $meta->requires(), PL_FILES => {}, # Prevent old MakeMaker from running Build.PL realclean => { FILES => join( ' ', @{ $meta->add_to_cleanup() } ), }, VERSION_FROM => $meta->version_from(), ); $mmv >= 6.31 and $args{LICENSE} = $meta->license(); if ( $mmv >= 6.4501 ) { $args{META_ADD} = { no_index => $meta->no_index(), $meta->provides(), }; $args{META_MERGE} = $meta->meta_merge(); } $mmv >= 6.4701 and $args{MIN_PERL_VERSION} = $meta->requires_perl(); if ( $mmv >= 6.52 ) { $args{BUILD_REQUIRES} = $meta->build_requires(); $args{CONFIGURE_REQUIRES} = $meta->configure_requires(); } elsif ( $mmv >= 6.5501 ) { $args{BUILD_REQUIRES} = $meta->build_requires(); $args{META_MERGE}{configure_requires} = $meta->configure_requires(); } elsif ( $mmv >= 6.4501 ) { $args{META_MERGE}{build_requires} = $meta->build_requires(); $args{META_MERGE}{configure_requires} = $meta->configure_requires(); } else { foreach my $method ( qw{ configure_requires build_requires } ) { my $req = $meta->$method(); foreach my $key ( keys %{ $req } ) { exists $args{PREREQ_PM}{$key} or $args{PREREQ_PM}{$key} = $req->{$key}; } } } My::Module::Recommend->recommend(); WriteMakefile( %args ); sub MY::postamble { my ( $self, @args ) = @_; my $test = $self->test_via_harness( '$(FULLPERLRUN)', '$(TEST_FILES)' ); my $structural_test = $self->test_via_harness( '$(FULLPERLRUN)', '$(STRUCTURAL_TEST_FILES)' ); foreach ( $test, $structural_test ) { s/ \s+ \z //smx; s/ \A \s+ //smx; } my $optionals = join ',', My::Module::Recommend->optionals(); return <<"EOD"; STRUCTURAL_TEST_FILES = xt/author/*.t functional_test :: pure_all \$(NOECHO) \$(ECHO) \$(NOECHO) \$(ECHO) functional_test AUTHOR_TESTING=1 $test optionals_test :: pure_all \$(NOECHO) \$(ECHO) \$(NOECHO) \$(ECHO) optionals_test AUTHOR_TESTING=1 PERL5OPT=-MTest::Without::Module=$optionals $test structural_test :: pure_all \$(NOECHO) \$(ECHO) \$(NOECHO) \$(ECHO) structural_test AUTHOR_TESTING=1 $structural_test authortest :: functional_test optionals_test structural_test testcover :: pure_all cover -test -ignore_re=inc/ -ignore_re=eg/ .PHONY: functional_test optionals_test structural_test authortest testcover EOD } # ex: set textwidth=72 : PPIx-QuoteLike-0.019/README000444000765000024 320714144504537 14354 0ustar00tomstaff000000000000PPIx-QuoteLike is Copyright (C) 2016-2021 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. PPIx-QuoteLike-0.019/LICENSES000755000765000024 014144504537 14542 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/LICENSES/Artistic000444000765000024 1373714144504537 16437 0ustar00tomstaff000000000000 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 PPIx-QuoteLike-0.019/LICENSES/Copying000444000765000024 3053014144504537 16253 0ustar00tomstaff000000000000 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! PPIx-QuoteLike-0.019/eg000755000765000024 014144504537 13730 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/eg/README000444000765000024 145214144504537 14747 0ustar00tomstaff000000000000This 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 : PPIx-QuoteLike-0.019/eg/pqldump000555000765000024 745714144504537 15512 0ustar00tomstaff000000000000#!/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.019'; my %opt; GetOptions( \%opt, qw{ encoding=s indent=i locations! margin=i perl_version|perl-version! ppi! short! 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 locations margin perl_version ppi short 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 -locations If this Boolean option is true the locations of the tokens will be dumped. =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 -short If this option is asserted, leading C<'PPIx::QuoteLike::'> will be removed from the class names in the output. The default is C<-noshort>. =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-2021 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 : PPIx-QuoteLike-0.019/eg/variables000555000765000024 467214144504537 15774 0ustar00tomstaff000000000000#!/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.019'; 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>. B that the C<__variables()> subroutine is discouraged, and may be deprecated and removed. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2019-2021 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 : PPIx-QuoteLike-0.019/inc000755000765000024 014144504537 14106 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/inc/My000755000765000024 014144504537 14473 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/inc/My/Module000755000765000024 014144504537 15720 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/inc/My/Module/Build.pm000444000765000024 1140014144504537 17466 0ustar00tomstaff000000000000package 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 ) = @_; # Arguments unused my ( $self ) = @_; $self->depends_on( qw{ functional_test optionals_test structural_test } ); return; } sub ACTION_functional_test { my ( $self ) = @_; local $ENV{AUTHOR_TESTING} = 1; $self->my_depends_on(); print <<'EOD'; functional_test AUTHOR_TESTING=1 EOD # Not depends_on(), because that is idempotent. But we really do # want to run 'test' more than once if we do more than one of the # *_test actions. $self->dispatch( 'test' ); return; } sub ACTION_optionals_test { my ( $self ) = @_; my $optionals = join ',', My::Module::Recommend->optionals(); local $ENV{AUTHOR_TESTING} = 1; local $ENV{PERL5OPT} = "-MTest::Without::Module=$optionals"; $self->my_depends_on(); print <<"EOD"; optionals_test AUTHOR_TESTING=1 PERL5OPT=-MTest::Without::Module=$optionals EOD # Not depends_on(), because that is idempotent. But we really do # want to run 'test' more than once if we do more than one of the # *_test actions. $self->dispatch( 'test' ); return; } sub ACTION_structural_test { my ( $self ) = @_; local $ENV{AUTHOR_TESTING} = 1; $self->my_depends_on(); print <<'EOD'; structural_test AUTHOR_TESTING=1 EOD my $structural_test_files = 'xt/author'; if ( $self->can( 'args' ) ) { my @arg = $self->args(); for ( my $inx = 0; $inx < $#arg; $inx += 2 ) { $arg[$inx] =~ m/ \A structural[-_]test[-_]files \z /smx or next; $structural_test_files = $arg[ $inx + 1 ]; last; } } $self->test_files( $structural_test_files ); # Not depends_on(), because that is idempotent. But we really do # want to run 'test' more than once if we do more than one of the # *_test actions. $self->dispatch( 'test' ); return; } sub my_depends_on { my ( $self ) = @_; my @depends_on; -d 'blib' or push @depends_on, 'build'; -e 'META.json' or push @depends_on, 'distmeta'; @depends_on and $self->depends_on( @depends_on ); 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 actions: =over =item authortest This action does nothing on its own, but it depends on L, L, and L, so invoking it runs all these tests. =item functional_test This action is the same as C, but the C environment variable is set to true. This test is sensitive to both the C argument and the C argument. =item optionals_test This action is the same as C, but the C environment variable is set to true, and the C environment variable is set to C<-MTest::Without::Module=...>, where the elipsis is a comma-separated list of all optional modules. This test is sensitive to both the C argument and the C argument. =item structural_test This action is the same as C, but the C environment variable is set to true, and the test files are F. Some of these tests require modules that are not named as requirements. Such tests should disable themselves if the required modules are not present. This test is sensitive to the C argument and the C argument, which specifies test files to run and defaults to F. The use of C requires at least L version C<0.26>. =back =head1 SUPPORT Support is by the author. Please file bug reports at L, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/inc/My/Module/Meta.pm000444000765000024 1750414144504537 17330 0ustar00tomstaff000000000000package 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 abstract { return 'Parse Perl string literals and string-literal-like things.'; } sub add_to_cleanup { return [ qw{ cover_db } ]; } sub author { return 'Thomas R. Wyant, III F'; } sub build_requires { return +{ 'Test::More' => 0.88, # Because of done_testing(). charnames => 0, }; } sub configure_requires { return +{ 'lib' => 0, 'strict' => 0, 'warnings' => 0, }; } sub dist_name { return 'PPIx-QuoteLike'; } sub distribution { my ( $self ) = @_; return $self->{distribution}; } sub license { return 'perl'; } sub meta_merge { my ( undef, @extra ) = @_; return { 'meta-spec' => { version => 2, }, dynamic_config => 1, resources => { bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=PPIx-QuoteLike', # web => 'https://github.com/trwyant/perl-PPIx-QuoteLike/issues', 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', }, }, @extra, }; } sub module_name { return 'PPIx::QuoteLike'; } sub no_index { return +{ directory => [ qw{ eg inc t xt } ], }; } sub provides { my $provides; local $@ = undef; eval { require CPAN::Meta; require ExtUtils::Manifest; require Module::Metadata; my $manifest; { local $SIG{__WARN__} = sub {}; $manifest = ExtUtils::Manifest::maniread(); } keys %{ $manifest || {} } or return; # Skeleton so we can use should_index_file() and # should_index_package(). my $meta = CPAN::Meta->new( { name => 'Euler', version => 2.71828, no_index => no_index(), }, ); # The Module::Metadata docs say not to use # package_versions_from_directory() directly, but the 'files =>' # version of provides() is broken, and has been known to be so # since 2014, so it's not getting fixed any time soon. So: foreach my $fn ( sort keys %{ $manifest } ) { $fn =~ m/ [.] pm \z /smx or next; my $pvd = Module::Metadata->package_versions_from_directory( undef, [ $fn ] ); foreach my $pkg ( keys %{ $pvd } ) { $meta->should_index_package( $pkg ) and $meta->should_index_file( $pvd->{$pkg}{file} ) and $provides->{$pkg} = $pvd->{$pkg}; } } 1; } or return; return ( provides => $provides ); } 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, 'Readonly' => 0, 'Scalar::Util' => 0, 'Text::Tabs' => 0, base => 0, constant => 0, re => 0, strict => 0, warnings => 0, @extra, }; } sub requires_perl { return 5.006; } sub script_files { return [ ]; } sub version_from { return 'lib/PPIx/QuoteLike.pm'; } 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 abstract This method returns the distribution's abstract. =head2 add_to_cleanup This method returns a reference to an array of files to be added to the cleanup. =head2 author This method returns the name of the distribution author =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 configure_requires use YAML; print Dump( $meta->configure_requires() ); This method returns a reference to a hash describing the modules required to configure the package, suitable for use in a F C key, or a F C<< {META_MERGE}->{configure_requires} >> or C key. =head2 dist_name This method returns the distribution name. =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 license This method returns the distribution's license. =head2 meta_merge use YAML; print Dump( $meta->meta_merge() ); This method returns a reference to a hash describing the meta-data which has to be provided by making use of the builder's C functionality. This includes the C and C data. Any arguments will be appended to the generated array. =head2 module_name This method returns the name of the module the distribution is based on. =head2 no_index This method returns the names of things which are not to be indexed by CPAN. =head2 provides use YAML; print Dump( [ $meta->provides() ] ); This method attempts to load L. If this succeeds, it returns a C entry suitable for inclusion in L data (i.e. C<'provides'> followed by a hash reference). If it can not load the required module, it returns nothing. =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. =head2 script_files This method returns a reference to an array containing the names of script files provided by this distribution. This array may be empty. =head2 version_from This method returns the name of the distribution file from which the distribution's version is to be derived. =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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/inc/My/Module/Recommend.pm000444000765000024 465614144504537 20337 0ustar00tomstaff000000000000package 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 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 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2014-2021 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 : PPIx-QuoteLike-0.019/inc/My/Module/Recommend000755000765000024 014144504537 17631 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/inc/My/Module/Recommend/Any.pm000444000765000024 1052214144504537 21073 0ustar00tomstaff000000000000package 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.019'; 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, L, or in electronic mail to the author. =head1 AUTHOR Tom Wyant (wyant at cpan dot org) =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib000755000765000024 014144504537 14103 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/lib/PPIx000755000765000024 014144504537 14723 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike.pm000444000765000024 11706114144504537 17366 0ustar00tomstaff000000000000package PPIx::QuoteLike; use 5.006; use strict; use warnings; use Carp; use Encode (); use List::Util (); use PPIx::QuoteLike::Constant qw{ ARRAY_REF LOCATION_LINE LOCATION_CHARACTER LOCATION_COLUMN LOCATION_LOGICAL_LINE LOCATION_LOGICAL_FILE 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 PPIx::QuoteLike::Utils qw{ column_number line_number logical_filename logical_line_number statement visual_column_number __instance __match_enclosed __matching_delimiter }; use Scalar::Util (); use Text::Tabs (); our $VERSION = '0.019'; use constant CLASS_CONTROL => 'PPIx::QuoteLike::Token::Control'; use constant CLASS_DELIMITER => 'PPIx::QuoteLike::Token::Delimiter'; use constant CLASS_INTERPOLATION => 'PPIx::QuoteLike::Token::Interpolation'; use constant CLASS_STRING => 'PPIx::QuoteLike::Token::String'; use constant CLASS_STRUCTURE => 'PPIx::QuoteLike::Token::Structure'; use constant CLASS_UNKNOWN => 'PPIx::QuoteLike::Token::Unknown'; use constant CLASS_WHITESPACE => 'PPIx::QuoteLike::Token::Whitespace'; use constant CODE_REF => ref sub {}; use constant ILLEGAL_FIRST => 'Tokenizer found illegal first characters'; use constant MISMATCHED_DELIM => 'Tokenizer found mismatched delimiters'; use constant NO_INDENTATION => 'No indentation string found'; { 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; if ( defined $arg{postderef} ) { $class->_deprecation_notice( attribute => 'postderef' ); } else { $arg{postderef} = 1; } if ( $arg{location} ) { ARRAY_REF eq ref $arg{location} or croak q; foreach my $inx ( 0 .. 3 ) { $arg{location}[$inx] =~ m/ [^0-9] /smx and croak "Argument 'location' element $inx must be an unsigned integer"; } } if ( ! defined $arg{index_locations} ) { $arg{index_locations} = !! $arg{location} || __instance( $source, 'PPI::Element' ); } my $self = { index_locations => $arg{index_locations}, children => \@children, encoding => $arg{encoding}, failures => 0, location => $arg{location}, postderef => ( $arg{postderef} ? 1 : 0 ), source => $source, }; bless $self, ref $class || $class; defined( my $string = $self->_stringify_source( $source ) ) or return; my ( $type, $gap, $gap2, $content, $end_delim, $indented, $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->_make_token( CLASS_UNKNOWN, $string, error => 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* ) ( ~? ) ( \s* ) ( [\\]? \w+ | $match_sq | $match_dq | $match_bt ) \n /smxgc ) { ( $type, $gap, $indented, $gap2, $start_delim ) = ( $1, $2, $3, $4, $5 ); $arg{trace} and warn "Initial match '$type$start_delim$gap$indented'\n"; $self->{interpolates} = $start_delim !~ m/ \A [\\'] /smx; $content = substr $string, ( pos $string || 0 ); $end_delim = _unquote( $start_delim ); # NOTE that the indentation is specifically space or tab # only. if ( $content =~ s/ ^ ( [ \t]* ) \Q$end_delim\E \n? \z //smx ) { # NOTE PPI::Token::HereDoc does not preserve the # indentation of an indented here document, so the # indentation will appear to be '' if we came from PPI. if ( $indented ) { # Version per perldelta.pod for that release. $self->{perl_version_introduced} = '5.025007'; $self->{indentation} = "$1"; $self->{_indentation_re} = qr/ ^ \Q$self->{indentation}\E /smx; } } else { $end_delim = ''; } $self->{start} = [ $self->_make_token( CLASS_DELIMITER, $start_delim ), $self->_make_token( CLASS_WHITESPACE, "\n" ), ]; # Don't instantiate yet -- we'll do them at the end. $self->{finish} = [ [ CLASS_DELIMITER, $end_delim ], [ CLASS_WHITESPACE, "\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->_make_token( CLASS_UNKNOWN, $string, error => ILLEGAL_FIRST ) ); } $self->{interpolates} = $self->{interpolates} ? 1 : 0; defined or $_ = '' for $indented, $gap2; $self->{type} = [ $self->_make_token( CLASS_STRUCTURE, $type ), length $gap ? $self->_make_token( CLASS_WHITESPACE, $gap ) : (), length $indented ? $self->_make_token( CLASS_STRUCTURE, $indented ) : (), length $gap2 ? $self->_make_token( CLASS_WHITESPACE, $gap2 ) : (), ]; $self->{start} ||= [ $self->_make_token( CLASS_DELIMITER, $start_delim ), ]; $arg{trace} and warn "Without delimiters: '$content'\n"; # We accumulate data and manufacure tokens at the end to reduce # the overhead involved in merging strings. if ( $self->{interpolates} ) { push @children, [ '' => '' ]; # Prime the pump while ( 1 ) { if ( $content =~ m/ \G ( \\ [ULulQEF] ) /smxgc ) { push @children, [ CLASS_CONTROL, "$1" ]; } elsif ( $content =~ m/ \G ( \\ N [{] ( [^}]+ ) [}] ) /smxgc ) { # 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. { # TODO use $re = __match_enclosed( '{' ); # } 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 ? [ CLASS_UNKNOWN, $seq, error => "Unknown charname '$name'" ] : [ CLASS_STRING, $seq ]; # NOTE in the following that I do not read perldata as # saying there can be space between the sigil and the # variable name, but Perl itself seems to accept it as # of 5.30.1. } elsif ( $content =~ m/ \G ( [\$\@] \#? \$* ) /smxgc ) { push @children, $self->_interpolation( "$1", $content ); } elsif ( $content =~ m/ \G ( \\ . | [^\\\$\@]+ ) /smxgc ) { push @children, $self->_remove_here_doc_indentation( "$1", sibling => \@children, ); } else { last; } } @children = _merge_strings( @children ); shift @children; # remove the priming # Make the tokens, at long last. foreach ( @children ) { $_ = $self->_make_token( @{ $_ } ); } } else { length $content and push @children, map { $self->_make_token( @{ $_ } ) } _merge_strings( $self->_remove_here_doc_indentation( $content ) ); } # Add the indentation before the end marker, if needed $self->{indentation} and push @children, $self->_make_token( CLASS_WHITESPACE, $self->{indentation} ); if ( $self->{finish} ) { # If we already have something here it is data, not objects. foreach ( @{ $self->{finish} } ) { $_ = $self->_make_token( @{ $_ } ); } } else { $self->{finish} = [ $self->_make_token( CLASS_DELIMITER, $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 }; } # $self->_deprecation_notice( $type, $name ); # # This method centralizes deprecation. Type is 'attribute' or # 'method'. Deprecation is driven of the %deprecate hash. Values # are: # false - no warning # 1 - warn on first use # 2 - warn on each use # 3 - die on each use. # # $self->_deprecation_in_progress( $type, $name ) # # This method returns true if the deprecation is in progress. In # fact it returns the deprecation level. { my %deprecate = ( attribute => { postderef => 3, }, ); sub _deprecation_notice { my ( undef, $type, $name, $repl ) = @_; # Invocant unused $deprecate{$type} or return; $deprecate{$type}{$name} or return; my $msg = sprintf 'The %s %s is %s', $name, $type, $deprecate{$type}{$name} > 2 ? 'removed' : 'deprecated'; defined $repl and $msg .= "; use $repl instead"; $deprecate{$type}{$name} >= 3 and croak $msg; warnings::enabled( 'deprecated' ) and carp $msg; $deprecate{$type}{$name} == 1 and $deprecate{$type}{$name} = 0; return; } } 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 indentation { my ( $self ) = @_; return $self->{indentation}; } sub interpolates { my ( $self ) = @_; return $self->{interpolates}; } sub location { my ( $self ) = @_; return $self->type()->location(); } sub _make_token { my ( $self, $class, $content, %arg ) = @_; my $token = $class->__new( content => $content, %arg ); CLASS_UNKNOWN eq $class and $self->{failures}++; $self->{index_locations} and $self->_update_location( $token ); return $token; } sub _update_location { my ( $self, $token ) = @_; $token->{location} # Idempotent and return; my $loc = $self->{_location} ||= do { my %loc = ( line_content => '', location => $self->{location}, ); if ( __instance( $self->{source}, 'PPI::Element' ) ) { $loc{location} ||= $self->{source}->location(); if ( my $doc = $self->{source}->document() ) { $loc{tab_width} = $doc->tab_width(); } } $loc{tab_width} ||= 1; \%loc; }; $loc->{location} or return; $token->{location} = [ @{ $loc->{location} } ]; if ( defined( my $content = $token->content() ) ) { if ( my $newlines = $content =~ tr/\n/\n/ ) { $loc->{location}[LOCATION_LINE] += $newlines; $loc->{location}[LOCATION_LOGICAL_LINE] += $newlines; $content =~ s/ .* \n //smx; $loc->{location}[LOCATION_CHARACTER] = $loc->{location}[LOCATION_COLUMN] = 1; $loc->{line_content} = ''; } $loc->{location}[LOCATION_CHARACTER] += length $content; $loc->{line_content} .= $content; local $Text::Tabs::tabstop = $loc->{tab_width}; $loc->{location}[LOCATION_COLUMN] = 1 + length Text::Tabs::expand( $loc->{line_content} ); } return; } sub parent { return; } 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 ) = @_; # TODO postderef - eventually this goes away. __PACKAGE__ eq caller or $self->_deprecation_notice( attribute => 'postderef' ); 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 top { my ( $self ) = @_; return $self; } 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() ) { 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 ( undef, $sigil ) = @_; return [ CLASS_INTERPOLATION, $sigil ]; }, '$' => sub { # Called if we find (e.g.) '$@' my ( undef, $sigil ) = @_; $_[2] =~ m/ \G ( [\@] ) /smxgc or return; return [ CLASS_INTERPOLATION, "$sigil$1" ]; }, '@' => sub { # Called if we find '@@'. my ( undef, $sigil ) = @_; return [ CLASS_STRING, $sigil ]; }, ); sub _interpolation { ## no critic (RequireArgUnpacking) my ( $self, $sigil ) = @_; # Argument $_[2] is $content, but we can't unpack it because we # need the caller to see any changes to pos(). if ( $_[2] =~ m/ \G (?= \{ ) /smxgc ) { # variable name enclosed in {} my $delim_re = __match_enclosed( qw< { > ); $_[2] =~ m/ \G ( $delim_re ) /smxgc and return [ CLASS_INTERPOLATION, "$sigil$1" ]; $_[2] =~ m/ \G ( .* ) /smxgc and return [ CLASS_UNKNOWN, "$sigil$1", error => MISMATCHED_DELIM ]; confess 'Failed to match /./'; } if ( $_[2] =~ m< \G ( @{[ VARIABLE_RE ]} ) >smxgco ) { # variable name not enclosed in {} my $interp = "$sigil$1"; while ( $_[2] =~ m/ \G ( (?: -> )? ) (?= ( [[{] ) ) /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 ( [ CLASS_INTERPOLATION, $interp ], [ CLASS_UNKNOWN, "$1", error => MISMATCHED_DELIM ], ); } } if ( $self->postderef() and defined( my $deref = _match_postderef( $_[2] ) ) ) { $interp .= $deref; } return [ CLASS_INTERPOLATION, $interp ]; } my $code; $code = $special{$sigil} and my $elem = $code->( $self, $sigil, $_[2] ) or return [ CLASS_UNKNOWN, $sigil, error => '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; } { my %allow_subscr = map { $_ => 1 } qw{ % @ }; # Match a postfix deref at the current position in the argument. If # a match occurs it is returned, and the current position is # updated. If not, nothing is returned, and the current position in # the argument remains unchanged. # This would all be much easier if I could count on Perl 5.10 sub _match_postderef { ## no critic (RequireArgUnpacking) my $pos = pos $_[0]; $_[0] =~ m/ \G ( -> ) ( \$ \# | [\$\@%&*] ) /smxgc or return; my $match = "$1$2"; my $sigil = $2; $_[0] =~ m/ \G ( [*] ) /smxgc and return "$match$1"; if ( $allow_subscr{$sigil} && $_[0] =~ m/ \G (?= ( [[{] ) ) /smxgc # }] ) { my $re = __match_enclosed( "$1" ); $_[0] =~ m/ \G $re /smxgc and return "$match$1"; } pos $_[0] = $pos; return; } } # For various reasons we may get consecutive literals -- typically # strings. We want to merge these. The arguments are array refs, with # the class name of the token in [0] and the content in [1]. I know of # no way we can generate consecutive white space tokens, but if I did I # would want them merged. # # NOTE that merger loses all attributes of the second token, so we MUST # NOT merge CLASS_UNKNOWN tokens, or any class that might have # attributes other than content. { my %can_merge = map { $_ => 1 } CLASS_STRING, CLASS_WHITESPACE; sub _merge_strings { my @arg = @_; my @rslt; foreach my $elem ( @arg ) { if ( @rslt && $can_merge{$elem->[0]} && $elem->[0] eq $rslt[-1][0] ) { $rslt[-1][1] .= $elem->[1]; } else { push @rslt, $elem; } } return @rslt; } } # If we're processing an indented here document, strings must be split # on new lines and un-indented. We return array refs rather than # objects because we may be called before we're ready to build the # objects. sub _remove_here_doc_indentation { my ( $self, $string, %arg ) = @_; # NOTE that we rely on the fact that both undef (not indented) and # '' (indented by zero characters) evaluate false. $self->{indentation} or return [ CLASS_STRING, $string ]; my $ignore_first; if ( $arg{sibling} ) { # Because the calling code primes the pump, @sibling will never # be empty, even when processing the first token. So: # * The pump-priming specifies class '', so if that is what we # see we must process the first line; otherwise # * If the previous token is a string ending in "\n", we must # process the first line. $ignore_first = '' ne $arg{sibling}[-1][0] && ( CLASS_STRING ne $arg{sibling}[-1][0] || $arg{sibling}[-1][1] !~ m/ \n \z /smx ); } else { # Without @sibling, we unconditionally process the first line. $ignore_first = 0; } my @rslt; foreach ( split qr/ (?<= \n ) /smx, $string ) { if ( $ignore_first ) { push @rslt, [ CLASS_STRING, "$_" ]; $ignore_first = 0; } else { if ( "\n" eq $_ ) { push @rslt, [ CLASS_STRING, "$_" ], ; } elsif ( s/ ( $self->{_indentation_re} ) //smx ) { push @rslt, [ CLASS_WHITESPACE, "$1" ], [ CLASS_STRING, "$_" ], ; } else { push @rslt, [ CLASS_UNKNOWN, "$_", error => NO_INDENTATION ], ; } } } return @rslt; } 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 _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. The parse is fairly straightforward, and a little poking around with F should show how it normally goes. But there is at least one quote-like thing that probably needs some explanation. =head2 Indented Here Documents These were introduced in Perl 5.25.7 (November 2016) but not recognized by this module until its version 0.015 (February 2021). The indentation is parsed as L objects, provided it is at least one character wide, otherwise it is not represented in the parse. That is to say, <<~EOD How doth the little crocodile Improve his shining tail EOD will have the three indentations represented by whitespace objects and each line of the literal represented by its own string object, but <<~EOD How doth the little crocodile Improve his shining tail EOD will parse the same as the non-indented version, except for the addition of the token representing the C<'~'>. L is ahead of this module, and recognized indented here documents as of its version 1.246 (May 2019). Unfortunately, as of version 1.270 the indent gets lost in the parse, so a C object initialized from such a L will be seen as having an indentation of C<''> regardless of the actual indentation in the source. I believe this restriction will go away when L is resolved. =head1 DEPRECATION NOTICE The L argument to L is being put through a deprecation cycle and retracted. After the retraction, postfix dereferences will always be recognized. This is the default behaviour now. Starting with version 0.012_01, the first use of this argument warned. With version 0.016_01, all uses will warn. With version 0.017_01 all uses will be fatal. With the first release after April 15 2022, all mention of this argument will be removed. =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. Indented here documents were not supported by this class until version C<0.015>. 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 index_locations This Boolean argument determines whether the locations of the tokens should be computed. It defaults to true if the C<$source> argument is a L or if the C argument was provided, and false otherwise. =item location This argument is a reference to an array compatible with that returned by the L location() method. It defaults to the location of the C<$source> argument if that was a L, otherwise no locations will be available. =item postderef B. See L above for the details. This Boolean argument determines whether postfix dereferencing is recognized in interpolation. If unspecified, or specified as C, it defaults to true. In version 0.012 it defaulted to the value of C<$PPIx::QuoteLike::DEFAULT_POSTDEREF>. This variable was not exported, and was true by default. =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 column_number This method returns the column number of the first character in the element, or C if that can not be determined. =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 indentation This method returns the indentation string if the object represents an indented here document, or C if it represents anything else, including an unindented here document. B that if indented syntax is used but the here document is not in fact indented, this will return C<''>, which evaluates to false. =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 line_number This method returns the line number of the first character in the element, or C if that can not be determined. =head2 location This method returns a reference to an array describing the position of the string, or C if the location is unavailable. The array is compatible with the corresponding L method. =head2 logical_filename This method returns the logical file name (taking C<#line> directives into account) of the file containing first character in the element, or C if that can not be determined. =head2 logical_line_number This method returns the logical line number (taking C<#line> directives into account) of the first character in the element, or C if that can not be determined. =head2 parent This method returns nothing, since the invocant is only used at the top of the object hierarchy. =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 statement This method returns the L that contains this string, or nothing if the statement can not be determined. In general this method will return something only under the following conditions: =over =item * The string is contained in a L object; =item * That object was initialized from a L; =item * The L is contained in a statement. =back =head2 top This method returns the top of the hierarchy -- in this case, the invocant. =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(); B that this method is discouraged, and may well be deprecated and removed. My problem with it is that it returns variable names rather than L objects, leaving you no idea how the variables are used. It was originally written for the benefit of L, but has proven inadequate to that policy's needs. 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. =head2 visual_column_number This method returns the visual column number (taking tabs into account) of the first character in the element, or C if that can not be determined. =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 PPI Restrictions As of version 0.015 of this module, the only known instance of this is the handling of indented here documents, as discussed above under L. =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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike000755000765000024 014144504537 16625 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Constant.pm000444000765000024 1036214144504537 21133 0ustar00tomstaff000000000000package PPIx::QuoteLike::Constant; use 5.006; use strict; use warnings; use Carp; use base qw{ Exporter }; our $VERSION = '0.019'; no warnings qw{ once }; # For older Perls. 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 }; use warnings qw{ once }; our @EXPORT_OK = qw{ ARRAY_REF MINIMUM_PERL HAVE_PPIX_REGEXP LOCATION_LINE LOCATION_CHARACTER LOCATION_COLUMN LOCATION_LOGICAL_LINE LOCATION_LOGICAL_FILE SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS VARIABLE_RE @CARP_NOT }; use constant ARRAY_REF => ref []; # 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; }; }; # Location constants. Must align with PPI use constant LOCATION_LINE => 0; use constant LOCATION_CHARACTER => 1; use constant LOCATION_COLUMN => 2; use constant LOCATION_LOGICAL_LINE => 3; use constant LOCATION_LOGICAL_FILE => 4; 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 ARRAY_REF This manifest constant contains the value of C, i.e. C<'ARRAY'>. =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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Dumper.pm000444000765000024 3100414144504537 20572 0ustar00tomstaff000000000000package PPIx::QuoteLike::Dumper; use 5.006; use strict; use warnings; use Carp; use PPI::Document; use PPIx::QuoteLike; use PPIx::QuoteLike::Constant qw{ @CARP_NOT }; use PPIx::QuoteLike::Utils qw{ __instance }; use Scalar::Util (); our $VERSION = '0.019'; use constant SCALAR_REF => ref \0; { my $default = { encoding => undef, file => undef, indent => 2, locations => 0, margin => 0, perl_version => 0, ppi => 0, short => 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, __instance( $source, 'PPI::Element' ) ? () : ( location => [ 1, 1, 1, 1, -f $source ? $source : undef ], ), map { $_ => $arg{$_} } qw{ encoding }, ) 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", $self->_class_name( $obj ), $string, _format_attr( $obj, qw{ encoding failures interpolates indentation } ), $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 $locn = $self->{locations} ? __instance( $elem, 'PPIx::QuoteLike::Token' ) ? sprintf '[ % 4d, % 3d, % 3d ] ', $elem->logical_line_number(), $elem->column_number(), $elem->visual_column_number() : ' ' x 19 : ''; my @line = ( $self->_class_name( $elem ), _quote( $elem->content() ), $self->_perl_version( $elem ), $self->_variables( $elem ), ); my @ppi; @ppi = $self->_ppi( $elem ) and shift @ppi; # Ignore PPI::Document foreach ( @ppi ) { if ( $self->{locations} ) { s/ ( [0-9]+ \s+ \] ) /$1 /smxg or substr $_, 0, 0, ' '; } else { substr $_, 0, 0, ' '; } } my $leader = "$locn$indent"; foreach ( join( "\t", @line ), @ppi ) { push @rslt, "$leader$_"; # $locn = $self->{locations} ? ' ' x 19 : ''; $leader = ''; } } 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(); } sub _class_name { my ( $self, $obj ) = @_; my $class = ref $obj; $self->{short} and $class =~ s/ \A PPIx::QuoteLike:: //smx; return $class; } { # 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; 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 = map { $_->content() } grep { $_->significant() } $obj->$method( @arg ) or return '?'; return join '', @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 ) = @_; $self->{ppi} and $elem->can( 'ppi' ) or return; require PPI::Dumper; # PPI::Dumper reports line_number(), but I want # logical_line_number(). There is no configuration for this, but the # interface is public, so I mung it to do what I want. my $locn = PPI::Element->can( 'location' ); local *PPI::Element::location = sub { my $loc = $locn->( @_ ); $loc->[0] = $loc->[3]; return $loc; }; my $dumper = PPI::Dumper->new( $elem->ppi(), map { $_ => $self->{$_} } qw{ indent locations }, ); return $dumper->list(); } 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 "; } $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} or return; my @var = $elem->variables() or return; return join ',', sort @var; } 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 B. See L in L for the details. 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 short Boolean If true, leading C<'PPIx::QuoteLike::'> will be removed from the class names in the output. =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. =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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token.pm000444000765000024 2033314144504537 20421 0ustar00tomstaff000000000000package PPIx::QuoteLike::Token; use 5.006; use strict; use warnings; use Carp; use PPIx::QuoteLike::Constant qw{ MINIMUM_PERL @CARP_NOT }; use PPIx::QuoteLike::Utils qw{ column_number line_number logical_filename logical_line_number statement visual_column_number }; our $VERSION = '0.019'; # 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 location { my ( $self ) = @_; return $self->{location} ? [ @{ $self->{location} } ] : undef; } 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; } sub top { my ( $self ) = @_; my $kid = $self; while ( defined ( my $parent = $kid->parent() ) ) { $kid = $parent; } return $kid; } sub variables { 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 column_number This method returns the column number of the first character in the element, or C if that can not be determined. =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 line_number This method returns the line number of the first character in the element, or C if that can not be determined. =head2 location This method returns a reference to an array describing the position of the element in the string, or C if the location is unavailable. The array is compatible with the corresponding L method. =head2 logical_filename This method returns the logical file name (taking C<#line> directives into account) of the file containing first character in the element, or C if that can not be determined. =head2 logical_line_number This method returns the logical line number (taking C<#line> directives into account) of the first character in the element, or C if that can not be determined. =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. =head2 statement This method returns the L that contains this token, or nothing if the statement can not be determined. In general this method will return something only under the following conditions: =over =item * The token is contained in a L object; =item * That object was initialized from a L; =item * The L is contained in a statement. =back =head2 top This method returns the top of the hierarchy. =head2 variables say "Interpolates $_" for $elem->variables(); B that this method is discouraged, and may well be deprecated and removed. My problem with it is that it returns variable names rather than L objects, leaving you no idea how the variables are used. It was originally written for the benefit of L, but has proven inadequate to that policy's needs. This convenience method returns all interpolated variables. Each is returned only once, and they are returned in no particular order. B that because this class does not represent an interpolation, this method returns nothing. =head2 visual_column_number This method returns the visual column number (taking tabs into account) of the first character in the element, or C if that can not be determined. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Utils.pm000444000765000024 4574414144504537 20456 0ustar00tomstaff000000000000package PPIx::QuoteLike::Utils; use 5.006; use strict; use warnings; use base qw{ Exporter }; use Carp; use PPIx::QuoteLike::Constant qw{ HAVE_PPIX_REGEXP LOCATION_LINE LOCATION_CHARACTER LOCATION_COLUMN LOCATION_LOGICAL_LINE LOCATION_LOGICAL_FILE VARIABLE_RE @CARP_NOT }; use Readonly; use Scalar::Util (); use constant LEFT_CURLY => q<{>; use constant RIGHT_CURLY => q<}>; our @EXPORT_OK = qw{ column_number is_ppi_quotelike_element line_number logical_filename logical_line_number statement visual_column_number __instance __match_enclosed __matching_delimiter __normalize_interpolation_for_ppi __variables }; our $VERSION = '0.019'; # Readonly::Scalar my $BRACED_RE => __match_enclosed( LEFT_CURLY ); Readonly::Scalar my $BRACKETED_RE => __match_enclosed( '[' ); # ] Readonly::Scalar my $PARENTHESIZED_RE => __match_enclosed( '(' ); # ) Readonly::Scalar my $SIGIL_AND_CAST_RE => qr/ \$ \# \$* | [\@\$] \$* /smx; # The following is an interpretation of perldata Identifier Parsing for # Perls before 5.10. Readonly::Scalar my $SYMBOL_NAME_RE => qr/ \^? (?: (?: :: )* '? \w+ (?: (?: (?: :: )+ '? | (?: :: )* ' ) \w+ )* (?: :: )* | [[:punct:]] ) /smx; sub column_number { my ( $self ) = @_; return ( $self->location() || [] )->[LOCATION_CHARACTER]; } { my @relevant_ppi_classes = qw{ PPI::Token::Quote PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Readline PPI::Token::HereDoc }; sub is_ppi_quotelike_element { my ( $elem ) = @_; ref $elem or return; Scalar::Util::blessed( $elem ) or return; foreach my $class ( @relevant_ppi_classes ) { $elem->isa( $class ) and return 1; } return; } # 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 ) = @_; # In case we need to manufacture any. require PPIx::QuoteLike; 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 ( @relevant_ppi_classes ) { 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; } sub __instance { my ( $object, $class ) = @_; Scalar::Util::blessed( $object ) or return; return $object->isa( $class ); } # 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; } sub line_number { my ( $self ) = @_; return ( $self->location() || [] )->[LOCATION_LINE]; } sub logical_filename { my ( $self ) = @_; return ( $self->location() || [] )->[LOCATION_LOGICAL_FILE]; } sub logical_line_number { my ( $self ) = @_; return ( $self->location() || [] )->[LOCATION_LOGICAL_LINE]; } { our %REGEXP_CACHE; my %matching_bracket; BEGIN { %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} ) { # 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)/sm; } 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 __normalize_interpolation_for_ppi { ( local $_ ) = @_; # "@{[ foo() ]}" => 'foo()' if ( m/ \A \@ [{] \s* ( $BRACKETED_RE ) \s* [}] \z /smx ) { $_ = $1; s/ \A [[] \s* //smx; s/ \s* []] \z //smx; return "$_"; } # "${\( foo() )}" => 'foo()' if ( m/ \A \$ [{] \s* \\ \s* ( $PARENTHESIZED_RE ) \s* [}] \z /smx ) { $_ = $1; s/ \A [(] \s* //smx; s/ \s* [)] \z //smx; return "$_"; } # "${foo}" => '$foo' m/ \A ( $SIGIL_AND_CAST_RE ) \s* [{] \s* ( $SYMBOL_NAME_RE ) \s* [}] \z /smx and return "$1$2"; # "${foo{bar}}" => '$foo{bar}' # NOTE that this is a warning, and so not done. # if ( m/ \A ( $SIGIL_AND_CAST_RE ) (?= [{] ) ( $BRACED_RE ) /smx ) { # ( my $sigil, local $_ ) = ( $1, $2 ); # s/ \A [{] \s* //smx; # s/ \s* [}] \z //smx; # return "$sigil$_"; # } # "$ foo->{bar}" => '$foo->{bar}' if ( m/ \A ( $SIGIL_AND_CAST_RE ) \s+ ( $SYMBOL_NAME_RE ) ( .* ) /smx ) { return "$1$2$3"; } # Everything else return "$_"; } sub statement { my ( $self ) = @_; my $top = $self->top() or return; $top->can( 'source' ) or return; my $source = $top->source() or return; $source->can( 'statement' ) or return; return $source->statement(); } sub visual_column_number { my ( $self ) = @_; return ( $self->location() || [] )->[LOCATION_COLUMN]; } # 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 column_number This subroutine/method returns the column number of the first character in the element, or C if that can not be determined. =head2 is_ppi_quotelike_element This subroutine returns true if its argument is a L that this package is capable of dealing with. That is, one of the following: PPI::Token::Quote PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Readline PPI::Token::HereDoc It returns false for unblessed references and for non-references. =head2 line_number This subroutine/method returns the line number of the first character in the element, or C if that can not be determined. =head2 logical_filename This subroutine/method returns the logical file name (taking C<#line> directives into account) of the file containing first character in the element, or C if that can not be determined. =head2 logical_line_number This subroutine/method returns the logical line number (taking C<#line> directives into account) of the first character in the element, or C if that can not be determined. =head2 __normalize_interpolation_for_ppi 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 argument a string representing an interpolation. It removes such things as braces around variable names to make it into more normal Perl -- which is to say Perl that produces a more normal L parse. Sample transformations are: '${foo}' => '$foo' '@{[ foo() ]}' => 'foo()' '${\( foo() )}' => 'foo()' B that this is not intended for general code cleanup. Specifically, it assumes that its argument is an interpolation and B an interpolation. Feeding it anything else is unsupported, and probably will not return anything useful. =head2 statement This subroutine/method returns the L that contains this element, or nothing if the statement can not be determined. In general this method will return something only under the following conditions: =over =item * The element is contained in a L object; =item * That object was initialized from a L; =item * The L is contained in a statement. =back =head2 visual_column_number This subroutine/method returns the visual column number (taking tabs into account) of the first character in the element, or C if that can not be determined. =head2 __variables say for __variables( PPI::Document->new( \'$foo' ); B that this subroutine is discouraged, and may well be deprecated and removed. My problem with it is that it returns variable names rather than L objects, leaving you no idea how the variables are used. It was originally written for the benefit of L, but has proven inadequate to that policy's needs. 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token000755000765000024 014144504537 17705 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/Control.pm000444000765000024 360214144504537 22021 0ustar00tomstaff000000000000package 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.019'; { # 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/Delimiter.pm000444000765000024 670514144504537 22326 0ustar00tomstaff000000000000package 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.019'; # 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/Interpolation.pm000444000765000024 1143514144504537 23253 0ustar00tomstaff000000000000package PPIx::QuoteLike::Token::Interpolation; use 5.006; use strict; use warnings; use Carp; use PPI::Document; use PPIx::QuoteLike::Constant qw{ LOCATION_COLUMN LOCATION_LOGICAL_LINE LOCATION_LOGICAL_FILE @CARP_NOT }; use PPIx::QuoteLike::Utils qw{ __normalize_interpolation_for_ppi __variables }; use base qw{ PPIx::QuoteLike::Token }; our $VERSION = '0.019'; sub ppi { my ( $self ) = @_; unless ( $self->{ppi} ) { my $content; my $location = $self->{location}; if ( $location ) { my $fn; if( defined( $fn = $location->[LOCATION_LOGICAL_FILE] ) ) { $fn =~ s/ (?= [\\"] ) /\\/smxg; $content = qq{#line $location->[LOCATION_LOGICAL_LINE] "$fn"\n}; } else { $content = qq{#line $location->[LOCATION_LOGICAL_LINE]\n}; } $content .= ' ' x ( $location->[LOCATION_COLUMN] - 1 ); } $content .= __normalize_interpolation_for_ppi( $self->content() ); $self->{ppi} = PPI::Document->new( \$content ); if ( $location ) { # Generate locations now. $self->{ppi}->location(); # Remove the stuff we originally injected. NOTE that we can # only get away with doing this if the removal does not # invalidate the locations of the other tokens that we just # generated. my $elem; # Remove the '#line' directive if we find it $elem = $self->{ppi}->child( 0 ) and $elem->isa( 'PPI::Token::Comment' ) and $elem->content() =~ m/ \A \#line\b /smx and $elem->remove(); # Remove the white space if we find it, and if it in fact # represents only the white space we injected to get the # column numbers right. my $wid = $location->[LOCATION_COLUMN] - 1; $wid and $elem = $self->{ppi}->child( 0 ) and $elem->isa( 'PPI::Token::Whitespace' ) and $wid == length $elem->content() and $elem->remove(); } } 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. B that this method is discouraged, and may well be deprecated and removed. My problem with it is that it returns variable names rather than L objects, leaving you no idea how the variables are used. It was originally written for the benefit of L, but has proven inadequate to that policy's needs. =head1 SEE ALSO L. =head1 SUPPORT Support is by the author. Please file bug reports at L, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/String.pm000444000765000024 304514144504537 21650 0ustar00tomstaff000000000000package 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.019'; 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/Structure.pm000444000765000024 347214144504537 22406 0ustar00tomstaff000000000000package 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.019'; 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/Unknown.pm000444000765000024 314414144504537 22041 0ustar00tomstaff000000000000package 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.019'; 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/lib/PPIx/QuoteLike/Token/Whitespace.pm000444000765000024 330014144504537 22470 0ustar00tomstaff000000000000package 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.019'; 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, L, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F =head1 COPYRIGHT AND LICENSE Copyright (C) 2016-2021 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 : PPIx-QuoteLike-0.019/t000755000765000024 014144504537 13600 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/t/basic.t000444000765000024 350514144504537 15206 0ustar00tomstaff000000000000package 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 $@; foreach my $class ( qw{ PPI::Token::Quote PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Readline PPI::Token::HereDoc } ) { my $obj = bless {}, $class; # Force scalar context so returning nothing is interpreted as a # false value. ok scalar PPIx::QuoteLike::Utils::is_ppi_quotelike_element( $obj ), "$class is a quotelike element" or BAIL_OUT; } foreach my $class ( qw{ PPI::Token::QuoteLike::Words PPI::Token::QuoteLike::Regexp } ) { my $obj = bless {}, $class; ok !PPIx::QuoteLike::Utils::is_ppi_quotelike_element( $obj ), "$class is not a quotelike element" or BAIL_OUT; } foreach my $class ( Fubar => [] ) { ok !PPIx::QuoteLike::Utils::is_ppi_quotelike_element( $class ), "$class is not a quotelike element" or BAIL_OUT; } done_testing; 1; PPIx-QuoteLike-0.019/t/dump.t000444000765000024 507614144504537 15077 0ustar00tomstaff000000000000package main; use 5.006; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); use PPIx::QuoteLike::Constant (); use PPIx::QuoteLike::Dumper; local @PPIx::QuoteLike::Constant::CARP_NOT = ( @PPIx::QuoteLike::Constant::CARP_NOT, 'My::Module::Test' ); 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 : PPIx-QuoteLike-0.019/t/locations.t000444000765000024 462514144504537 16124 0ustar00tomstaff000000000000package main; use 5.006; use strict; use warnings; use PPI::Document; use PPIx::QuoteLike; use Test::More 0.88; # Because of done_testing(); { note 'Parse "foo${bar}baz"'; my $ppi = PPI::Document->new( \<<'EOD' ); #line 42 the_answer "foo${bar}baz"; EOD my $qd = $ppi->find( 'PPI::Token::Quote::Double' ); ok $qd, 'Found PPI::Token::Quote::Double'; cmp_ok @{ $qd }, '==', 1, 'Found exactly one PPI::Token:Quote::Double'; my $pql = PPIx::QuoteLike->new( $qd->[0] ); my @token = $pql->elements(); cmp_ok scalar @token, '==', 6, 'Found 6 tokens in string'; is_deeply $token[0]->location(), [ 2, 1, 1, 42, 'the_answer' ], q; is_deeply $token[1]->location(), [ 2, 1, 1, 42, 'the_answer' ], q; is_deeply $token[2]->location(), [ 2, 2, 2, 42, 'the_answer' ], q; is_deeply $token[3]->location(), [ 2, 5, 5, 42, 'the_answer' ], q; is_deeply $token[4]->location(), [ 2, 11, 11, 42, 'the_answer' ], q; cmp_ok $token[4]->line_number(), '==', 2, q; cmp_ok $token[4]->column_number(), '==', 11, q; cmp_ok $token[4]->visual_column_number(), '==', 11, q; cmp_ok $token[4]->logical_line_number(), '==', 42, q; cmp_ok $token[4]->logical_filename(), 'eq', 'the_answer', q; is_deeply $token[5]->location(), [ 2, 14, 14, 42, 'the_answer' ], q; is_deeply $pql->location(), [ 2, 1, 1, 42, 'the_answer' ], q; cmp_ok $pql->line_number(), '==', 2, q; cmp_ok $pql->column_number(), '==', 1, q; cmp_ok $pql->visual_column_number(), '==', 1, q; cmp_ok $pql->logical_line_number(), '==', 42, q; cmp_ok $pql->logical_filename(), 'eq', 'the_answer', q; note q; my $ppi2 = $token[3]->ppi(); @token = $ppi2->tokens(); cmp_ok scalar @token, '==', 1, 'Interpolation PPI has 1 token'; is_deeply $token[0]->location(), [ 2, 5, 5, 42, 'the_answer' ], q; } done_testing; 1; # ex: set textwidth=72 : PPIx-QuoteLike-0.019/t/normalize_interpolation_for_ppi.t000444000765000024 155714144504537 22617 0ustar00tomstaff000000000000package main; use 5.006; use strict; use warnings; use PPIx::QuoteLike::Utils qw{ __normalize_interpolation_for_ppi }; use Test::More 0.88; # Because of done_testing(); norm( '$foo', '$foo' ); norm( '$ foo', '$foo' ); norm( '${foo}', '$foo' ); norm( '${ foo }', '$foo' ); norm( '$ { foo }', '$foo' ); # NOTE this is a warning, and so (for now) not supported # norm( '${foo{bar}}', '$foo{bar}' ); # NOTE this is a warning, and so (for now) not supported # norm( '@{foo{bar}}', '@foo{bar}' ); norm( '@{$x[$i]}', '@{$x[$i]}' ); norm( '@{ [ foo() ] }', 'foo()' ); norm( '${ \\ ( foo() ) }', 'foo()' ); done_testing; sub norm { my ( $norm, $want, $title ) = @_; defined $title or $title = "'$norm' normalizes to '$want'"; my $got = __normalize_interpolation_for_ppi( $norm ); @_ = ( $got, $want, $title ); goto &is; } 1; # ex: set textwidth=72 : PPIx-QuoteLike-0.019/t/parse.t000444000765000024 16307414144504537 15307 0ustar00tomstaff000000000000package main; use 5.006; use strict; use warnings; use PPIx::QuoteLike; use PPIx::QuoteLike::Constant qw{ SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS }; use Test::More 0.88; # Because of done_testing(); # NOTE we use this circumlocution to hide the :encoding() from # xt/author/minimum_perl.t and Perl::MinimumVersion. The two-argument # binmode itself is OK under Perl 5.6 but the :encoding() is not. But if # we're 5.6 then SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS is false, # so the binmode() never gets executed. use constant OUTPUT_ENCODING => ':encoding(utf-8)'; if ( SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS ) { my $builder = Test::More->builder(); foreach my $method ( qw{ output failure_output todo_output } ) { my $handle = $builder->$method(); binmode $handle, OUTPUT_ENCODING; } } 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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}; } } { my $here_doc = <<'__END_OF_HERE_DOCUMENT'; << "EOD" $foo->{bar}bazzle ${\ $burfle } EOD __END_OF_HERE_DOCUMENT $obj = PPIx::QuoteLike->new( $here_doc ); if ( ok $obj, q{Able to parse HERE_DOCUMENT} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing HERE_DOCUMENT}; cmp_ok $obj->interpolates(), '==', 1, q{Does HERE_DOCUMENT interpolate}; is $obj->indentation(), undef, 'HERE_DOCUMENT indentation'; is $obj->content(), $here_doc, q{Can recover HERE_DOCUMENT}; is $obj->__get_value( 'type' ), '<<', q{Type of HERE_DOCUMENT}; is $obj->delimiters(), q{"EOD"EOD}, q{Delimiters of HERE_DOCUMENT}; is $obj->__get_value( 'start' ), q{"EOD"}, q{Start delimiter of HERE_DOCUMENT}; is $obj->__get_value( 'finish' ), q{EOD}, q{Finish delimiter of HERE_DOCUMENT}; is $obj->encoding(), undef, q{Encoding of HERE_DOCUMENT}; is_deeply [ sort $obj->variables() ], [ qw{ $burfle $foo } ], q{HERE_DOCUMENT interpolated variables}; cmp_ok scalar $obj->elements(), '==', 10, q{Number of elements of HERE_DOCUMENT}; cmp_ok scalar $obj->children(), '==', 4, q{Number of children of HERE_DOCUMENT}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{HERE_DOCUMENT child 0 class}; is $kid->content(), q/$foo->{bar}/, q{HERE_DOCUMENT child 0 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{HERE_DOCUMENT child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{HERE_DOCUMENT child 0 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $foo } ], q{HERE_DOCUMENT child 0 interpolated variables}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{HERE_DOCUMENT child 1 class}; is $kid->content(), qq{bazzle\n}, q{HERE_DOCUMENT child 1 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{HERE_DOCUMENT child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{HERE_DOCUMENT child 1 next sibling}; } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{HERE_DOCUMENT child 2 class}; is $kid->content(), "\${\\\n \$burfle\n}", q{HERE_DOCUMENT child 2 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 2 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 2 parent}; cmp_ok $kid->previous_sibling() || 2, '==', $obj->__kid( 2 - 1 ), q{HERE_DOCUMENT child 2 previous sibling}; cmp_ok $kid->next_sibling() || 2, '==', $obj->__kid( 2 + 1 ), q{HERE_DOCUMENT child 2 next sibling}; is_deeply [ sort $kid->variables() ], [ qw{ $burfle } ], q{HERE_DOCUMENT child 2 interpolated variables}; } } } $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 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 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 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 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 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 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 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 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 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 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 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 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}; } } } { my $here_doc = <<'__END_OF_HERE_DOCUMENT'; << ~'EOD' The $1,000,000 Bank-Note EOD __END_OF_HERE_DOCUMENT $obj = PPIx::QuoteLike->new( $here_doc ); if ( ok $obj, q{Able to parse HERE_DOCUMENT} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing HERE_DOCUMENT}; cmp_ok $obj->interpolates(), '==', 0, q{Does HERE_DOCUMENT interpolate}; is $obj->indentation(), ' ' x 4, 'HERE_DOCUMENT indentation'; is $obj->content(), $here_doc, q{Can recover HERE_DOCUMENT}; is $obj->__get_value( 'type' ), '<<', q{Type of HERE_DOCUMENT}; is $obj->delimiters(), q{'EOD'EOD}, q{Delimiters of HERE_DOCUMENT}; is $obj->__get_value( 'start' ), q{'EOD'}, q{Start delimiter of HERE_DOCUMENT}; is $obj->__get_value( 'finish' ), q{EOD}, q{Finish delimiter of HERE_DOCUMENT}; is $obj->encoding(), undef, q{Encoding of HERE_DOCUMENT}; is_deeply [ sort $obj->variables() ], [ ], q{HERE_DOCUMENT interpolated variables}; cmp_ok scalar $obj->elements(), '==', 10, q{Number of elements of HERE_DOCUMENT}; cmp_ok scalar $obj->children(), '==', 3, q{Number of children of HERE_DOCUMENT}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Whitespace' ), q{HERE_DOCUMENT child 0 class}; is $kid->content(), ' ' x 4, q{HERE_DOCUMENT child 0 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{HERE_DOCUMENT child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{HERE_DOCUMENT child 0 next sibling}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{HERE_DOCUMENT child 1 class}; is $kid->content(), "The \$1,000,000 Bank-Note\n", q{HERE_DOCUMENT child 1 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{HERE_DOCUMENT child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{HERE_DOCUMENT child 1 next sibling}; } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Whitespace' ), q{HERE_DOCUMENT child 2 class}; is $kid->content(), ' ' x 4, q{HERE_DOCUMENT child 2 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 2 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 2 parent}; cmp_ok $kid->previous_sibling() || 2, '==', $obj->__kid( 2 - 1 ), q{HERE_DOCUMENT child 2 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 2 + 1 ), q{HERE_DOCUMENT child 2 next sibling}; } } } { my $here_doc = <<'__END_OF_HERE_DOCUMENT'; << ~"EOD" The $1,000,000 Bank-Note EOD __END_OF_HERE_DOCUMENT $obj = PPIx::QuoteLike->new( $here_doc ); if ( ok $obj, q{Able to parse HERE_DOCUMENT} ) { cmp_ok $obj->failures(), '==', 0, q{Failures parsing HERE_DOCUMENT}; cmp_ok $obj->interpolates(), '==', 1, q{Does HERE_DOCUMENT interpolate}; is $obj->indentation(), ' ' x 4, 'HERE_DOCUMENT indentation'; is $obj->content(), $here_doc, q{Can recover HERE_DOCUMENT}; is $obj->__get_value( 'type' ), '<<', q{Type of HERE_DOCUMENT}; is $obj->delimiters(), q{"EOD"EOD}, q{Delimiters of HERE_DOCUMENT}; is $obj->__get_value( 'start' ), q{"EOD"}, q{Start delimiter of HERE_DOCUMENT}; is $obj->__get_value( 'finish' ), q{EOD}, q{Finish delimiter of HERE_DOCUMENT}; is $obj->encoding(), undef, q{Encoding of HERE_DOCUMENT}; is_deeply [ sort $obj->variables() ], [ qw{ $1 } ], q{HERE_DOCUMENT interpolated variables}; cmp_ok scalar $obj->elements(), '==', 12, q{Number of elements of HERE_DOCUMENT}; cmp_ok scalar $obj->children(), '==', 5, q{Number of children of HERE_DOCUMENT}; if ( my $kid = $obj->child( 0 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Whitespace' ), q{HERE_DOCUMENT child 0 class}; is $kid->content(), ' ' x 4, q{HERE_DOCUMENT child 0 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 0 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 0 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 0 - 1 ), q{HERE_DOCUMENT child 0 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 0 + 1 ), q{HERE_DOCUMENT child 0 next sibling}; } if ( my $kid = $obj->child( 1 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{HERE_DOCUMENT child 1 class}; is $kid->content(), 'The ', q{HERE_DOCUMENT child 1 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 1 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 1 parent}; cmp_ok $kid->previous_sibling() || 0, '==', $obj->__kid( 1 - 1 ), q{HERE_DOCUMENT child 1 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 1 + 1 ), q{HERE_DOCUMENT child 1 next sibling}; } if ( my $kid = $obj->child( 2 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Interpolation' ), q{HERE_DOCUMENT child 2 class}; is $kid->content(), '$1', q{HERE_DOCUMENT child 2 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 2 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 2 parent}; cmp_ok $kid->previous_sibling() || 2, '==', $obj->__kid( 2 - 1 ), q{HERE_DOCUMENT child 2 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 2 + 1 ), q{HERE_DOCUMENT child 2 next sibling}; } if ( my $kid = $obj->child( 3 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::String' ), q{HERE_DOCUMENT child 3 class}; is $kid->content(), ",000,000 Bank-Note\n\n", q{HERE_DOCUMENT child 3 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 3 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 3 parent}; cmp_ok $kid->previous_sibling() || 3, '==', $obj->__kid( 3 - 1 ), q{HERE_DOCUMENT child 3 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 3 + 1 ), q{HERE_DOCUMENT child 3 next sibling}; } if ( my $kid = $obj->child( 4 ) ) { ok $kid->isa( 'PPIx::QuoteLike::Token::Whitespace' ), q{HERE_DOCUMENT child 4 class}; is $kid->content(), ' ' x 4, q{HERE_DOCUMENT child 4 content}; is $kid->error(), undef, q{HERE_DOCUMENT child 4 error}; cmp_ok $kid->parent(), '==', $obj, q{HERE_DOCUMENT child 4 parent}; cmp_ok $kid->previous_sibling() || 4, '==', $obj->__kid( 4 - 1 ), q{HERE_DOCUMENT child 4 previous sibling}; cmp_ok $kid->next_sibling() || 0, '==', $obj->__kid( 4 + 1 ), q{HERE_DOCUMENT child 4 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 : PPIx-QuoteLike-0.019/t/unit-adhoc.t000444000765000024 235714144504537 16164 0ustar00tomstaff000000000000package main; use 5.006; use strict; use warnings; use PPI::Document; use PPIx::QuoteLike; use Scalar::Util qw{ refaddr }; use Test::More 0.88; # Because of done_testing(); { my $code = '"foo"'; my $doc = PPI::Document->new( \$code ); my @qs = @{ $doc->find( 'PPI::Token::Quote' ) || [] }; my $pql = PPIx::QuoteLike->new( $qs[0] ); cmp_ok refaddr( $qs[0]->statement() ), '==', refaddr( $pql->statement() ), q; my @lit = @{ $pql->find( 'PPIx::QuoteLike::Token::String' ) || [] }; cmp_ok refaddr( $lit[0]->statement() ), '==', refaddr( $pql->statement() ), q; } { my $code = <<'END_OF_DOCUMENT'; <<\EOD $foo EOD END_OF_DOCUMENT my $pql = PPIx::QuoteLike->new( $code ); cmp_ok $pql->failures(), '==', 0, '<<\\EOD here doc parses'; ok ! $pql->interpolates(), '<<\\EOD here doc does not interpolate'; } { my $code = <<'END_OF_DOCUMENT'; <<~\EOD $foo EOD END_OF_DOCUMENT my $pql = PPIx::QuoteLike->new( $code ); cmp_ok $pql->failures(), '==', 0, '<<~\\EOD here doc parses'; ok ! $pql->interpolates(), '<<~\\EOD here doc does not interpolate'; } done_testing; 1; # ex: set textwidth=72 : PPIx-QuoteLike-0.019/t/variables.t000444000765000024 415014144504537 16072 0ustar00tomstaff000000000000package 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(); 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 : PPIx-QuoteLike-0.019/t/version.t000444000765000024 1072714144504537 15636 0ustar00tomstaff000000000000package 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; use Test::More 0.88; # Because of done_testing(); # NOTE we use this circumlocution to hide the :encoding() from # xt/author/minimum_perl.t and Perl::MinimumVersion. The two-argument # binmode itself is OK under Perl 5.6 but the :encoding() is not. But if # we're 5.6 then SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS is false, # so the binmode() never gets executed. use constant OUTPUT_ENCODING => ':encoding(utf-8)'; if ( SUFFICIENT_UTF8_SUPPORT_FOR_WEIRD_DELIMITERS ) { my $builder = Test::More->builder(); foreach my $method ( qw{ output failure_output todo_output } ) { my $handle = $builder->$method(); binmode $handle, OUTPUT_ENCODING; } } 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'; $obj = PPIx::QuoteLike->new( <perl_version_introduced(), '5.025007', 'Indented here-doc was introduced in 5.25.7'; is $obj->perl_version_removed(), undef, 'Indented here-doc is still here'; done_testing; 1; # ex: set textwidth=72 : PPIx-QuoteLike-0.019/xt000755000765000024 014144504537 13770 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/xt/author000755000765000024 014144504537 15272 5ustar00tomstaff000000000000PPIx-QuoteLike-0.019/xt/author/carp_not.t000444000765000024 136414144504537 17425 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/changes.t000444000765000024 60214144504537 17202 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/critic.t000444000765000024 106014144504537 17066 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/executable.t000444000765000024 111414144504537 17732 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/kwalitee.t000444000765000024 53214144504537 17401 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/manifest.t000444000765000024 62314144504537 17403 0ustar00tomstaff000000000000package 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; PPIx-QuoteLike-0.019/xt/author/minimum_perl.t000444000765000024 262614144504537 20317 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/perlcriticrc000444000765000024 351414144504537 20042 0ustar00tomstaff000000000000severity = 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 PPIx-QuoteLike-0.019/xt/author/pod.t000444000765000024 50514144504537 16356 0ustar00tomstaff000000000000package 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 : PPIx-QuoteLike-0.019/xt/author/pod_links.t000444000765000024 71514144504537 17561 0ustar00tomstaff000000000000package main; use 5.008; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); BEGIN { local $@ = undef; eval { require Test::Pod::LinkCheck::Lite; Test::Pod::LinkCheck::Lite->import( ':const' ); 1; } or plan skip_all => 'Unable to load Test::Pod::LinkCheck::Lite'; } Test::Pod::LinkCheck::Lite->new( prohibit_redirect => ALLOW_REDIRECT_TO_INDEX, )->all_pod_files_ok(); done_testing; 1; # ex: set textwidth=72 : PPIx-QuoteLike-0.019/xt/author/pod_spelling.t000444000765000024 61514144504537 20255 0ustar00tomstaff000000000000package 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 hoc merchantability quotelike postderef postfix ppi ppix quotish schild schildren trigraphs uninterpolated Wyant PPIx-QuoteLike-0.019/xt/author/prereq.t000444000765000024 56214144504537 17075 0ustar00tomstaff000000000000package main; use strict; use warnings; use Test::More 0.88; # Because of done_testing(); eval { require Test::Prereq::Meta; 1; } or plan skip_all => 'Test::Prereq::Meta not available'; my $tpm = Test::Prereq::Meta->new( accept => [ qw{ PPIx::Regexp } ], ); $tpm->all_prereq_ok(); $tpm->all_prereqs_used(); done_testing; 1; # ex: set textwidth=72 :