Import Upstream version 2.006006
This commit is contained in:
Lu zhiping
commit
67bb2aaa8b
|
|
@ -0,0 +1,79 @@
|
|||
Revision history for Sub::Quote
|
||||
|
||||
2.006006 - 2019-10-01
|
||||
- change quotify to use longest form of floating point numbers if unable to
|
||||
find a perfectly accurate representation
|
||||
- updated documentation for quotify to reflect handling of floating point
|
||||
numbers
|
||||
- don't try to copy hints hash entries that look like references (RT#122698)
|
||||
|
||||
2.006_005 - 2019-09-06
|
||||
- additional fixes for quotify for floating point numbers to be faster and
|
||||
should always be able to maintain accuracy
|
||||
|
||||
2.006_004 - 2019-04-24
|
||||
- change quotify of NaNs to simpler calculation
|
||||
- avoid ever triggering exceptions when testing for quotify on false values
|
||||
- skip quotify Inf and NaN tests if perl is compiled without support for
|
||||
them
|
||||
- fix quotify of very large or very small numbers
|
||||
- fix accuracy of quotify on high precision numbers when perl is compiled
|
||||
with quadmath
|
||||
- quotify will use hex floats when needed for full accuracy if they are
|
||||
available
|
||||
- change tests of quotify for floating point numbers to allow a small amount
|
||||
of inaccuracy, since decimal floats can't always be accurate
|
||||
|
||||
2.006003 - 2019-03-10
|
||||
- releasing as stable
|
||||
|
||||
2.006_002 - 2019-01-29
|
||||
- Fix quotifying of backslashes in utf8-flagged strings on perl 5.10.0.
|
||||
|
||||
2.006_001 - 2019-01-07
|
||||
- avoid warnings or failures on new perls when testing quoting UTF-8 strings
|
||||
- test quotify output under utf8 pragma
|
||||
- fix quoting of negative NaN
|
||||
|
||||
2.006_000 - 2018-12-29
|
||||
- don't test threads behavior on perl < 5.8.5, since they are too unstable
|
||||
- more tests
|
||||
- preserve inf, nan, and false in quotify
|
||||
- improve accuracy of quotified floating point numbers
|
||||
- SUB_QUOTE_DEBUG can now be set to sub names, package names, or a regex to
|
||||
match against the code to filter which generated subs are printed to STDERR.
|
||||
|
||||
2.005001 - 2018-04-20
|
||||
- add a workaround for test failures on early 5.8 releases with threads
|
||||
|
||||
2.005000 - 2018-02-06
|
||||
- fixed defer_info and undefer_sub from returning data for a deferred sub
|
||||
after it expires, even if the ref address matches
|
||||
- fixed defer_info not returning info for undeferred unnamed subs after the
|
||||
deferred sub expires
|
||||
- include options in defer_info return data
|
||||
- exclude internals from defer_info return data
|
||||
- document defer_info function
|
||||
- encode all utf8 flagged scalars as strings, since they generally will
|
||||
always have originated as strings. Avoids future warning on bitwise ops
|
||||
on strings with wide characters.
|
||||
- more thorough check for threads availability to avoid needless test
|
||||
failures.
|
||||
- added file and line options to quote_sub to allow specifying apparent
|
||||
source location.
|
||||
- documented additional options to Sub::Defer::defer_sub and
|
||||
Sub::Quote::quote_sub.
|
||||
|
||||
2.004000 - 2017-06-07
|
||||
- more extensive quotify tests
|
||||
- split tests into separate files
|
||||
- propagate package to deferred subs, even if unnamed
|
||||
- reject invalid attributes
|
||||
- include line numbers compile errors (PR#1, djerius)
|
||||
|
||||
2.003001 - 2016-12-09
|
||||
- fix use of Sub::Name
|
||||
|
||||
2.003000 - 2016-12-09
|
||||
- Sub::Quote and Sub::Defer have been split out of Moo.
|
||||
- For old history see: https://metacpan.org/changes/release/HAARG/Moo-2.002005
|
||||
|
|
@ -0,0 +1,374 @@
|
|||
Terms of the Perl programming language system itself
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
b) the "Artistic License"
|
||||
|
||||
--- The GNU General Public License, Version 1, February 1989 ---
|
||||
|
||||
This software is Copyright (c) 2019 by mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The GNU General Public License, Version 1, February 1989
|
||||
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
Version 1, February 1989
|
||||
|
||||
Copyright (C) 1989 Free Software Foundation, Inc.
|
||||
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
Preamble
|
||||
|
||||
The license agreements of most software companies try to keep users
|
||||
at the mercy of those companies. By contrast, our General Public
|
||||
License is intended to guarantee your freedom to share and change free
|
||||
software--to make sure the software is free for all its users. The
|
||||
General Public License applies to the Free Software Foundation's
|
||||
software and to any other program whose authors commit to using it.
|
||||
You can use it for your programs, too.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Specifically, the General Public License is designed to make
|
||||
sure that you have the freedom to give away or sell copies of free
|
||||
software, that you receive source code or can get it if you want it,
|
||||
that you can change the software or use pieces of it in new free
|
||||
programs; and that you know you can do these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
anyone to deny you these rights or to ask you to surrender the rights.
|
||||
These restrictions translate to certain responsibilities for you if you
|
||||
distribute copies of the software, or if you modify it.
|
||||
|
||||
For example, if you distribute copies of a such a program, whether
|
||||
gratis or for a fee, you must give the recipients all the rights that
|
||||
you have. You must make sure that they, too, receive or can get the
|
||||
source code. And you must tell them their rights.
|
||||
|
||||
We protect your rights with two steps: (1) copyright the software, and
|
||||
(2) offer you this license which gives you legal permission to copy,
|
||||
distribute and/or modify the software.
|
||||
|
||||
Also, for each author's protection and ours, we want to make certain
|
||||
that everyone understands that there is no warranty for this free
|
||||
software. If the software is modified by someone else and passed on, we
|
||||
want its recipients to know that what they have is not the original, so
|
||||
that any problems introduced by others will not reflect on the original
|
||||
authors' reputations.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow.
|
||||
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any program or other work which
|
||||
contains a notice placed by the copyright holder saying it may be
|
||||
distributed under the terms of this General Public License. The
|
||||
"Program", below, refers to any such program or work, and a "work based
|
||||
on the Program" means either the Program or any work containing the
|
||||
Program or a portion of it, either verbatim or with modifications. Each
|
||||
licensee is addressed as "you".
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Program's source
|
||||
code as you receive it, in any medium, provided that you conspicuously and
|
||||
appropriately publish on each copy an appropriate copyright notice and
|
||||
disclaimer of warranty; keep intact all the notices that refer to this
|
||||
General Public License and to the absence of any warranty; and give any
|
||||
other recipients of the Program a copy of this General Public License
|
||||
along with the Program. You may charge a fee for the physical act of
|
||||
transferring a copy.
|
||||
|
||||
2. You may modify your copy or copies of the Program or any portion of
|
||||
it, and copy and distribute such modifications under the terms of Paragraph
|
||||
1 above, provided that you also do the following:
|
||||
|
||||
a) cause the modified files to carry prominent notices stating that
|
||||
you changed the files and the date of any change; and
|
||||
|
||||
b) cause the whole of any work that you distribute or publish, that
|
||||
in whole or in part contains the Program or any part thereof, either
|
||||
with or without modifications, to be licensed at no charge to all
|
||||
third parties under the terms of this General Public License (except
|
||||
that you may choose to grant warranty protection to some or all
|
||||
third parties, at your option).
|
||||
|
||||
c) If the modified program normally reads commands interactively when
|
||||
run, you must cause it, when started running for such interactive use
|
||||
in the simplest and most usual way, to print or display an
|
||||
announcement including an appropriate copyright notice and a notice
|
||||
that there is no warranty (or else, saying that you provide a
|
||||
warranty) and that users may redistribute the program under these
|
||||
conditions, and telling the user how to view a copy of this General
|
||||
Public License.
|
||||
|
||||
d) You may charge a fee for the physical act of transferring a
|
||||
copy, and you may at your option offer warranty protection in
|
||||
exchange for a fee.
|
||||
|
||||
Mere aggregation of another independent work with the Program (or its
|
||||
derivative) on a volume of a storage or distribution medium does not bring
|
||||
the other work under the scope of these terms.
|
||||
|
||||
3. You may copy and distribute the Program (or a portion or derivative of
|
||||
it, under Paragraph 2) in object code or executable form under the terms of
|
||||
Paragraphs 1 and 2 above provided that you also do one of the following:
|
||||
|
||||
a) accompany it with the complete corresponding machine-readable
|
||||
source code, which must be distributed under the terms of
|
||||
Paragraphs 1 and 2 above; or,
|
||||
|
||||
b) accompany it with a written offer, valid for at least three
|
||||
years, to give any third party free (except for a nominal charge
|
||||
for the cost of distribution) a complete machine-readable copy of the
|
||||
corresponding source code, to be distributed under the terms of
|
||||
Paragraphs 1 and 2 above; or,
|
||||
|
||||
c) accompany it with the information you received as to where the
|
||||
corresponding source code may be obtained. (This alternative is
|
||||
allowed only for noncommercial distribution and only if you
|
||||
received the program in object code or executable form alone.)
|
||||
|
||||
Source code for a work means the preferred form of the work for making
|
||||
modifications to it. For an executable file, complete source code means
|
||||
all the source code for all modules it contains; but, as a special
|
||||
exception, it need not include source code for modules which are standard
|
||||
libraries that accompany the operating system on which the executable
|
||||
file runs, or for standard header files or definitions files that
|
||||
accompany that operating system.
|
||||
|
||||
4. You may not copy, modify, sublicense, distribute or transfer the
|
||||
Program except as expressly provided under this General Public License.
|
||||
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
|
||||
the Program is void, and will automatically terminate your rights to use
|
||||
the Program under this License. However, parties who have received
|
||||
copies, or rights to use copies, from you under this General Public
|
||||
License will not have their licenses terminated so long as such parties
|
||||
remain in full compliance.
|
||||
|
||||
5. By copying, distributing or modifying the Program (or any work based
|
||||
on the Program) you indicate your acceptance of this license to do so,
|
||||
and all its terms and conditions.
|
||||
|
||||
6. Each time you redistribute the Program (or any work based on the
|
||||
Program), the recipient automatically receives a license from the original
|
||||
licensor to copy, distribute or modify the Program subject to these
|
||||
terms and conditions. You may not impose any further restrictions on the
|
||||
recipients' exercise of the rights granted herein.
|
||||
|
||||
7. The Free Software Foundation may publish revised and/or new versions
|
||||
of the General Public License from time to time. Such new versions will
|
||||
be similar in spirit to the present version, but may differ in detail to
|
||||
address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Program
|
||||
specifies a version number of the license which applies to it and "any
|
||||
later version", you have the option of following the terms and conditions
|
||||
either of that version or of any later version published by the Free
|
||||
Software Foundation. If the Program does not specify a version number of
|
||||
the license, you may choose any version ever published by the Free Software
|
||||
Foundation.
|
||||
|
||||
8. If you wish to incorporate parts of the Program into other free
|
||||
programs whose distribution conditions are different, write to the author
|
||||
to ask for permission. For software which is copyrighted by the Free
|
||||
Software Foundation, write to the Free Software Foundation; we sometimes
|
||||
make exceptions for this. Our decision will be guided by the two goals
|
||||
of preserving the free status of all derivatives of our free software and
|
||||
of promoting the sharing and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
|
||||
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
|
||||
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
|
||||
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
|
||||
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
|
||||
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
|
||||
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
|
||||
REPAIR OR CORRECTION.
|
||||
|
||||
10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
|
||||
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
|
||||
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
|
||||
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
|
||||
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
|
||||
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
|
||||
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
Appendix: How to Apply These Terms to Your New Programs
|
||||
|
||||
If you develop a new program, and you want it to be of the greatest
|
||||
possible use to humanity, the best way to achieve this is to make it
|
||||
free software which everyone can redistribute and change under these
|
||||
terms.
|
||||
|
||||
To do so, attach the following notices to the program. It is safest to
|
||||
attach them to the start of each source file to most effectively convey
|
||||
the exclusion of warranty; and each file should have at least the
|
||||
"copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the program's name and a brief idea of what it does.>
|
||||
Copyright (C) 19yy <name of author>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 1, or (at your option)
|
||||
any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
|
||||
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
If the program is interactive, make it output a short notice like this
|
||||
when it starts in an interactive mode:
|
||||
|
||||
Gnomovision version 69, Copyright (C) 19xx name of author
|
||||
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
|
||||
This is free software, and you are welcome to redistribute it
|
||||
under certain conditions; type `show c' for details.
|
||||
|
||||
The hypothetical commands `show w' and `show c' should show the
|
||||
appropriate parts of the General Public License. Of course, the
|
||||
commands you use may be called something other than `show w' and `show
|
||||
c'; they could even be mouse-clicks or menu items--whatever suits your
|
||||
program.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or your
|
||||
school, if any, to sign a "copyright disclaimer" for the program, if
|
||||
necessary. Here a sample; alter the names:
|
||||
|
||||
Yoyodyne, Inc., hereby disclaims all copyright interest in the
|
||||
program `Gnomovision' (a program to direct compilers to make passes
|
||||
at assemblers) written by James Hacker.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1989
|
||||
Ty Coon, President of Vice
|
||||
|
||||
That's all there is to it!
|
||||
|
||||
|
||||
--- The Artistic License 1.0 ---
|
||||
|
||||
This software is Copyright (c) 2019 by mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 1.0
|
||||
|
||||
The Artistic License
|
||||
|
||||
Preamble
|
||||
|
||||
The intent of this document is to state the conditions under which a Package
|
||||
may be copied, such that the Copyright Holder maintains some semblance of
|
||||
artistic control over the development of the package, while giving the users of
|
||||
the package the right to use and distribute the Package in a more-or-less
|
||||
customary fashion, plus the right to make reasonable modifications.
|
||||
|
||||
Definitions:
|
||||
|
||||
- "Package" refers to the collection of files distributed by the Copyright
|
||||
Holder, and derivatives of that collection of files created through
|
||||
textual modification.
|
||||
- "Standard Version" refers to such a Package if it has not been modified,
|
||||
or has been modified in accordance with the wishes of the Copyright
|
||||
Holder.
|
||||
- "Copyright Holder" is whoever is named in the copyright or copyrights for
|
||||
the package.
|
||||
- "You" is you, if you're thinking about copying or distributing this Package.
|
||||
- "Reasonable copying fee" is whatever you can justify on the basis of media
|
||||
cost, duplication charges, time of people involved, and so on. (You will
|
||||
not be required to justify it to the Copyright Holder, but only to the
|
||||
computing community at large as a market that must bear the fee.)
|
||||
- "Freely Available" means that no fee is charged for the item itself, though
|
||||
there may be fees involved in handling the item. It also means that
|
||||
recipients of the item may redistribute it under the same conditions they
|
||||
received it.
|
||||
|
||||
1. You may make and give away verbatim copies of the source form of the
|
||||
Standard Version of this Package without restriction, provided that you
|
||||
duplicate all of the original copyright notices and associated disclaimers.
|
||||
|
||||
2. You may apply bug fixes, portability fixes and other modifications derived
|
||||
from the Public Domain or from the Copyright Holder. A Package modified in such
|
||||
a way shall still be considered the Standard Version.
|
||||
|
||||
3. You may otherwise modify your copy of this Package in any way, provided that
|
||||
you insert a prominent notice in each changed file stating how and when you
|
||||
changed that file, and provided that you do at least ONE of the following:
|
||||
|
||||
a) place your modifications in the Public Domain or otherwise make them
|
||||
Freely Available, such as by posting said modifications to Usenet or an
|
||||
equivalent medium, or placing the modifications on a major archive site
|
||||
such as ftp.uu.net, or by allowing the Copyright Holder to include your
|
||||
modifications in the Standard Version of the Package.
|
||||
|
||||
b) use the modified Package only within your corporation or organization.
|
||||
|
||||
c) rename any non-standard executables so the names do not conflict with
|
||||
standard executables, which must also be provided, and provide a separate
|
||||
manual page for each non-standard executable that clearly documents how it
|
||||
differs from the Standard Version.
|
||||
|
||||
d) make other distribution arrangements with the Copyright Holder.
|
||||
|
||||
4. You may distribute the programs of this Package in object code or executable
|
||||
form, provided that you do at least ONE of the following:
|
||||
|
||||
a) distribute a Standard Version of the executables and library files,
|
||||
together with instructions (in the manual page or equivalent) on where to
|
||||
get the Standard Version.
|
||||
|
||||
b) accompany the distribution with the machine-readable source of the Package
|
||||
with your modifications.
|
||||
|
||||
c) accompany any non-standard executables with their corresponding Standard
|
||||
Version executables, giving the non-standard executables non-standard
|
||||
names, and clearly documenting the differences in manual pages (or
|
||||
equivalent), together with instructions on where to get the Standard
|
||||
Version.
|
||||
|
||||
d) make other distribution arrangements with the Copyright Holder.
|
||||
|
||||
5. You may charge a reasonable copying fee for any distribution of this
|
||||
Package. You may charge any fee you choose for support of this Package. You
|
||||
may not charge a fee for this Package itself. However, you may distribute this
|
||||
Package in aggregate with other (possibly commercial) programs as part of a
|
||||
larger (possibly commercial) software distribution provided that you do not
|
||||
advertise this Package as a product of your own.
|
||||
|
||||
6. The scripts and library files supplied as input to or produced as output
|
||||
from the programs of this Package do not automatically fall under the copyright
|
||||
of this Package, but belong to whomever generated them, and may be sold
|
||||
commercially, and may be aggregated with this Package.
|
||||
|
||||
7. C or perl subroutines supplied by you and linked into this Package shall not
|
||||
be considered part of this Package.
|
||||
|
||||
8. The name of the Copyright Holder may not be used to endorse or promote
|
||||
products derived from this software without specific prior written permission.
|
||||
|
||||
9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
The End
|
||||
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
Changes
|
||||
lib/Sub/Defer.pm
|
||||
lib/Sub/Quote.pm
|
||||
maint/Makefile.PL.include
|
||||
Makefile.PL
|
||||
MANIFEST This list of files
|
||||
t/croak-locations.t
|
||||
t/hints.t
|
||||
t/inline.t
|
||||
t/leaks.t
|
||||
t/lib/ErrorLocation.pm
|
||||
t/lib/InlineModule.pm
|
||||
t/lib/ThreadsCheck.pm
|
||||
t/quotify-5.6.t
|
||||
t/quotify-no-hex.t
|
||||
t/quotify.t
|
||||
t/sub-defer-no-subname.t
|
||||
t/sub-defer-threads.t
|
||||
t/sub-defer.t
|
||||
t/sub-quote-threads.t
|
||||
t/sub-quote.t
|
||||
t/subname-none.t
|
||||
t/subname-sub-name-preload.t
|
||||
t/subname-sub-name.t
|
||||
t/subname-sub-util.t
|
||||
xt/release/kwalitee.t
|
||||
META.yml Module YAML meta-data (added by MakeMaker)
|
||||
META.json Module JSON meta-data (added by MakeMaker)
|
||||
README README file (added by Distar)
|
||||
LICENSE LICENSE file (added by Distar)
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
{
|
||||
"abstract" : "Efficient generation of subroutines via string eval",
|
||||
"author" : [
|
||||
"mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>"
|
||||
],
|
||||
"dynamic_config" : 1,
|
||||
"generated_by" : "ExtUtils::MakeMaker version 7.38, CPAN::Meta::Converter version 2.150010",
|
||||
"license" : [
|
||||
"perl_5"
|
||||
],
|
||||
"meta-spec" : {
|
||||
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
|
||||
"version" : 2
|
||||
},
|
||||
"name" : "Sub-Quote",
|
||||
"no_index" : {
|
||||
"directory" : [
|
||||
"t",
|
||||
"xt"
|
||||
]
|
||||
},
|
||||
"prereqs" : {
|
||||
"build" : {
|
||||
"requires" : {}
|
||||
},
|
||||
"configure" : {
|
||||
"requires" : {
|
||||
"ExtUtils::MakeMaker" : "0"
|
||||
}
|
||||
},
|
||||
"develop" : {
|
||||
"requires" : {}
|
||||
},
|
||||
"runtime" : {
|
||||
"recommends" : {
|
||||
"Sub::Name" : "0.08"
|
||||
},
|
||||
"requires" : {
|
||||
"Scalar::Util" : "0",
|
||||
"perl" : "5.006"
|
||||
}
|
||||
},
|
||||
"test" : {
|
||||
"requires" : {
|
||||
"Test::Fatal" : "0.003",
|
||||
"Test::More" : "0.94"
|
||||
}
|
||||
}
|
||||
},
|
||||
"release_status" : "stable",
|
||||
"resources" : {
|
||||
"bugtracker" : {
|
||||
"mailto" : "bug-Sub-Quote@rt.cpan.org",
|
||||
"web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote"
|
||||
},
|
||||
"license" : [
|
||||
"http://dev.perl.org/licenses/"
|
||||
],
|
||||
"repository" : {
|
||||
"type" : "git",
|
||||
"url" : "https://github.com/moose/Sub-Quote.git",
|
||||
"web" : "https://github.com/moose/Sub-Quote"
|
||||
},
|
||||
"x_IRC" : "irc://irc.perl.org/#moose"
|
||||
},
|
||||
"version" : "2.006006",
|
||||
"x_authority" : "cpan:MSTROUT",
|
||||
"x_serialization_backend" : "JSON::PP version 4.04"
|
||||
}
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
---
|
||||
abstract: 'Efficient generation of subroutines via string eval'
|
||||
author:
|
||||
- 'mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>'
|
||||
build_requires:
|
||||
Test::Fatal: '0.003'
|
||||
Test::More: '0.94'
|
||||
configure_requires:
|
||||
ExtUtils::MakeMaker: '0'
|
||||
dynamic_config: 1
|
||||
generated_by: 'ExtUtils::MakeMaker version 7.38, 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: Sub-Quote
|
||||
no_index:
|
||||
directory:
|
||||
- t
|
||||
- xt
|
||||
recommends:
|
||||
Sub::Name: '0.08'
|
||||
requires:
|
||||
Scalar::Util: '0'
|
||||
perl: '5.006'
|
||||
resources:
|
||||
IRC: irc://irc.perl.org/#moose
|
||||
bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote
|
||||
license: http://dev.perl.org/licenses/
|
||||
repository: https://github.com/moose/Sub-Quote.git
|
||||
version: '2.006006'
|
||||
x_authority: cpan:MSTROUT
|
||||
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use 5.006;
|
||||
|
||||
my %META = (
|
||||
name => 'Sub-Quote',
|
||||
license => 'perl_5',
|
||||
prereqs => {
|
||||
configure => { requires => {
|
||||
'ExtUtils::MakeMaker' => 0,
|
||||
} },
|
||||
build => { requires => {
|
||||
} },
|
||||
test => {
|
||||
requires => {
|
||||
'Test::More' => 0.94,
|
||||
'Test::Fatal' => 0.003,
|
||||
},
|
||||
},
|
||||
runtime => {
|
||||
requires => {
|
||||
'Scalar::Util' => 0,
|
||||
'perl' => 5.006,
|
||||
},
|
||||
recommends => {
|
||||
'Sub::Name' => 0.08,
|
||||
},
|
||||
},
|
||||
develop => {
|
||||
requires => {},
|
||||
},
|
||||
},
|
||||
resources => {
|
||||
repository => {
|
||||
url => 'https://github.com/moose/Sub-Quote.git',
|
||||
web => 'https://github.com/moose/Sub-Quote',
|
||||
type => 'git',
|
||||
},
|
||||
x_IRC => 'irc://irc.perl.org/#moose',
|
||||
bugtracker => {
|
||||
web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote',
|
||||
mailto => 'bug-Sub-Quote@rt.cpan.org',
|
||||
},
|
||||
license => [ 'http://dev.perl.org/licenses/' ],
|
||||
},
|
||||
no_index => {
|
||||
directory => [ 't', 'xt' ]
|
||||
},
|
||||
x_authority => 'cpan:MSTROUT',
|
||||
);
|
||||
|
||||
my %MM_ARGS = (
|
||||
PREREQ_PM => {
|
||||
("$]" >= 5.008_000 ? () : ('Task::Weaken' => 0)),
|
||||
},
|
||||
);
|
||||
|
||||
## BOILERPLATE ###############################################################
|
||||
require ExtUtils::MakeMaker;
|
||||
(do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml';
|
||||
|
||||
# have to do this since old EUMM dev releases miss the eval $VERSION line
|
||||
my $eumm_version = eval $ExtUtils::MakeMaker::VERSION;
|
||||
my $mymeta = $eumm_version >= 6.57_02;
|
||||
my $mymeta_broken = $mymeta && $eumm_version < 6.57_07;
|
||||
|
||||
($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g;
|
||||
($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g;
|
||||
$META{license} = [ $META{license} ]
|
||||
if $META{license} && !ref $META{license};
|
||||
$MM_ARGS{LICENSE} = $META{license}[0]
|
||||
if $META{license} && $eumm_version >= 6.30;
|
||||
$MM_ARGS{NO_MYMETA} = 1
|
||||
if $mymeta_broken;
|
||||
$MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META }
|
||||
unless -f 'META.yml';
|
||||
|
||||
for (qw(configure build test runtime)) {
|
||||
my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES';
|
||||
my $r = $MM_ARGS{$key} = {
|
||||
%{$META{prereqs}{$_}{requires} || {}},
|
||||
%{delete $MM_ARGS{$key} || {}},
|
||||
};
|
||||
defined $r->{$_} or delete $r->{$_} for keys %$r;
|
||||
}
|
||||
|
||||
$MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0;
|
||||
|
||||
delete $MM_ARGS{MIN_PERL_VERSION}
|
||||
if $eumm_version < 6.47_01;
|
||||
$MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}}
|
||||
if $eumm_version < 6.63_03;
|
||||
$MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}}
|
||||
if $eumm_version < 6.55_01;
|
||||
delete $MM_ARGS{CONFIGURE_REQUIRES}
|
||||
if $eumm_version < 6.51_03;
|
||||
|
||||
ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS);
|
||||
## END BOILERPLATE ###########################################################
|
||||
|
|
@ -0,0 +1,285 @@
|
|||
NAME
|
||||
Sub::Quote - Efficient generation of subroutines via string eval
|
||||
|
||||
SYNOPSIS
|
||||
package Silly;
|
||||
|
||||
use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
|
||||
|
||||
quote_sub 'Silly::kitty', q{ print "meow" };
|
||||
|
||||
quote_sub 'Silly::doggy', q{ print "woof" };
|
||||
|
||||
my $sound = 0;
|
||||
|
||||
quote_sub 'Silly::dagron',
|
||||
q{ print ++$sound % 2 ? 'burninate' : 'roar' },
|
||||
{ '$sound' => \$sound };
|
||||
|
||||
And elsewhere:
|
||||
|
||||
Silly->kitty; # meow
|
||||
Silly->doggy; # woof
|
||||
Silly->dagron; # burninate
|
||||
Silly->dagron; # roar
|
||||
Silly->dagron; # burninate
|
||||
|
||||
DESCRIPTION
|
||||
This package provides performant ways to generate subroutines from
|
||||
strings.
|
||||
|
||||
SUBROUTINES
|
||||
quote_sub
|
||||
my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
|
||||
|
||||
Arguments: ?$name, $code, ?\%captures, ?\%options
|
||||
|
||||
$name is the subroutine where the coderef will be installed.
|
||||
|
||||
$code is a string that will be turned into code.
|
||||
|
||||
"\%captures" is a hashref of variables that will be made available to
|
||||
the code. The keys should be the full name of the variable to be made
|
||||
available, including the sigil. The values should be references to the
|
||||
values. The variables will contain copies of the values. See the
|
||||
"SYNOPSIS"'s "Silly::dagron" for an example using captures.
|
||||
|
||||
Exported by default.
|
||||
|
||||
options
|
||||
"no_install"
|
||||
Boolean. Set this option to not install the generated coderef into the
|
||||
passed subroutine name on undefer.
|
||||
|
||||
"no_defer"
|
||||
Boolean. Prevents a Sub::Defer wrapper from being generated for the
|
||||
quoted sub. If the sub will most likely be called at some point,
|
||||
setting this is a good idea. For a sub that will most likely be
|
||||
inlined, it is not recommended.
|
||||
|
||||
"package"
|
||||
The package that the quoted sub will be evaluated in. If not
|
||||
specified, the package from sub calling "quote_sub" will be used.
|
||||
|
||||
"hints"
|
||||
The value of $^H to use for the code being evaluated. This captures
|
||||
the settings of the strict pragma. If not specified, the value from
|
||||
the calling code will be used.
|
||||
|
||||
"warning_bits"
|
||||
The value of "${^WARNING_BITS}" to use for the code being evaluated.
|
||||
This captures the warnings set. If not specified, the warnings from
|
||||
the calling code will be used.
|
||||
|
||||
"%^H"
|
||||
The value of "%^H" to use for the code being evaluated. This captures
|
||||
additional pragma settings. If not specified, the value from the
|
||||
calling code will be used if possible (on perl 5.10+).
|
||||
|
||||
"attributes"
|
||||
The "Subroutine Attributes" in perlsub to apply to the sub generated.
|
||||
Should be specified as an array reference. The attributes will be
|
||||
applied to both the generated sub and the deferred wrapper, if one is
|
||||
used.
|
||||
|
||||
"file"
|
||||
The apparent filename to use for the code being evaluated.
|
||||
|
||||
"line"
|
||||
The apparent line number to use for the code being evaluated.
|
||||
|
||||
unquote_sub
|
||||
my $coderef = unquote_sub $sub;
|
||||
|
||||
Forcibly replace subroutine with actual code.
|
||||
|
||||
If $sub is not a quoted sub, this is a no-op.
|
||||
|
||||
Exported by default.
|
||||
|
||||
quoted_from_sub
|
||||
my $data = quoted_from_sub $sub;
|
||||
|
||||
my ($name, $code, $captures, $compiled_sub) = @$data;
|
||||
|
||||
Returns original arguments to quote_sub, plus the compiled version if
|
||||
this sub has already been unquoted.
|
||||
|
||||
Note that $sub can be either the original quoted version or the compiled
|
||||
version for convenience.
|
||||
|
||||
Exported by default.
|
||||
|
||||
inlinify
|
||||
my $prelude = capture_unroll '$captures', {
|
||||
'$x' => 1,
|
||||
'$y' => 2,
|
||||
}, 4;
|
||||
|
||||
my $inlined_code = inlinify q{
|
||||
my ($x, $y) = @_;
|
||||
|
||||
print $x + $y . "\n";
|
||||
}, '$x, $y', $prelude;
|
||||
|
||||
Takes a string of code, a string of arguments, a string of code which
|
||||
acts as a "prelude", and a Boolean representing whether or not to
|
||||
localize the arguments.
|
||||
|
||||
quotify
|
||||
my $quoted_value = quotify $value;
|
||||
|
||||
Quotes a single (non-reference) scalar value for use in a code string.
|
||||
The result should reproduce the original value, including strings,
|
||||
undef, integers, and floating point numbers. The resulting floating
|
||||
point numbers (including infinites and not a number) should be precisely
|
||||
equal to the original, if possible. The exact format of the resulting
|
||||
number should not be relied on, as it may include hex floats or math
|
||||
expressions.
|
||||
|
||||
capture_unroll
|
||||
my $prelude = capture_unroll '$captures', {
|
||||
'$x' => 1,
|
||||
'$y' => 2,
|
||||
}, 4;
|
||||
|
||||
Arguments: $from, \%captures, $indent
|
||||
|
||||
Generates a snippet of code which is suitable to be used as a prelude
|
||||
for "inlinify". $from is a string will be used as a hashref in the
|
||||
resulting code. The keys of %captures are the names of the variables and
|
||||
the values are ignored. $indent is the number of spaces to indent the
|
||||
result by.
|
||||
|
||||
qsub
|
||||
my $hash = {
|
||||
coderef => qsub q{ print "hello"; },
|
||||
other => 5,
|
||||
};
|
||||
|
||||
Arguments: $code
|
||||
|
||||
Works exactly like "quote_sub", but includes a prototype to only accept
|
||||
a single parameter. This makes it easier to include in hash structures
|
||||
or lists.
|
||||
|
||||
Exported by default.
|
||||
|
||||
sanitize_identifier
|
||||
my $var_name = '$variable_for_' . sanitize_identifier('@name');
|
||||
quote_sub qq{ print \$${var_name} }, { $var_name => \$value };
|
||||
|
||||
Arguments: $identifier
|
||||
|
||||
Sanitizes a value so that it can be used in an identifier.
|
||||
|
||||
ENVIRONMENT
|
||||
SUB_QUOTE_DEBUG
|
||||
Causes code to be output to "STDERR" before being evaled. Several forms
|
||||
are supported:
|
||||
|
||||
1 All subs will be output.
|
||||
|
||||
"/foo/"
|
||||
Subs will be output if their code matches the given regular
|
||||
expression.
|
||||
|
||||
"simple_identifier"
|
||||
Any sub with the given name will be output.
|
||||
|
||||
"Full::identifier"
|
||||
A sub matching the full name will be output.
|
||||
|
||||
"Package::Name::"
|
||||
Any sub in the given package (including anonymous subs) will be
|
||||
output.
|
||||
|
||||
CAVEATS
|
||||
Much of this is just string-based code-generation, and as a result, a
|
||||
few caveats apply.
|
||||
|
||||
return
|
||||
Calling "return" from a quote_sub'ed sub will not likely do what you
|
||||
intend. Instead of returning from the code you defined in "quote_sub",
|
||||
it will return from the overall function it is composited into.
|
||||
|
||||
So when you pass in:
|
||||
|
||||
quote_sub q{ return 1 if $condition; $morecode }
|
||||
|
||||
It might turn up in the intended context as follows:
|
||||
|
||||
sub foo {
|
||||
|
||||
<important code a>
|
||||
do {
|
||||
return 1 if $condition;
|
||||
$morecode
|
||||
};
|
||||
<important code b>
|
||||
|
||||
}
|
||||
|
||||
Which will obviously return from foo, when all you meant to do was
|
||||
return from the code context in quote_sub and proceed with running
|
||||
important code b.
|
||||
|
||||
pragmas
|
||||
"Sub::Quote" preserves the environment of the code creating the quoted
|
||||
subs. This includes the package, strict, warnings, and any other lexical
|
||||
pragmas. This is done by prefixing the code with a block that sets up a
|
||||
matching environment. When inlining "Sub::Quote" subs, care should be
|
||||
taken that user pragmas won't effect the rest of the code.
|
||||
|
||||
SUPPORT
|
||||
Users' IRC: #moose on irc.perl.org
|
||||
|
||||
Development and contribution IRC: #web-simple on irc.perl.org
|
||||
|
||||
Bugtracker:
|
||||
<https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote>
|
||||
|
||||
Git repository: <git://github.com/moose/Sub-Quote.git>
|
||||
|
||||
Git browser: <https://github.com/moose/Sub-Quote>
|
||||
|
||||
AUTHOR
|
||||
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
|
||||
|
||||
CONTRIBUTORS
|
||||
frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
|
||||
|
||||
ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
|
||||
|
||||
Mithaldu - Christian Walde (cpan:MITHALDU)
|
||||
<walde.christian@googlemail.com>
|
||||
|
||||
tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
|
||||
|
||||
haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
|
||||
|
||||
bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
|
||||
|
||||
ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
|
||||
|
||||
dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
|
||||
|
||||
alexbio - Alessandro Ghedini (cpan:ALEXBIO) <alexbio@cpan.org>
|
||||
|
||||
getty - Torsten Raudssus (cpan:GETTY) <torsten@raudss.us>
|
||||
|
||||
arcanez - Justin Hunter (cpan:ARCANEZ) <justin.d.hunter@gmail.com>
|
||||
|
||||
kanashiro - Lucas Kanashiro (cpan:KANASHIRO)
|
||||
<kanashiro.duarte@gmail.com>
|
||||
|
||||
djerius - Diab Jerius (cpan:DJERIUS) <djerius@cfa.harvard.edu>
|
||||
|
||||
COPYRIGHT
|
||||
Copyright (c) 2010-2016 the Sub::Quote "AUTHOR" and "CONTRIBUTORS" as
|
||||
listed above.
|
||||
|
||||
LICENSE
|
||||
This library is free software and may be distributed under the same
|
||||
terms as perl itself. See <http://dev.perl.org/licenses/>.
|
||||
|
||||
|
|
@ -0,0 +1,312 @@
|
|||
package Sub::Defer;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter qw(import);
|
||||
use Scalar::Util qw(weaken);
|
||||
use Carp qw(croak);
|
||||
|
||||
our $VERSION = '2.006006';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
our @EXPORT = qw(defer_sub undefer_sub undefer_all);
|
||||
our @EXPORT_OK = qw(undefer_package defer_info);
|
||||
|
||||
sub _getglob { no strict 'refs'; \*{$_[0]} }
|
||||
|
||||
BEGIN {
|
||||
my $no_subname;
|
||||
*_subname
|
||||
= defined &Sub::Util::set_subname ? \&Sub::Util::set_subname
|
||||
: defined &Sub::Name::subname ? \&Sub::Name::subname
|
||||
: (eval { require Sub::Util } && defined &Sub::Util::set_subname) ? \&Sub::Util::set_subname
|
||||
: (eval { require Sub::Name } && defined &Sub::Name::subname ) ? \&Sub::Name::subname
|
||||
: ($no_subname = 1, sub { $_[1] });
|
||||
*_CAN_SUBNAME = $no_subname ? sub(){0} : sub(){1};
|
||||
}
|
||||
|
||||
sub _name_coderef {
|
||||
shift if @_ > 2; # three args is (target, name, sub)
|
||||
_CAN_SUBNAME ? _subname(@_) : $_[1];
|
||||
}
|
||||
|
||||
sub _install_coderef {
|
||||
my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
|
||||
no warnings 'redefine';
|
||||
if (*{$glob}{CODE}) {
|
||||
*{$glob} = $code;
|
||||
}
|
||||
# perl will sometimes warn about mismatched prototypes coming from the
|
||||
# inheritance cache, so disable them if we aren't redefining a sub
|
||||
else {
|
||||
no warnings 'prototype';
|
||||
*{$glob} = $code;
|
||||
}
|
||||
}
|
||||
|
||||
# We are dealing with three subs. The first is the generator sub. It is
|
||||
# provided by the user, so we cannot modify it. When called, it generates the
|
||||
# undeferred sub. This is also created, so it also cannot be modified. These
|
||||
# are wrapped in a third sub. The deferred sub is generated by us, and when
|
||||
# called it uses the generator sub to create the undeferred sub. If it is a
|
||||
# named sub, it is installed in the symbol table, usually overwriting the
|
||||
# deferred sub. From then on, the deferred sub will goto the undeferred sub
|
||||
# if it is called.
|
||||
#
|
||||
# In %DEFERRED we store array refs with information about these subs. The key
|
||||
# is the stringified subref. We have a CLONE method to fix this up in the
|
||||
# case of threading to deal with changing refaddrs. The arrayrefs contain:
|
||||
#
|
||||
# 0. fully qualified sub name (or undef)
|
||||
# 1. generator sub
|
||||
# 2. options (attributes)
|
||||
# 3. scalar ref to undeferred sub (inner reference weakened)
|
||||
# 4. deferred sub (deferred only)
|
||||
# 5. info arrayref for undeferred sub (deferred only, after undefer)
|
||||
#
|
||||
# The deferred sub contains a strong reference to its info arrayref, and the
|
||||
# undeferred.
|
||||
|
||||
our %DEFERRED;
|
||||
|
||||
sub undefer_sub {
|
||||
my ($deferred) = @_;
|
||||
my $info = $DEFERRED{$deferred} or return $deferred;
|
||||
my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
|
||||
|
||||
if (!(
|
||||
$deferred_sub && $deferred eq $deferred_sub
|
||||
|| ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
|
||||
)) {
|
||||
return $deferred;
|
||||
}
|
||||
|
||||
return ${$undeferred_ref}
|
||||
if ${$undeferred_ref};
|
||||
${$undeferred_ref} = my $made = $maker->();
|
||||
|
||||
# make sure the method slot has not changed since deferral time
|
||||
if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
|
||||
no warnings 'redefine';
|
||||
|
||||
# I believe $maker already evals with the right package/name, so that
|
||||
# _install_coderef calls are not necessary --ribasushi
|
||||
*{_getglob($target)} = $made;
|
||||
}
|
||||
my $undefer_info = [ $target, $maker, $options, $undeferred_ref ];
|
||||
$info->[5] = $DEFERRED{$made} = $undefer_info;
|
||||
weaken ${$undefer_info->[3]};
|
||||
|
||||
return $made;
|
||||
}
|
||||
|
||||
sub undefer_all {
|
||||
undefer_sub($_) for keys %DEFERRED;
|
||||
return;
|
||||
}
|
||||
|
||||
sub undefer_package {
|
||||
my $package = shift;
|
||||
undefer_sub($_)
|
||||
for grep {
|
||||
my $name = $DEFERRED{$_} && $DEFERRED{$_}[0];
|
||||
$name && $name =~ /^${package}::[^:]+$/
|
||||
} keys %DEFERRED;
|
||||
return;
|
||||
}
|
||||
|
||||
sub defer_info {
|
||||
my ($deferred) = @_;
|
||||
my $info = $DEFERRED{$deferred||''} or return undef;
|
||||
|
||||
my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
|
||||
if (!(
|
||||
$deferred_sub && $deferred eq $deferred_sub
|
||||
|| ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
|
||||
)) {
|
||||
delete $DEFERRED{$deferred};
|
||||
return undef;
|
||||
}
|
||||
[
|
||||
$target, $maker, $options,
|
||||
( $undeferred_ref && $$undeferred_ref ? $$undeferred_ref : ()),
|
||||
];
|
||||
}
|
||||
|
||||
sub defer_sub {
|
||||
my ($target, $maker, $options) = @_;
|
||||
my $package;
|
||||
my $subname;
|
||||
($package, $subname) = $target =~ /^(.*)::([^:]+)$/
|
||||
or croak "$target is not a fully qualified sub name!"
|
||||
if $target;
|
||||
$package ||= $options && $options->{package} || caller;
|
||||
my @attributes = @{$options && $options->{attributes} || []};
|
||||
if (@attributes) {
|
||||
/\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
|
||||
for @attributes;
|
||||
}
|
||||
my $deferred;
|
||||
my $undeferred;
|
||||
my $deferred_info = [ $target, $maker, $options, \$undeferred ];
|
||||
if (@attributes || $target && !_CAN_SUBNAME) {
|
||||
my $code
|
||||
= q[#line ].(__LINE__+2).q[ "].__FILE__.qq["\n]
|
||||
. qq[package $package;\n]
|
||||
. ($target ? "sub $subname" : '+sub') . join('', map " :$_", @attributes)
|
||||
. q[ {
|
||||
package Sub::Defer;
|
||||
# uncoverable subroutine
|
||||
# uncoverable statement
|
||||
$undeferred ||= undefer_sub($deferred_info->[4]);
|
||||
goto &$undeferred; # uncoverable statement
|
||||
$undeferred; # fake lvalue return
|
||||
}]."\n"
|
||||
. ($target ? "\\&$subname" : '');
|
||||
my $e;
|
||||
$deferred = do {
|
||||
no warnings qw(redefine closure);
|
||||
local $@;
|
||||
eval $code or $e = $@; # uncoverable branch true
|
||||
};
|
||||
die $e if defined $e; # uncoverable branch true
|
||||
}
|
||||
else {
|
||||
# duplicated from above
|
||||
$deferred = sub {
|
||||
$undeferred ||= undefer_sub($deferred_info->[4]);
|
||||
goto &$undeferred;
|
||||
};
|
||||
_install_coderef($target, $deferred)
|
||||
if $target;
|
||||
}
|
||||
weaken($deferred_info->[4] = $deferred);
|
||||
weaken($DEFERRED{$deferred} = $deferred_info);
|
||||
return $deferred;
|
||||
}
|
||||
|
||||
sub CLONE {
|
||||
%DEFERRED = map {
|
||||
defined $_ ? (
|
||||
$_->[4] ? ($_->[4] => $_)
|
||||
: ($_->[3] && ${$_->[3]}) ? (${$_->[3]} => $_)
|
||||
: ()
|
||||
) : ()
|
||||
} values %DEFERRED;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Sub::Defer - Defer generation of subroutines until they are first called
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Sub::Defer;
|
||||
|
||||
my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
|
||||
my $t = time;
|
||||
sub { time - $t };
|
||||
};
|
||||
|
||||
Logger->time_since_first_log; # returns 0 and replaces itself
|
||||
Logger->time_since_first_log; # returns time - $t
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These subroutines provide the user with a convenient way to defer creation of
|
||||
subroutines and methods until they are first called.
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=head2 defer_sub
|
||||
|
||||
my $coderef = defer_sub $name => sub { ... }, \%options;
|
||||
|
||||
This subroutine returns a coderef that encapsulates the provided sub - when
|
||||
it is first called, the provided sub is called and is -itself- expected to
|
||||
return a subroutine which will be goto'ed to on subsequent calls.
|
||||
|
||||
If a name is provided, this also installs the sub as that name - and when
|
||||
the subroutine is undeferred will re-install the final version for speed.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head3 Options
|
||||
|
||||
A hashref of options can optionally be specified.
|
||||
|
||||
=over 4
|
||||
|
||||
=item package
|
||||
|
||||
The package to generate the sub in. Will be overridden by a fully qualified
|
||||
C<$name> option. If not specified, will default to the caller's package.
|
||||
|
||||
=item attributes
|
||||
|
||||
The L<perlsub/Subroutine Attributes> to apply to the sub generated. Should be
|
||||
specified as an array reference.
|
||||
|
||||
=back
|
||||
|
||||
=head2 undefer_sub
|
||||
|
||||
my $coderef = undefer_sub \&Foo::name;
|
||||
|
||||
If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
|
||||
If the passed coderef has not been deferred, this will just return it.
|
||||
|
||||
If this is confusing, take a look at the example in the L</SYNOPSIS>.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head2 defer_info
|
||||
|
||||
my $data = defer_info $sub;
|
||||
my ($name, $generator, $options, $undeferred_sub) = @$data;
|
||||
|
||||
Returns original arguments to defer_sub, plus the undeferred version if this
|
||||
sub has already been undeferred.
|
||||
|
||||
Note that $sub can be either the original deferred version or the undeferred
|
||||
version for convenience.
|
||||
|
||||
Not exported by default.
|
||||
|
||||
=head2 undefer_all
|
||||
|
||||
undefer_all();
|
||||
|
||||
This will undefer all deferred subs in one go. This can be very useful in a
|
||||
forking environment where child processes would each have to undefer the same
|
||||
subs. By calling this just before you start forking children you can undefer
|
||||
all currently deferred subs in the parent so that the children do not have to
|
||||
do it. Note this may bake the behavior of some subs that were intended to
|
||||
calculate their behavior later, so it shouldn't be used midway through a
|
||||
module load or class definition.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head2 undefer_package
|
||||
|
||||
undefer_package($package);
|
||||
|
||||
This undefers all deferred subs in a package.
|
||||
|
||||
Not exported by default.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
See L<Sub::Quote> for support and contact information.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
See L<Sub::Quote> for authors.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
See L<Sub::Quote> for the copyright and license.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,713 @@
|
|||
package Sub::Quote;
|
||||
|
||||
sub _clean_eval { eval $_[0] }
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sub::Defer qw(defer_sub);
|
||||
use Scalar::Util qw(weaken);
|
||||
use Exporter qw(import);
|
||||
use Carp qw(croak);
|
||||
BEGIN { our @CARP_NOT = qw(Sub::Defer) }
|
||||
use B ();
|
||||
BEGIN {
|
||||
*_HAVE_IS_UTF8 = defined &utf8::is_utf8 ? sub(){1} : sub(){0};
|
||||
*_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
|
||||
*_BAD_BACKSLASH_ESCAPE = _HAVE_PERLSTRING() && "$]" == 5.010_000 ? sub(){1} : sub(){0};
|
||||
*_HAVE_HEX_FLOAT = !$ENV{SUB_QUOTE_NO_HEX_FLOAT} && "$]" >= 5.022 ? sub(){1} : sub(){0};
|
||||
|
||||
# This may not be perfect, as we can't tell the format purely from the size
|
||||
# but it should cover the common cases, and other formats are more likely to
|
||||
# be less precise.
|
||||
my $nvsize = 8 * length pack 'F', 0;
|
||||
my $nvmantbits
|
||||
= $nvsize == 16 ? 11
|
||||
: $nvsize == 32 ? 24
|
||||
: $nvsize == 64 ? 53
|
||||
: $nvsize == 80 ? 64
|
||||
: $nvsize == 128 ? 113
|
||||
: $nvsize == 256 ? 237
|
||||
: 237 # unknown float format
|
||||
;
|
||||
my $precision = int( log(2)/log(10)*$nvmantbits );
|
||||
|
||||
*_NVSIZE = sub(){$nvsize};
|
||||
*_NVMANTBITS = sub(){$nvmantbits};
|
||||
*_FLOAT_PRECISION = sub(){$precision};
|
||||
}
|
||||
|
||||
our $VERSION = '2.006006';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
|
||||
our @EXPORT_OK = qw(quotify capture_unroll inlinify sanitize_identifier);
|
||||
|
||||
our %QUOTED;
|
||||
|
||||
my %escape;
|
||||
if (_BAD_BACKSLASH_ESCAPE) {
|
||||
%escape = (
|
||||
(map +(chr($_) => sprintf '\x%02x', $_), 0 .. 0x31, 0x7f),
|
||||
"\t" => "\\t",
|
||||
"\n" => "\\n",
|
||||
"\r" => "\\r",
|
||||
"\f" => "\\f",
|
||||
"\b" => "\\b",
|
||||
"\a" => "\\a",
|
||||
"\e" => "\\e",
|
||||
(map +($_ => "\\$_"), qw(" \ $ @)),
|
||||
);
|
||||
}
|
||||
|
||||
sub quotify {
|
||||
my $value = $_[0];
|
||||
no warnings 'numeric';
|
||||
! defined $value ? 'undef()'
|
||||
# numeric detection
|
||||
: (!(_HAVE_IS_UTF8 && utf8::is_utf8($value))
|
||||
&& length( (my $dummy = '') & $value )
|
||||
&& 0 + $value eq $value
|
||||
) ? (
|
||||
$value != $value ? (
|
||||
$value eq (9**9**9*0)
|
||||
? '(9**9**9*0)' # nan
|
||||
: '(-(9**9**9*0))' # -nan
|
||||
)
|
||||
: $value == 9**9**9 ? '(9**9**9)' # inf
|
||||
: $value == -9**9**9 ? '(-9**9**9)' # -inf
|
||||
: $value == 0 ? (
|
||||
sprintf('%g', $value) eq '-0' ? '-0.0' : '0',
|
||||
)
|
||||
: $value !~ /[e.]/i ? (
|
||||
$value > 0 ? (sprintf '%u', $value)
|
||||
: (sprintf '%d', $value)
|
||||
)
|
||||
: do {
|
||||
my $float = $value;
|
||||
my $max_factor = int( log( abs($value) ) / log(2) ) - _NVMANTBITS;
|
||||
my $ex_sign = $max_factor > 0 ? 1 : -1;
|
||||
FACTOR: for my $ex (0 .. abs($max_factor)) {
|
||||
my $num = $value / 2**($ex_sign * $ex);
|
||||
for my $precision (_FLOAT_PRECISION .. _FLOAT_PRECISION+2) {
|
||||
my $formatted = sprintf '%.'.$precision.'g', $num;
|
||||
$float = $formatted
|
||||
if $ex == 0;
|
||||
if ($formatted == $num) {
|
||||
if ($ex) {
|
||||
$float
|
||||
= $formatted
|
||||
. ($ex_sign == 1 ? '*' : '/')
|
||||
. (
|
||||
$ex > _NVMANTBITS
|
||||
? "2**$ex"
|
||||
: sprintf('%u', 2**$ex)
|
||||
);
|
||||
}
|
||||
last FACTOR;
|
||||
}
|
||||
}
|
||||
if (_HAVE_HEX_FLOAT) {
|
||||
$float = sprintf '%a', $value;
|
||||
last FACTOR;
|
||||
}
|
||||
}
|
||||
"$float";
|
||||
}
|
||||
)
|
||||
: !length($value) && length( (my $dummy2 = '') & $value ) ? '(!1)' # false
|
||||
: _BAD_BACKSLASH_ESCAPE && _HAVE_IS_UTF8 && utf8::is_utf8($value) ? do {
|
||||
$value =~ s/(["\$\@\\[:cntrl:]]|[^\x00-\x7f])/
|
||||
$escape{$1} || sprintf('\x{%x}', ord($1))
|
||||
/ge;
|
||||
qq["$value"];
|
||||
}
|
||||
: _HAVE_PERLSTRING ? B::perlstring($value)
|
||||
: qq["\Q$value\E"];
|
||||
}
|
||||
|
||||
sub sanitize_identifier {
|
||||
my $name = shift;
|
||||
$name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
|
||||
$name;
|
||||
}
|
||||
|
||||
sub capture_unroll {
|
||||
my ($from, $captures, $indent) = @_;
|
||||
join(
|
||||
'',
|
||||
map {
|
||||
/^([\@\%\$])/
|
||||
or croak "capture key should start with \@, \% or \$: $_";
|
||||
(' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
|
||||
} keys %$captures
|
||||
);
|
||||
}
|
||||
|
||||
sub inlinify {
|
||||
my ($code, $args, $extra, $local) = @_;
|
||||
$args = '()'
|
||||
if !defined $args;
|
||||
my $do = 'do { '.($extra||'');
|
||||
if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
|
||||
$do .= $1;
|
||||
}
|
||||
if ($code =~ s{
|
||||
\A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
|
||||
(^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
|
||||
}{}xms) {
|
||||
my ($pre, $indent, $code_args) = ($1, $2, $3);
|
||||
$do .= $pre;
|
||||
if ($code_args ne $args) {
|
||||
$do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
|
||||
}
|
||||
}
|
||||
elsif ($local || $args ne '@_') {
|
||||
$do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
|
||||
}
|
||||
$do.$code.' }';
|
||||
}
|
||||
|
||||
sub quote_sub {
|
||||
# HOLY DWIMMERY, BATMAN!
|
||||
# $name => $code => \%captures => \%options
|
||||
# $name => $code => \%captures
|
||||
# $name => $code
|
||||
# $code => \%captures => \%options
|
||||
# $code
|
||||
my $options =
|
||||
(ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
|
||||
? pop
|
||||
: {};
|
||||
my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
|
||||
undef($captures) if $captures && !keys %$captures;
|
||||
my $code = pop;
|
||||
my $name = $_[0];
|
||||
if ($name) {
|
||||
my $subname = $name;
|
||||
my $package = $subname =~ s/(.*)::// ? $1 : caller;
|
||||
$name = join '::', $package, $subname;
|
||||
croak qq{package name "$package" too long!}
|
||||
if length $package > 252;
|
||||
croak qq{package name "$package" is not valid!}
|
||||
unless $package =~ /^[^\d\W]\w*(?:::\w+)*$/;
|
||||
croak qq{sub name "$subname" too long!}
|
||||
if length $subname > 252;
|
||||
croak qq{sub name "$subname" is not valid!}
|
||||
unless $subname =~ /^[^\d\W]\w*$/;
|
||||
}
|
||||
my @caller = caller(0);
|
||||
my ($attributes, $file, $line) = @{$options}{qw(attributes file line)};
|
||||
if ($attributes) {
|
||||
/\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
|
||||
for @$attributes;
|
||||
}
|
||||
my $quoted_info = {
|
||||
name => $name,
|
||||
code => $code,
|
||||
captures => $captures,
|
||||
package => (exists $options->{package} ? $options->{package} : $caller[0]),
|
||||
hints => (exists $options->{hints} ? $options->{hints} : $caller[8]),
|
||||
warning_bits => (exists $options->{warning_bits} ? $options->{warning_bits} : $caller[9]),
|
||||
hintshash => (exists $options->{hintshash} ? $options->{hintshash} : $caller[10]),
|
||||
($attributes ? (attributes => $attributes) : ()),
|
||||
($file ? (file => $file) : ()),
|
||||
($line ? (line => $line) : ()),
|
||||
};
|
||||
my $unquoted;
|
||||
weaken($quoted_info->{unquoted} = \$unquoted);
|
||||
if ($options->{no_defer}) {
|
||||
my $fake = \my $var;
|
||||
local $QUOTED{$fake} = $quoted_info;
|
||||
my $sub = unquote_sub($fake);
|
||||
Sub::Defer::_install_coderef($name, $sub) if $name && !$options->{no_install};
|
||||
return $sub;
|
||||
}
|
||||
else {
|
||||
my $deferred = defer_sub(
|
||||
($options->{no_install} ? undef : $name),
|
||||
sub {
|
||||
$unquoted if 0;
|
||||
unquote_sub($quoted_info->{deferred});
|
||||
},
|
||||
{
|
||||
($attributes ? ( attributes => $attributes ) : ()),
|
||||
($name ? () : ( package => $quoted_info->{package} )),
|
||||
},
|
||||
);
|
||||
weaken($quoted_info->{deferred} = $deferred);
|
||||
weaken($QUOTED{$deferred} = $quoted_info);
|
||||
return $deferred;
|
||||
}
|
||||
}
|
||||
|
||||
sub _context {
|
||||
my $info = shift;
|
||||
$info->{context} ||= do {
|
||||
my ($package, $hints, $warning_bits, $hintshash, $file, $line)
|
||||
= @{$info}{qw(package hints warning_bits hintshash file line)};
|
||||
|
||||
$line ||= 1
|
||||
if $file;
|
||||
|
||||
my $line_mark = '';
|
||||
if ($line) {
|
||||
$line_mark = "#line ".($line-1);
|
||||
if ($file) {
|
||||
$line_mark .= qq{ "$file"};
|
||||
}
|
||||
$line_mark .= "\n";
|
||||
}
|
||||
|
||||
$info->{context}
|
||||
="# BEGIN quote_sub PRELUDE\n"
|
||||
."package $package;\n"
|
||||
."BEGIN {\n"
|
||||
." \$^H = ".quotify($hints).";\n"
|
||||
." \${^WARNING_BITS} = ".quotify($warning_bits).";\n"
|
||||
." \%^H = (\n"
|
||||
. join('', map
|
||||
" ".quotify($_)." => ".quotify($hintshash->{$_}).",\n",
|
||||
grep !(ref $hintshash->{$_} && $hintshash->{$_} =~ /\A(?:\w+(?:::\w+)*=)?[A-Z]+\(0x[[0-9a-fA-F]+\)\z/),
|
||||
keys %$hintshash)
|
||||
." );\n"
|
||||
."}\n"
|
||||
.$line_mark
|
||||
."# END quote_sub PRELUDE\n";
|
||||
};
|
||||
}
|
||||
|
||||
sub quoted_from_sub {
|
||||
my ($sub) = @_;
|
||||
my $quoted_info = $QUOTED{$sub||''} or return undef;
|
||||
my ($name, $code, $captures, $unquoted, $deferred)
|
||||
= @{$quoted_info}{qw(name code captures unquoted deferred)};
|
||||
$code = _context($quoted_info) . $code;
|
||||
$unquoted &&= $$unquoted;
|
||||
if (($deferred && $deferred eq $sub)
|
||||
|| ($unquoted && $unquoted eq $sub)) {
|
||||
return [ $name, $code, $captures, $unquoted, $deferred ];
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub unquote_sub {
|
||||
my ($sub) = @_;
|
||||
my $quoted_info = $QUOTED{$sub} or return undef;
|
||||
my $unquoted = $quoted_info->{unquoted};
|
||||
unless ($unquoted && $$unquoted) {
|
||||
my ($name, $code, $captures, $package, $attributes)
|
||||
= @{$quoted_info}{qw(name code captures package attributes)};
|
||||
|
||||
($package, $name) = $name =~ /(.*)::(.*)/
|
||||
if $name;
|
||||
|
||||
my %captures = $captures ? %$captures : ();
|
||||
$captures{'$_UNQUOTED'} = \$unquoted;
|
||||
$captures{'$_QUOTED'} = \$quoted_info;
|
||||
|
||||
my $make_sub
|
||||
= "{\n"
|
||||
. capture_unroll("\$_[1]", \%captures, 2)
|
||||
. " package ${package};\n"
|
||||
. (
|
||||
$name
|
||||
# disable the 'variable $x will not stay shared' warning since
|
||||
# we're not letting it escape from this scope anyway so there's
|
||||
# nothing trying to share it
|
||||
? " no warnings 'closure';\n sub ${name} "
|
||||
: " \$\$_UNQUOTED = sub "
|
||||
)
|
||||
. ($attributes ? join('', map ":$_ ", @$attributes) : '') . "{\n"
|
||||
. " (\$_QUOTED,\$_UNQUOTED) if 0;\n"
|
||||
. _context($quoted_info)
|
||||
. $code
|
||||
. " }".($name ? "\n \$\$_UNQUOTED = \\&${name}" : '') . ";\n"
|
||||
. "}\n"
|
||||
. "1;\n";
|
||||
if (my $debug = $ENV{SUB_QUOTE_DEBUG}) {
|
||||
if ($debug =~ m{^([^\W\d]\w*(?:::\w+)*(?:::)?)$}) {
|
||||
my $filter = $1;
|
||||
my $match
|
||||
= $filter =~ /::$/ ? $package.'::'
|
||||
: $filter =~ /::/ ? $package.'::'.($name||'__ANON__')
|
||||
: ($name||'__ANON__');
|
||||
warn $make_sub
|
||||
if $match eq $filter;
|
||||
}
|
||||
elsif ($debug =~ m{\A/(.*)/\z}s) {
|
||||
my $filter = $1;
|
||||
warn $make_sub
|
||||
if $code =~ $filter;
|
||||
}
|
||||
else {
|
||||
warn $make_sub;
|
||||
}
|
||||
}
|
||||
{
|
||||
no strict 'refs';
|
||||
local *{"${package}::${name}"} if $name;
|
||||
my ($success, $e);
|
||||
{
|
||||
local $@;
|
||||
$success = _clean_eval($make_sub, \%captures);
|
||||
$e = $@;
|
||||
}
|
||||
unless ($success) {
|
||||
my $space = length($make_sub =~ tr/\n//);
|
||||
my $line = 0;
|
||||
$make_sub =~ s/^/sprintf "%${space}d: ", ++$line/emg;
|
||||
croak "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
|
||||
}
|
||||
weaken($QUOTED{$$unquoted} = $quoted_info);
|
||||
}
|
||||
}
|
||||
$$unquoted;
|
||||
}
|
||||
|
||||
sub qsub ($) {
|
||||
goto "e_sub;
|
||||
}
|
||||
|
||||
sub CLONE {
|
||||
my @quoted = map { defined $_ ? (
|
||||
$_->{unquoted} && ${$_->{unquoted}} ? (${ $_->{unquoted} } => $_) : (),
|
||||
$_->{deferred} ? ($_->{deferred} => $_) : (),
|
||||
) : () } values %QUOTED;
|
||||
%QUOTED = @quoted;
|
||||
weaken($_) for values %QUOTED;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=encoding utf-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Sub::Quote - Efficient generation of subroutines via string eval
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Silly;
|
||||
|
||||
use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
|
||||
|
||||
quote_sub 'Silly::kitty', q{ print "meow" };
|
||||
|
||||
quote_sub 'Silly::doggy', q{ print "woof" };
|
||||
|
||||
my $sound = 0;
|
||||
|
||||
quote_sub 'Silly::dagron',
|
||||
q{ print ++$sound % 2 ? 'burninate' : 'roar' },
|
||||
{ '$sound' => \$sound };
|
||||
|
||||
And elsewhere:
|
||||
|
||||
Silly->kitty; # meow
|
||||
Silly->doggy; # woof
|
||||
Silly->dagron; # burninate
|
||||
Silly->dagron; # roar
|
||||
Silly->dagron; # burninate
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package provides performant ways to generate subroutines from strings.
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=head2 quote_sub
|
||||
|
||||
my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
|
||||
|
||||
Arguments: ?$name, $code, ?\%captures, ?\%options
|
||||
|
||||
C<$name> is the subroutine where the coderef will be installed.
|
||||
|
||||
C<$code> is a string that will be turned into code.
|
||||
|
||||
C<\%captures> is a hashref of variables that will be made available to the
|
||||
code. The keys should be the full name of the variable to be made available,
|
||||
including the sigil. The values should be references to the values. The
|
||||
variables will contain copies of the values. See the L</SYNOPSIS>'s
|
||||
C<Silly::dagron> for an example using captures.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head3 options
|
||||
|
||||
=over 2
|
||||
|
||||
=item C<no_install>
|
||||
|
||||
B<Boolean>. Set this option to not install the generated coderef into the
|
||||
passed subroutine name on undefer.
|
||||
|
||||
=item C<no_defer>
|
||||
|
||||
B<Boolean>. Prevents a Sub::Defer wrapper from being generated for the quoted
|
||||
sub. If the sub will most likely be called at some point, setting this is a
|
||||
good idea. For a sub that will most likely be inlined, it is not recommended.
|
||||
|
||||
=item C<package>
|
||||
|
||||
The package that the quoted sub will be evaluated in. If not specified, the
|
||||
package from sub calling C<quote_sub> will be used.
|
||||
|
||||
=item C<hints>
|
||||
|
||||
The value of L<< C<$^H> | perlvar/$^H >> to use for the code being evaluated.
|
||||
This captures the settings of the L<strict> pragma. If not specified, the value
|
||||
from the calling code will be used.
|
||||
|
||||
=item C<warning_bits>
|
||||
|
||||
The value of L<< C<${^WARNING_BITS}> | perlvar/${^WARNING_BITS} >> to use for
|
||||
the code being evaluated. This captures the L<warnings> set. If not specified,
|
||||
the warnings from the calling code will be used.
|
||||
|
||||
=item C<%^H>
|
||||
|
||||
The value of L<< C<%^H> | perlvar/%^H >> to use for the code being evaluated.
|
||||
This captures additional pragma settings. If not specified, the value from the
|
||||
calling code will be used if possible (on perl 5.10+).
|
||||
|
||||
=item C<attributes>
|
||||
|
||||
The L<perlsub/Subroutine Attributes> to apply to the sub generated. Should be
|
||||
specified as an array reference. The attributes will be applied to both the
|
||||
generated sub and the deferred wrapper, if one is used.
|
||||
|
||||
=item C<file>
|
||||
|
||||
The apparent filename to use for the code being evaluated.
|
||||
|
||||
=item C<line>
|
||||
|
||||
The apparent line number
|
||||
to use for the code being evaluated.
|
||||
|
||||
=back
|
||||
|
||||
=head2 unquote_sub
|
||||
|
||||
my $coderef = unquote_sub $sub;
|
||||
|
||||
Forcibly replace subroutine with actual code.
|
||||
|
||||
If $sub is not a quoted sub, this is a no-op.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head2 quoted_from_sub
|
||||
|
||||
my $data = quoted_from_sub $sub;
|
||||
|
||||
my ($name, $code, $captures, $compiled_sub) = @$data;
|
||||
|
||||
Returns original arguments to quote_sub, plus the compiled version if this
|
||||
sub has already been unquoted.
|
||||
|
||||
Note that $sub can be either the original quoted version or the compiled
|
||||
version for convenience.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head2 inlinify
|
||||
|
||||
my $prelude = capture_unroll '$captures', {
|
||||
'$x' => 1,
|
||||
'$y' => 2,
|
||||
}, 4;
|
||||
|
||||
my $inlined_code = inlinify q{
|
||||
my ($x, $y) = @_;
|
||||
|
||||
print $x + $y . "\n";
|
||||
}, '$x, $y', $prelude;
|
||||
|
||||
Takes a string of code, a string of arguments, a string of code which acts as a
|
||||
"prelude", and a B<Boolean> representing whether or not to localize the
|
||||
arguments.
|
||||
|
||||
=head2 quotify
|
||||
|
||||
my $quoted_value = quotify $value;
|
||||
|
||||
Quotes a single (non-reference) scalar value for use in a code string. The
|
||||
result should reproduce the original value, including strings, undef, integers,
|
||||
and floating point numbers. The resulting floating point numbers (including
|
||||
infinites and not a number) should be precisely equal to the original, if
|
||||
possible. The exact format of the resulting number should not be relied on, as
|
||||
it may include hex floats or math expressions.
|
||||
|
||||
=head2 capture_unroll
|
||||
|
||||
my $prelude = capture_unroll '$captures', {
|
||||
'$x' => 1,
|
||||
'$y' => 2,
|
||||
}, 4;
|
||||
|
||||
Arguments: $from, \%captures, $indent
|
||||
|
||||
Generates a snippet of code which is suitable to be used as a prelude for
|
||||
L</inlinify>. C<$from> is a string will be used as a hashref in the resulting
|
||||
code. The keys of C<%captures> are the names of the variables and the values
|
||||
are ignored. C<$indent> is the number of spaces to indent the result by.
|
||||
|
||||
=head2 qsub
|
||||
|
||||
my $hash = {
|
||||
coderef => qsub q{ print "hello"; },
|
||||
other => 5,
|
||||
};
|
||||
|
||||
Arguments: $code
|
||||
|
||||
Works exactly like L</quote_sub>, but includes a prototype to only accept a
|
||||
single parameter. This makes it easier to include in hash structures or lists.
|
||||
|
||||
Exported by default.
|
||||
|
||||
=head2 sanitize_identifier
|
||||
|
||||
my $var_name = '$variable_for_' . sanitize_identifier('@name');
|
||||
quote_sub qq{ print \$${var_name} }, { $var_name => \$value };
|
||||
|
||||
Arguments: $identifier
|
||||
|
||||
Sanitizes a value so that it can be used in an identifier.
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
=head2 SUB_QUOTE_DEBUG
|
||||
|
||||
Causes code to be output to C<STDERR> before being evaled. Several forms are
|
||||
supported:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<1>
|
||||
|
||||
All subs will be output.
|
||||
|
||||
=item C</foo/>
|
||||
|
||||
Subs will be output if their code matches the given regular expression.
|
||||
|
||||
=item C<simple_identifier>
|
||||
|
||||
Any sub with the given name will be output.
|
||||
|
||||
=item C<Full::identifier>
|
||||
|
||||
A sub matching the full name will be output.
|
||||
|
||||
=item C<Package::Name::>
|
||||
|
||||
Any sub in the given package (including anonymous subs) will be output.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Much of this is just string-based code-generation, and as a result, a few
|
||||
caveats apply.
|
||||
|
||||
=head2 return
|
||||
|
||||
Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
|
||||
Instead of returning from the code you defined in C<quote_sub>, it will return
|
||||
from the overall function it is composited into.
|
||||
|
||||
So when you pass in:
|
||||
|
||||
quote_sub q{ return 1 if $condition; $morecode }
|
||||
|
||||
It might turn up in the intended context as follows:
|
||||
|
||||
sub foo {
|
||||
|
||||
<important code a>
|
||||
do {
|
||||
return 1 if $condition;
|
||||
$morecode
|
||||
};
|
||||
<important code b>
|
||||
|
||||
}
|
||||
|
||||
Which will obviously return from foo, when all you meant to do was return from
|
||||
the code context in quote_sub and proceed with running important code b.
|
||||
|
||||
=head2 pragmas
|
||||
|
||||
C<Sub::Quote> preserves the environment of the code creating the
|
||||
quoted subs. This includes the package, strict, warnings, and any
|
||||
other lexical pragmas. This is done by prefixing the code with a
|
||||
block that sets up a matching environment. When inlining C<Sub::Quote>
|
||||
subs, care should be taken that user pragmas won't effect the rest
|
||||
of the code.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Users' IRC: #moose on irc.perl.org
|
||||
|
||||
=for :html
|
||||
L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org>
|
||||
|
||||
Development and contribution IRC: #web-simple on irc.perl.org
|
||||
|
||||
=for :html
|
||||
L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org>
|
||||
|
||||
Bugtracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote>
|
||||
|
||||
Git repository: L<git://github.com/moose/Sub-Quote.git>
|
||||
|
||||
Git browser: L<https://github.com/moose/Sub-Quote>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
|
||||
|
||||
ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
|
||||
|
||||
Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
|
||||
|
||||
tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
|
||||
|
||||
haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
|
||||
|
||||
bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
|
||||
|
||||
ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
|
||||
|
||||
dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
|
||||
|
||||
alexbio - Alessandro Ghedini (cpan:ALEXBIO) <alexbio@cpan.org>
|
||||
|
||||
getty - Torsten Raudssus (cpan:GETTY) <torsten@raudss.us>
|
||||
|
||||
arcanez - Justin Hunter (cpan:ARCANEZ) <justin.d.hunter@gmail.com>
|
||||
|
||||
kanashiro - Lucas Kanashiro (cpan:KANASHIRO) <kanashiro.duarte@gmail.com>
|
||||
|
||||
djerius - Diab Jerius (cpan:DJERIUS) <djerius@cfa.harvard.edu>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2010-2016 the Sub::Quote L</AUTHOR> and L</CONTRIBUTORS>
|
||||
as listed above.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software and may be distributed under the same terms
|
||||
as perl itself. See L<http://dev.perl.org/licenses/>.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") }
|
||||
use lib 'Distar/lib';
|
||||
use Distar 0.001;
|
||||
|
||||
use ExtUtils::MakeMaker 6.57_10 ();
|
||||
|
||||
author 'mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>';
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
use Test::More;
|
||||
use lib 't/lib';
|
||||
use ErrorLocation;
|
||||
|
||||
location_ok <<'END_CODE', 'Sub::Defer::defer_sub - unqualified name';
|
||||
use Sub::Defer qw(defer_sub);
|
||||
defer_sub 'welp' => sub { sub { 1 } };
|
||||
END_CODE
|
||||
|
||||
location_ok <<'END_CODE', 'Sub::Quote::quote_sub - long package';
|
||||
use Sub::Quote qw(quote_sub);
|
||||
quote_sub +("x" x 500).'::x', '1';
|
||||
END_CODE
|
||||
|
||||
location_ok <<'END_CODE', 'Sub::Quote::unquote_sub - bad captures';
|
||||
use Sub::Quote qw(unquote_sub quote_sub);
|
||||
unquote_sub quote_sub '1', { '&foo' => sub { 1 } };
|
||||
END_CODE
|
||||
|
||||
location_ok <<'END_CODE', 'Sub::Quote::unquote_sub - compile error';
|
||||
use Sub::Quote qw(unquote_sub quote_sub);
|
||||
unquote_sub quote_sub ' { ] } ';
|
||||
END_CODE
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,226 @@
|
|||
BEGIN {
|
||||
%^H = ();
|
||||
my %clear_hints = sub { %{(caller(0))[10]||{}} }->();
|
||||
$INC{'ClearHintsHash.pm'} = __FILE__;
|
||||
package ClearHintsHash;
|
||||
sub hints { %clear_hints }
|
||||
sub import {
|
||||
$^H |= 0x020000;
|
||||
%^H = hints;
|
||||
}
|
||||
}
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use Test::More;
|
||||
use Test::Fatal;
|
||||
|
||||
use Sub::Quote qw(
|
||||
quote_sub
|
||||
unquote_sub
|
||||
quoted_from_sub
|
||||
);
|
||||
|
||||
{
|
||||
use strict;
|
||||
no strict 'subs';
|
||||
local $TODO = "hints from caller not available on perl < 5.8"
|
||||
if "$]" < 5.008_000;
|
||||
like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} })->(); },
|
||||
qr/strict refs/,
|
||||
'hints preserved from context';
|
||||
}
|
||||
|
||||
{
|
||||
my $hints;
|
||||
{
|
||||
use strict;
|
||||
no strict 'subs';
|
||||
BEGIN { $hints = $^H }
|
||||
}
|
||||
like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} }, {}, { hints => $hints })->(); },
|
||||
qr/strict refs/,
|
||||
'hints used from options';
|
||||
}
|
||||
|
||||
{
|
||||
my $sub = do {
|
||||
no warnings;
|
||||
unquote_sub quote_sub(q{ 0 + undef });
|
||||
};
|
||||
my @warnings;
|
||||
local $SIG{__WARN__} = sub { push @warnings, @_ };
|
||||
$sub->();
|
||||
is scalar @warnings, 0,
|
||||
'"no warnings" preserved from context';
|
||||
}
|
||||
|
||||
{
|
||||
my $sub = do {
|
||||
no warnings;
|
||||
use warnings;
|
||||
unquote_sub quote_sub(q{ 0 + undef });
|
||||
};
|
||||
my @warnings;
|
||||
local $SIG{__WARN__} = sub { push @warnings, @_ };
|
||||
$sub->();
|
||||
like $warnings[0],
|
||||
qr/uninitialized/,
|
||||
'"use warnings" preserved from context';
|
||||
}
|
||||
|
||||
{
|
||||
my $warn_bits;
|
||||
eval q{
|
||||
use warnings FATAL => 'uninitialized';
|
||||
BEGIN { $warn_bits = ${^WARNING_BITS} }
|
||||
1;
|
||||
} or die $@;
|
||||
no warnings 'uninitialized';
|
||||
like exception { quote_sub(q{ 0 + undef }, {}, { warning_bits => $warn_bits })->(); },
|
||||
qr/uninitialized/,
|
||||
'warnings used from options';
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
package UseHintHash;
|
||||
$INC{'UseHintHash.pm'} = 1;
|
||||
|
||||
sub import {
|
||||
$^H |= 0x020000;
|
||||
$^H{__PACKAGE__.'/enabled'} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my %hints;
|
||||
{
|
||||
use ClearHintsHash;
|
||||
use UseHintHash;
|
||||
BEGIN { %hints = %^H }
|
||||
}
|
||||
|
||||
{
|
||||
local $TODO = 'hints hash from context not available on perl 5.8'
|
||||
if "$]" < 5.010_000;
|
||||
|
||||
use ClearHintsHash;
|
||||
use UseHintHash;
|
||||
is_deeply quote_sub(q{
|
||||
our %temp_hints_hash;
|
||||
BEGIN { %temp_hints_hash = %^H }
|
||||
\%temp_hints_hash;
|
||||
})->(), \%hints,
|
||||
'hints hash preserved from context';
|
||||
}
|
||||
|
||||
is_deeply quote_sub(q{
|
||||
our %temp_hints_hash;
|
||||
BEGIN { %temp_hints_hash = %^H }
|
||||
\%temp_hints_hash;
|
||||
}, {}, { hintshash => \%hints })->(), \%hints,
|
||||
'hints hash used from options';
|
||||
}
|
||||
|
||||
{
|
||||
use ClearHintsHash;
|
||||
my $sub = quote_sub(q{
|
||||
our %temp_hints_hash;
|
||||
BEGIN { %temp_hints_hash = %^H }
|
||||
\%temp_hints_hash;
|
||||
});
|
||||
my $wrap_sub = do {
|
||||
use UseHintHash;
|
||||
my (undef, $code, $cap) = @{quoted_from_sub($sub)};
|
||||
quote_sub $code, $cap||();
|
||||
};
|
||||
is_deeply $wrap_sub->(), { ClearHintsHash::hints },
|
||||
'empty hints maintained when inlined';
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
package BetterNumbers;
|
||||
$INC{'BetterNumbers.pm'} = 1;
|
||||
use overload ();
|
||||
|
||||
sub import {
|
||||
my ($class, $add) = @_;
|
||||
# closure vs not
|
||||
if (defined $add) {
|
||||
overload::constant 'integer', sub { $_[0] + $add };
|
||||
}
|
||||
else {
|
||||
overload::constant 'integer', sub { $_[0] + 1 };
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
TODO: {
|
||||
my ($options, $context_sub, $direct_val);
|
||||
{
|
||||
use BetterNumbers;
|
||||
BEGIN { $options = { hints => $^H, hintshash => { %^H } } }
|
||||
$direct_val = 10;
|
||||
$context_sub = quote_sub(q{ 10 });
|
||||
}
|
||||
my $options_sub = quote_sub(q{ 10 }, {}, $options);
|
||||
|
||||
is $direct_val, 11,
|
||||
'integer overload is working';
|
||||
|
||||
todo_skip "refs in hints hash not yet implemented", 4;
|
||||
{
|
||||
my $context_val;
|
||||
is exception { $context_val = $context_sub->() }, undef,
|
||||
'hints hash refs from context not broken';
|
||||
local $TODO = 'hints hash from context not available on perl 5.8'
|
||||
if !$TODO && "$]" < 5.010_000;
|
||||
is $context_val, 11,
|
||||
'hints hash refs preserved from context';
|
||||
}
|
||||
|
||||
{
|
||||
my $options_val;
|
||||
is exception { $options_val = $options_sub->() }, undef,
|
||||
'hints hash refs from options not broken';
|
||||
is $options_val, 11,
|
||||
'hints hash refs used from options';
|
||||
}
|
||||
}
|
||||
|
||||
TODO: {
|
||||
my ($options, $context_sub, $direct_val);
|
||||
{
|
||||
use BetterNumbers +2;
|
||||
BEGIN { $options = { hints => $^H, hintshash => { %^H } } }
|
||||
$direct_val = 10;
|
||||
$context_sub = quote_sub(q{ 10 });
|
||||
}
|
||||
my $options_sub = quote_sub(q{ 10 }, {}, $options);
|
||||
|
||||
is $direct_val, 12,
|
||||
'closure integer overload is working';
|
||||
|
||||
todo_skip "refs in hints hash not yet implemented", 4;
|
||||
|
||||
{
|
||||
my $context_val;
|
||||
is exception { $context_val = $context_sub->() }, undef,
|
||||
'hints hash closure refs from context not broken';
|
||||
local $TODO = 'hints hash from context not available on perl 5.8'
|
||||
if !$TODO && "$]" < 5.010_000;
|
||||
is $context_val, 12,
|
||||
'hints hash closure refs preserved from context';
|
||||
}
|
||||
|
||||
{
|
||||
my $options_val;
|
||||
is exception { $options_val = $options_sub->() }, undef,
|
||||
'hints hash closure refs from options not broken';
|
||||
is $options_val, 12,
|
||||
'hints hash closure refs used from options';
|
||||
}
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use Test::More;
|
||||
use Test::Fatal;
|
||||
use Data::Dumper;
|
||||
|
||||
use Sub::Quote qw(
|
||||
capture_unroll
|
||||
inlinify
|
||||
);
|
||||
|
||||
my $captures = {
|
||||
'$x' => \1,
|
||||
'$y' => \2,
|
||||
};
|
||||
my $prelude = capture_unroll '$captures', $captures, 4;
|
||||
{
|
||||
my $sub = eval
|
||||
"sub { $prelude"
|
||||
. '[ $x, $y ] }';
|
||||
is "$@", '', 'capture_unroll produces valid code';
|
||||
is_deeply $sub->(), [ 1, 2 ], 'unrolled variables get correct values';
|
||||
}
|
||||
|
||||
like exception {
|
||||
capture_unroll '$captures', { '&foo' => \sub { 5 } }, 4;
|
||||
}, qr/^capture key should start with @, % or \$/,
|
||||
'capture_unroll rejects vars other than scalar, hash, or array';
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
my ($x, $y) = @_;
|
||||
|
||||
[ $x, $y ];
|
||||
}, '$x, $y', $prelude;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is_deeply $sub->(), [ 1, 2 ], 'inlinified code get correct values';
|
||||
unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/,
|
||||
"matching variables aren't reassigned";
|
||||
}
|
||||
|
||||
{
|
||||
$Bar::baz = 3;
|
||||
my $inlined_code = inlinify q{
|
||||
package Bar;
|
||||
my ($x, $y) = @_;
|
||||
|
||||
[ $x, $y, our $baz ];
|
||||
}, '$x, $y', $prelude;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is_deeply $sub->(), [ 1, 2, 3 ], 'inlinified code get correct values';
|
||||
unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/,
|
||||
"matching variables aren't reassigned";
|
||||
}
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
my ($d, $f) = @_;
|
||||
|
||||
[ $d, $f ];
|
||||
}, '$x, $y', $prelude;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify with unmatched params produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is_deeply $sub->(), [ 1, 2 ], 'inlinified code get correct values';
|
||||
}
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
my $z = $_[0];
|
||||
$z;
|
||||
}, '$y', $prelude;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify with out @_ produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is $sub->(), 2, 'inlinified code get correct values';
|
||||
}
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
my $z = $_[0];
|
||||
$z;
|
||||
}, '@_', $prelude;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify with @_ as args produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is $sub->(5), 5, 'inlinified code get correct values';
|
||||
}
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
my $z = $_[0];
|
||||
$z;
|
||||
}, '$x', $prelude, 1;
|
||||
my $sub = eval "sub { [ $inlined_code, \@_ ] }";
|
||||
is "$@", '', 'inlinify with local produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is_deeply $sub->(5), [1, 5], 'inlinified code get correct values';
|
||||
}
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
219;
|
||||
}, undef, $prelude;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify without args produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is $sub->(), 219, 'inlinified code get correct values';
|
||||
}
|
||||
|
||||
{
|
||||
my $inlined_code = inlinify q{
|
||||
219;
|
||||
}, '@_', undef;
|
||||
my $sub = eval "sub { $inlined_code }";
|
||||
is "$@", '', 'inlinify without extra produces valid code'
|
||||
or diag "code:\n$inlined_code";
|
||||
is $sub->(), 219, 'inlinified code get correct values';
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use Test::More;
|
||||
use Test::Fatal;
|
||||
use Data::Dumper;
|
||||
|
||||
use Sub::Quote qw(
|
||||
quote_sub
|
||||
unquote_sub
|
||||
quoted_from_sub
|
||||
);
|
||||
|
||||
{
|
||||
my $foo = quote_sub '{}';
|
||||
my $foo_string = "$foo";
|
||||
undef $foo;
|
||||
|
||||
is quoted_from_sub($foo_string), undef,
|
||||
"quoted subs don't leak";
|
||||
|
||||
Sub::Quote->CLONE;
|
||||
ok !exists $Sub::Quote::QUOTED{$foo_string},
|
||||
'CLONE cleans out expired entries';
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = quote_sub '{}';
|
||||
my $foo_string = "$foo";
|
||||
Sub::Quote->CLONE;
|
||||
undef $foo;
|
||||
|
||||
is quoted_from_sub($foo_string), undef,
|
||||
"CLONE doesn't strengthen refs";
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = quote_sub '{}';
|
||||
my $foo_string = "$foo";
|
||||
my $foo_info = quoted_from_sub($foo_string);
|
||||
undef $foo;
|
||||
|
||||
is exception { Sub::Quote->CLONE }, undef,
|
||||
'CLONE works when quoted info saved externally';
|
||||
ok exists $Sub::Quote::QUOTED{$foo_string},
|
||||
'CLONE keeps entries that had info saved';
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = quote_sub '{}';
|
||||
my $foo_string = "$foo";
|
||||
my $foo_info = $Sub::Quote::QUOTED{$foo_string};
|
||||
undef $foo;
|
||||
|
||||
is exception { Sub::Quote->CLONE }, undef,
|
||||
'CLONE works when quoted info kept alive externally';
|
||||
ok !exists $Sub::Quote::QUOTED{$foo_string},
|
||||
'CLONE removes expired entries that were kept alive externally';
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = quote_sub '{}';
|
||||
my $foo_string = "$foo";
|
||||
my $sub = unquote_sub $foo;
|
||||
my $sub_string = "$sub";
|
||||
|
||||
Sub::Quote->CLONE;
|
||||
|
||||
ok quoted_from_sub($sub_string),
|
||||
'CLONE maintains entries referenced by unquoted sub';
|
||||
|
||||
undef $sub;
|
||||
ok quoted_from_sub($foo_string)->[3],
|
||||
'unquoted sub still available if quoted sub exists';
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
package ErrorLocation;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Test::Builder;
|
||||
use Carp qw(croak);
|
||||
use Exporter 'import';
|
||||
|
||||
our @EXPORT = qw(location_ok);
|
||||
|
||||
my $builder = Test::Builder->new;
|
||||
|
||||
my $gen = 'A000';
|
||||
sub location_ok ($$) {
|
||||
my ($code, $name) = @_;
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
my ($pre) = $code =~ /\A(.*?)(?:## fail\n.*)?\n?\z/s;
|
||||
my $fail_line = 1 + $pre =~ tr/\n//;
|
||||
my $PACKAGE = "LocationTest::_".++$gen;
|
||||
my $sub = eval qq{ sub {
|
||||
package $PACKAGE;
|
||||
#line 1 LocationTestFile
|
||||
$code
|
||||
} };
|
||||
my $full_trace;
|
||||
my $last_location;
|
||||
my $immediate;
|
||||
my $trace_capture = sub {
|
||||
my @c = caller;
|
||||
my ($location) = $_[0] =~ /^.* at (.*? line \d+)\.?$/;
|
||||
$location ||= sprintf "%s line %s", (caller(0))[1,2];
|
||||
if (!$last_location || $last_location ne $location) {
|
||||
$last_location = $location;
|
||||
$immediate = $c[1] eq 'LocationTestFile';
|
||||
{
|
||||
local %Carp::Internal;
|
||||
local %Carp::CarpInternal;
|
||||
$full_trace = Carp::longmess('');
|
||||
}
|
||||
$full_trace =~ s/\A.*\n//;
|
||||
$full_trace =~ s/^\t//mg;
|
||||
$full_trace =~ s/^[^\n]+ called at ${\__FILE__} line [0-9]+\n.*//ms;
|
||||
if ($c[0] eq 'Carp') {
|
||||
$full_trace =~ s/.*?(^Carp::)/$1/ms;
|
||||
}
|
||||
else {
|
||||
my ($arg) = @_;
|
||||
$arg =~ s/\Q at $c[1] line $c[2]\E\.\n\z//;
|
||||
my $caller = 'CORE::die(' . Carp::format_arg($arg) . ") called at $location\n";
|
||||
$full_trace =~ s/\A.*\n/$caller/;
|
||||
}
|
||||
$full_trace =~ s{^(.* called at )(\(eval [0-9]+\)(?:\[[^\]]*\])?) line ([0-9]+)\n}{
|
||||
my ($prefix, $file, $line) = ($1, $2, $3);
|
||||
my $i = 0;
|
||||
while (my @c = caller($i++)) {
|
||||
if ($c[1] eq $file && $c[2] eq $line) {
|
||||
$file .= "[$c[0]]";
|
||||
last;
|
||||
}
|
||||
}
|
||||
"$prefix$file line $line\n";
|
||||
}meg;
|
||||
$full_trace =~ s/^/ /mg;
|
||||
}
|
||||
};
|
||||
croak "$name - compile error: $@"
|
||||
if !$sub;
|
||||
local $@;
|
||||
eval {
|
||||
local $Carp::Verbose = 0;
|
||||
local $SIG{__WARN__};
|
||||
local $SIG{__DIE__} = $trace_capture;
|
||||
$sub->();
|
||||
1;
|
||||
} and croak "$name - code did not fail!";
|
||||
croak "died directly in test code: $@"
|
||||
if $immediate;
|
||||
delete $LocationTest::{"_$gen"};
|
||||
my ($location) = $@ =~ /.* at (.*? line \d+)\.?$/;
|
||||
$builder->is_eq($location, "LocationTestFile line $fail_line", $name)
|
||||
or $builder->diag(" error:\n $@\n full trace:\n$full_trace"), return !1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
package InlineModule;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN {
|
||||
*_HAS_PERLIO = "$]" >= 5.008_000 ? sub(){1} : sub(){0};
|
||||
}
|
||||
|
||||
sub import {
|
||||
my ($class, %modules) = @_;
|
||||
unshift @INC, inc_hook(%modules);
|
||||
}
|
||||
|
||||
sub inc_hook {
|
||||
my (%modules) = @_;
|
||||
my %files = map {
|
||||
(my $file = "$_.pm") =~ s{::}{/}g;
|
||||
$file => $modules{$_};
|
||||
} keys %modules;
|
||||
|
||||
sub {
|
||||
return
|
||||
unless exists $files{$_[1]};
|
||||
my $module = $files{$_[1]};
|
||||
if (!defined $module) {
|
||||
die "Can't locate $_[1] in \@INC (hidden) (\@INC contains: @INC).\n";
|
||||
}
|
||||
inc_module($module);
|
||||
}
|
||||
}
|
||||
|
||||
sub inc_module {
|
||||
my $code = $_[0];
|
||||
if (_HAS_PERLIO) {
|
||||
open my $fh, '<', \$code
|
||||
or die "error loading module: $!";
|
||||
return $fh;
|
||||
}
|
||||
else {
|
||||
my $pos = 0;
|
||||
my $last = length $code;
|
||||
return (sub {
|
||||
return 0 if $pos == $last;
|
||||
my $next = (1 + index $code, "\n", $pos) || $last;
|
||||
$_ .= substr $code, $pos, $next - $pos;
|
||||
$pos = $next;
|
||||
return 1;
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
package ThreadsCheck;
|
||||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
|
||||
sub _skip {
|
||||
print "1..0 # SKIP $_[0]\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub import {
|
||||
my ($class, $op) = @_;
|
||||
require Config;
|
||||
if (! $Config::Config{useithreads}) {
|
||||
_skip "your perl does not support ithreads";
|
||||
}
|
||||
elsif (system "$^X", __FILE__, 'installed') {
|
||||
_skip "threads.pm not installed";
|
||||
}
|
||||
elsif (system "$^X", __FILE__, 'create') {
|
||||
_skip "threads are broken on this machine";
|
||||
}
|
||||
}
|
||||
|
||||
if (!caller && @ARGV) {
|
||||
my ($op) = @ARGV;
|
||||
require POSIX;
|
||||
if ($op eq 'installed') {
|
||||
eval { require threads } or POSIX::_exit(1);
|
||||
}
|
||||
elsif ($op eq 'create') {
|
||||
require threads;
|
||||
require File::Spec;
|
||||
open my $olderr, '>&', \*STDERR
|
||||
or die "can't dup filehandle: $!";
|
||||
open STDERR, '>', File::Spec->devnull
|
||||
or die "can't open null: $!";
|
||||
my $out = threads->create(sub { 1 })->join;
|
||||
open STDERR, '>&', $olderr;
|
||||
POSIX::_exit((defined $out && $out eq '1') ? 0 : 1);
|
||||
}
|
||||
else {
|
||||
die "Invalid option $op!\n";
|
||||
}
|
||||
POSIX::_exit(0);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use B;
|
||||
BEGIN {
|
||||
local $utf8::{is_utf8};
|
||||
local $B::{perlstring};
|
||||
require Sub::Quote;
|
||||
}
|
||||
die "Unable to disable utf8::is_utf8 and B::perlstring for testing"
|
||||
unless !Sub::Quote::_HAVE_IS_UTF8 && ! Sub::Quote::_HAVE_PERLSTRING;
|
||||
do './t/quotify.t' or die $@ || $!;
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
$::SUB_QUOTE_NO_HEX_FLOAT = 1;
|
||||
do './t/quotify.t' or die $@ || $!;
|
||||
|
|
@ -0,0 +1,256 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use Test::More;
|
||||
use Data::Dumper;
|
||||
use B;
|
||||
BEGIN {
|
||||
$ENV{SUB_QUOTE_NO_HEX_FLOAT} = $::SUB_QUOTE_NO_HEX_FLOAT ? 1 : 0;
|
||||
}
|
||||
|
||||
use Sub::Quote qw(
|
||||
quotify
|
||||
);
|
||||
|
||||
use constant HAVE_UTF8 => Sub::Quote::_HAVE_IS_UTF8;
|
||||
use constant FLOAT_PRECISION => Sub::Quote::_FLOAT_PRECISION;
|
||||
use constant HAVE_HEX_FLOAT => Sub::Quote::_HAVE_HEX_FLOAT;
|
||||
use constant INF => 9**9**9**9;
|
||||
use constant NAN => INF * 0;
|
||||
use constant MAXUINT => ~0;
|
||||
use constant MAXINT => ~0 >> 1;
|
||||
use constant MININT => -(~0 >> 1) - 1;
|
||||
use constant INF_NAN_SUPPORT => (
|
||||
INF == 10 * INF
|
||||
and !(NAN == 0 || NAN == 0.1 || NAN + 0 == 0)
|
||||
);
|
||||
|
||||
sub _dump {
|
||||
my $value = shift;
|
||||
if (!defined $value) {
|
||||
return 'undef';
|
||||
}
|
||||
elsif (is_strict_numeric($value)) {
|
||||
return "$value";
|
||||
}
|
||||
local $Data::Dumper::Terse = 1;
|
||||
local $Data::Dumper::Useqq = 1;
|
||||
my $d = Data::Dumper::Dumper("$value");
|
||||
$d =~ s/\s+$//;
|
||||
$d;
|
||||
}
|
||||
|
||||
sub is_numeric {
|
||||
my $flags = B::svref_2object(\($_[0]))->FLAGS;
|
||||
!!( $flags & ( B::SVp_IOK | B::SVp_NOK ) )
|
||||
}
|
||||
|
||||
sub is_float {
|
||||
my $num = shift;
|
||||
$num != int($num)
|
||||
|| $num > ~0
|
||||
|| $num < -(~0>>1)-1;
|
||||
}
|
||||
|
||||
sub is_strict_numeric {
|
||||
my $flags = B::svref_2object(\($_[0]))->FLAGS;
|
||||
|
||||
!!( $flags & ( B::SVp_IOK | B::SVp_NOK ) && !( $flags & B::SVp_POK ) )
|
||||
}
|
||||
|
||||
my %flags;
|
||||
{
|
||||
no strict 'refs';
|
||||
for my $flag (qw(
|
||||
SVs_TEMP
|
||||
SVs_OBJECT
|
||||
SVs_GMG
|
||||
SVs_SMG
|
||||
SVs_RMG
|
||||
SVf_IOK
|
||||
SVf_NOK
|
||||
SVf_POK
|
||||
SVf_OOK
|
||||
SVf_FAKE
|
||||
SVf_READONLY
|
||||
SVf_PROTECT
|
||||
SVf_BREAK
|
||||
SVp_IOK
|
||||
SVp_NOK
|
||||
SVp_POK
|
||||
)) {
|
||||
if (defined &{'B::'.$flag}) {
|
||||
$flags{$flag} = &{'B::'.$flag};
|
||||
}
|
||||
}
|
||||
}
|
||||
sub flags {
|
||||
my $flags = B::svref_2object(\($_[0]))->FLAGS;
|
||||
join ' ', sort grep $flags & $flags{$_}, keys %flags;
|
||||
}
|
||||
|
||||
# unique values taking flags into account
|
||||
sub _uniq {
|
||||
my %s;
|
||||
grep {
|
||||
my $copy = $_;
|
||||
my $key = defined $_ ? flags($_).'|'.(HAVE_UTF8 && utf8::is_utf8($_) ? 1 : 0)."|$copy" : '';
|
||||
!$s{$key}++;
|
||||
} @_;
|
||||
}
|
||||
|
||||
sub eval_utf8 {
|
||||
my $value = shift;
|
||||
my $output;
|
||||
eval "use utf8; \$output = $value; 1;" or die $@;
|
||||
$output;
|
||||
}
|
||||
|
||||
my @numbers = (
|
||||
-20 .. 20,
|
||||
-0.0,
|
||||
qw(00 01 .0 .1 0.0 0.00 00.00 0.10 0.101),
|
||||
'0 but true',
|
||||
'0e0',
|
||||
(map +("1e$_", "-1e$_"), -50, -5, 0, 1, 5, 50),
|
||||
(map 1 / $_, -10 .. -2, 2 .. 10),
|
||||
(map +(1 / 9) * $_, -9 .. -1, 1 .. 9),
|
||||
(map $_ x 100, 1 .. 9),
|
||||
3.14159265358979323846264338327950288419716939937510,
|
||||
2.71828182845904523536028747135266249775724709369995,
|
||||
sqrt(2),
|
||||
1.4142135623730951,
|
||||
1.4142135623730954,
|
||||
sqrt(3),
|
||||
1.7320508075688772935274463415058722,
|
||||
1.73205080756887729352744634150587224,
|
||||
sqrt(5),
|
||||
2.2360679774997896963,
|
||||
2.23606797749978969634,
|
||||
MAXUINT,
|
||||
MAXUINT-1,
|
||||
MAXINT,
|
||||
MAXINT+1,
|
||||
MININT,
|
||||
(INF_NAN_SUPPORT ? (
|
||||
INF, -(INF),
|
||||
NAN, -(NAN),
|
||||
) : ()),
|
||||
);
|
||||
|
||||
my @strings = (
|
||||
"",
|
||||
(map +chr($_), 0 .. 0xff),
|
||||
"\\a\"",
|
||||
"\xC3\x84",
|
||||
"\x{ABCD}",
|
||||
"\x{1F4A9}",
|
||||
);
|
||||
|
||||
if (HAVE_UTF8) {
|
||||
utf8::downgrade($_, 1)
|
||||
for @strings;
|
||||
}
|
||||
|
||||
my @utf8_strings;
|
||||
if (HAVE_UTF8) {
|
||||
@utf8_strings = @strings;
|
||||
utf8::upgrade($_)
|
||||
for @utf8_strings;
|
||||
}
|
||||
|
||||
my @booleans = (!1, !0);
|
||||
|
||||
my @quotify = (
|
||||
undef,
|
||||
@booleans,
|
||||
(map {
|
||||
my $indeterminate = $_;
|
||||
my $number = $indeterminate + 0;
|
||||
my $string = $indeterminate . "";
|
||||
($number, $indeterminate, $string);
|
||||
} @numbers),
|
||||
@strings,
|
||||
@utf8_strings,
|
||||
);
|
||||
|
||||
# HAVE_UTF8 will be artificially false under quotify-5.6.t. skip utf8 strings
|
||||
# in this case as they will produce warnings or errors in newer perls.
|
||||
@quotify = grep !utf8::is_utf8($_), @quotify
|
||||
if !HAVE_UTF8 and "$]" >= 5.025;
|
||||
|
||||
my $eval_utf8;
|
||||
|
||||
for my $value (_uniq @quotify) {
|
||||
my $value_name
|
||||
= _dump($value)
|
||||
. (HAVE_UTF8 && utf8::is_utf8($value) ? ' utf8' : '')
|
||||
. (is_strict_numeric($value) ? ' pure' : '')
|
||||
. (is_numeric($value) ? ' num' : '');
|
||||
|
||||
my $quoted = quotify(my $copy = $value);
|
||||
utf8::downgrade($quoted, 1)
|
||||
if HAVE_UTF8;
|
||||
|
||||
my $note = "quotified as $quoted";
|
||||
utf8::encode($note)
|
||||
if defined &utf8::encode;
|
||||
note $note;
|
||||
|
||||
is flags($copy), flags($value),
|
||||
"$value_name: quotify doesn't modify input";
|
||||
|
||||
my $evaled;
|
||||
eval "\$evaled = $quoted; 1" or die $@;
|
||||
|
||||
for my $check (
|
||||
[ $evaled ],
|
||||
( HAVE_UTF8 ? [ eval_utf8($quoted), ' under utf8' ] : ()),
|
||||
) {
|
||||
my ($check_value, $suffix) = @$check;
|
||||
$suffix ||= '';
|
||||
|
||||
if (is_strict_numeric($value)) {
|
||||
ok is_strict_numeric($check_value),
|
||||
"$value_name: numeric status maintained$suffix";
|
||||
}
|
||||
|
||||
if (is_numeric($value)) {
|
||||
if ($value == $value) {
|
||||
my $todo;
|
||||
if (!HAVE_HEX_FLOAT && $check_value != $value && is_float($value)) {
|
||||
my $diff = abs($check_value - $value);
|
||||
my $accuracy = abs($value)/$diff;
|
||||
my $precision = FLOAT_PRECISION + 1;
|
||||
$todo = "not always accurate beyond $precision digits"
|
||||
if $accuracy <= 10**$precision;
|
||||
}
|
||||
|
||||
local $TODO = $todo
|
||||
if $todo;
|
||||
cmp_ok $check_value, '==', $value,
|
||||
"$value_name: numeric value maintained$suffix"
|
||||
or do {
|
||||
diag "quotified as $quoted";
|
||||
diag "got float : ".uc unpack("h*", pack("F", $check_value));
|
||||
diag "expected float : ".uc unpack("h*", pack("F", $value));
|
||||
};
|
||||
}
|
||||
else {
|
||||
cmp_ok $check_value, '!=', $check_value,
|
||||
"$value_name: numeric value maintained$suffix";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $value) {
|
||||
cmp_ok $check_value, 'eq', $value,
|
||||
"$value_name: string value maintained$suffix";
|
||||
}
|
||||
else {
|
||||
is $check_value, undef,
|
||||
"$value_name: undef maintained$suffix";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
use lib 't/lib';
|
||||
use InlineModule
|
||||
'Sub::Name' => undef,
|
||||
'Sub::Util' => undef,
|
||||
;
|
||||
use List::Util;
|
||||
delete $Sub::Util::{set_subname};
|
||||
do './t/sub-defer.t';
|
||||
die $@
|
||||
if $@;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
BEGIN {
|
||||
if ("$]" <= 5.008005) {
|
||||
print "1..0 # SKIP threads too unstable until perl 5.8.5\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
use lib 't/lib';
|
||||
use ThreadsCheck;
|
||||
use strict;
|
||||
use warnings;
|
||||
use threads;
|
||||
BEGIN {
|
||||
# lie to Test2 to avoid thread handling, which will crash on early 5.8.
|
||||
delete $INC{'threads.pm'};
|
||||
}
|
||||
use Test::More;
|
||||
|
||||
use Sub::Defer;
|
||||
|
||||
my %made;
|
||||
|
||||
my $one_defer = defer_sub 'Foo::one' => sub {
|
||||
die "remade - wtf" if $made{'Foo::one'};
|
||||
$made{'Foo::one'} = sub { 'one' };
|
||||
};
|
||||
|
||||
ok(threads->create(sub {
|
||||
my $info = Sub::Defer::defer_info($one_defer);
|
||||
my $name = $info && $info->[0] || '[undef]';
|
||||
my $ok = $name eq 'Foo::one';
|
||||
if (!$ok) {
|
||||
print STDERR "# Bad sub name when undeferring: $name\n";
|
||||
}
|
||||
return $ok ? 1234 : 0;
|
||||
})->join == 1234, 'able to retrieve info in thread');
|
||||
|
||||
ok(threads->create(sub {
|
||||
undefer_sub($one_defer);
|
||||
my $ok = $made{'Foo::one'} && $made{'Foo::one'} == \&Foo::one;
|
||||
return $ok ? 1234 : 0;
|
||||
})->join == 1234, 'able to undefer in thread');
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,349 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
use Test::More;
|
||||
use Test::Fatal;
|
||||
use Sub::Defer qw(defer_sub undefer_sub undefer_all undefer_package defer_info);
|
||||
use Scalar::Util qw(refaddr weaken);
|
||||
|
||||
my %made;
|
||||
|
||||
my $one_defer = defer_sub 'Foo::one' => sub {
|
||||
die "remade - wtf" if $made{'Foo::one'};
|
||||
$made{'Foo::one'} = sub { 'one' }
|
||||
};
|
||||
|
||||
my $two_defer = defer_sub 'Foo::two' => sub {
|
||||
die "remade - wtf" if $made{'Foo::two'};
|
||||
$made{'Foo::two'} = sub { 'two' }
|
||||
};
|
||||
|
||||
is($one_defer, \&Foo::one, 'one defer installed');
|
||||
is($two_defer, \&Foo::two, 'two defer installed');
|
||||
|
||||
is($one_defer->(), 'one', 'one defer runs');
|
||||
|
||||
is($made{'Foo::one'}, \&Foo::one, 'one made');
|
||||
|
||||
is($made{'Foo::two'}, undef, 'two not made');
|
||||
|
||||
is($one_defer->(), 'one', 'one (deferred) still runs');
|
||||
|
||||
is(Foo->one, 'one', 'one (undeferred) runs');
|
||||
|
||||
like exception { defer_sub 'welp' => sub { sub { 1 } } },
|
||||
qr/^welp is not a fully qualified sub name!/,
|
||||
'correct error for defer_sub with unqualified name';
|
||||
|
||||
is(my $two_made = undefer_sub($two_defer), $made{'Foo::two'}, 'make two');
|
||||
|
||||
is exception { undefer_sub($two_defer) }, undef,
|
||||
"repeated undefer doesn't regenerate";
|
||||
|
||||
is($two_made, \&Foo::two, 'two installed');
|
||||
|
||||
is($two_defer->(), 'two', 'two (deferred) still runs');
|
||||
|
||||
is($two_made->(), 'two', 'two (undeferred) runs');
|
||||
|
||||
my $three = sub { 'three' };
|
||||
|
||||
is(undefer_sub($three), $three, 'undefer non-deferred is a no-op');
|
||||
|
||||
my $four_defer = defer_sub 'Foo::four' => sub {
|
||||
sub { 'four' }
|
||||
};
|
||||
is($four_defer, \&Foo::four, 'four defer installed');
|
||||
|
||||
my $unnamed_defer = defer_sub undef ,=> sub {
|
||||
die 'remade - wtf' if $made{'unnamed'};
|
||||
$made{'unnamed'} = sub { 'dwarg' };
|
||||
};
|
||||
my $unnamed_result = $unnamed_defer->();
|
||||
ok $made{'unnamed'}, 'unnamed deferred subs generate subs';
|
||||
is $unnamed_result, 'dwarg', 'unnamed deferred subs call generated sub properly';
|
||||
|
||||
# somebody somewhere wraps up around the deferred installer
|
||||
no warnings qw/redefine/;
|
||||
my $orig = Foo->can('four');
|
||||
*Foo::four = sub {
|
||||
$orig->() . ' with a twist';
|
||||
};
|
||||
|
||||
is(Foo->four, 'four with a twist', 'around works');
|
||||
is(Foo->four, 'four with a twist', 'around has not been destroyed by first invocation');
|
||||
|
||||
my $one_all_defer = defer_sub 'Foo::one_all' => sub {
|
||||
$made{'Foo::one_all'} = sub { 'one_all' }
|
||||
};
|
||||
|
||||
my $two_all_defer = defer_sub 'Foo::two_all' => sub {
|
||||
$made{'Foo::two_all'} = sub { 'two_all' }
|
||||
};
|
||||
|
||||
is( $made{'Foo::one_all'}, undef, 'one_all not made' );
|
||||
is( $made{'Foo::two_all'}, undef, 'two_all not made' );
|
||||
|
||||
undefer_all();
|
||||
|
||||
is( $made{'Foo::one_all'}, \&Foo::one_all, 'one_all made by undefer_all' );
|
||||
is( $made{'Foo::two_all'}, \&Foo::two_all, 'two_all made by undefer_all' );
|
||||
|
||||
defer_sub 'Bar::one' => sub {
|
||||
$made{'Bar::one'} = sub { 'one' }
|
||||
};
|
||||
defer_sub 'Bar::two' => sub {
|
||||
$made{'Bar::two'} = sub { 'two' }
|
||||
};
|
||||
defer_sub 'Bar::Baz::one' => sub {
|
||||
$made{'Bar::Baz::one'} = sub { 'one' }
|
||||
};
|
||||
|
||||
undefer_package('Bar');
|
||||
|
||||
is( $made{'Bar::one'}, \&Bar::one, 'one made by undefer_package' );
|
||||
is( $made{'Bar::two'}, \&Bar::two, 'two made by undefer_package' );
|
||||
|
||||
is( $made{'Bar::Baz::one'}, undef, 'sub-package not undefered by undefer_package' );
|
||||
|
||||
{
|
||||
my $foo = defer_sub undef, sub { sub { 'foo' } };
|
||||
my $foo_string = "$foo";
|
||||
undef $foo;
|
||||
|
||||
is defer_info($foo_string), undef,
|
||||
"deferred subs don't leak";
|
||||
|
||||
Sub::Defer->CLONE;
|
||||
ok !exists $Sub::Defer::DEFERRED{$foo_string},
|
||||
'CLONE cleans out expired entries';
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = defer_sub undef, sub { sub { 'foo' } };
|
||||
my $foo_string = "$foo";
|
||||
Sub::Defer->CLONE;
|
||||
undef $foo;
|
||||
|
||||
is defer_info($foo_string), undef,
|
||||
"CLONE doesn't strengthen refs";
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = defer_sub undef, sub { sub { 'foo' } };
|
||||
my $foo_string = "$foo";
|
||||
my $foo_info = defer_info($foo_string);
|
||||
undef $foo;
|
||||
|
||||
is exception { Sub::Defer->CLONE }, undef,
|
||||
'CLONE works when quoted info saved externally';
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = defer_sub undef, sub { sub { 'foo' } };
|
||||
my $foo_string = "$foo";
|
||||
my $foo_info = $Sub::Defer::DEFERRED{$foo_string};
|
||||
undef $foo;
|
||||
|
||||
is exception { Sub::Defer->CLONE }, undef,
|
||||
'CLONE works when quoted info kept alive externally';
|
||||
ok !exists $Sub::Defer::DEFERRED{$foo_string},
|
||||
'CLONE removes expired entries that were kept alive externally';
|
||||
}
|
||||
|
||||
{
|
||||
my $foo = defer_sub undef, sub { sub { 'foo' } };
|
||||
my $foo_string = "$foo";
|
||||
undef $foo;
|
||||
Sub::Defer::undefer_package 'Unused';
|
||||
is exception { undefer_sub $foo_string }, undef,
|
||||
"undeferring expired sub (or reused refaddr) after undefer_package lives";
|
||||
}
|
||||
|
||||
{
|
||||
my $foo;
|
||||
my $sub = defer_sub undef, sub { +sub :lvalue { $foo } }, { attributes => [ 'lvalue' ]};
|
||||
$sub->() = 'foo';
|
||||
is $foo, 'foo', 'attributes are applied to deferred subs';
|
||||
}
|
||||
|
||||
{
|
||||
my $error;
|
||||
eval {
|
||||
my $sub = defer_sub undef, sub { sub { "gorf" } }, { attributes => [ 'oh boy' ] };
|
||||
1;
|
||||
} or $error = $@;
|
||||
like $error, qr/invalid attribute/,
|
||||
'invalid attributes are rejected';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $deferred = defer_sub "Foo::flub", sub { sub { $guff } };
|
||||
my $undeferred = undefer_sub($deferred);
|
||||
my $undeferred_addr = refaddr($undeferred);
|
||||
my $deferred_str = "$deferred";
|
||||
weaken($deferred);
|
||||
|
||||
is $deferred, undef,
|
||||
'no strong external refs kept for deferred named subs';
|
||||
|
||||
is defer_info($deferred_str), undef,
|
||||
'defer_info on expired deferred named sub gives undef';
|
||||
|
||||
isnt refaddr(undefer_sub($deferred_str)), $undeferred_addr,
|
||||
'undefer_sub on expired deferred named sub does not give undeferred sub';
|
||||
|
||||
is refaddr(undefer_sub($undeferred)), $undeferred_addr,
|
||||
'undefer_sub on undeferred named sub after deferred expiry gives undeferred';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $deferred = defer_sub undef, sub { sub { $guff } };
|
||||
my $undeferred = undefer_sub($deferred);
|
||||
my $undeferred_addr = refaddr($undeferred);
|
||||
my $deferred_str = "$deferred";
|
||||
my $undeferred_str = "$undeferred";
|
||||
weaken($deferred);
|
||||
|
||||
is $deferred, undef,
|
||||
'no strong external refs kept for deferred unnamed subs';
|
||||
|
||||
is defer_info($deferred_str), undef,
|
||||
'defer_info on expired deferred unnamed sub gives undef';
|
||||
|
||||
isnt refaddr(undefer_sub($deferred_str)), $undeferred_addr,
|
||||
'undefer_sub on expired deferred unnamed sub does not give undeferred sub';
|
||||
|
||||
is refaddr(undefer_sub($undeferred)), $undeferred_addr,
|
||||
'undefer_sub on undeferred unnamed sub after deferred expiry gives undeferred';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $deferred = defer_sub "Foo::gwarf", sub { sub { $guff } };
|
||||
my $undeferred = undefer_sub($deferred);
|
||||
my $undeferred_addr = refaddr($undeferred);
|
||||
my $deferred_str = "$deferred";
|
||||
my $undeferred_str = "$undeferred";
|
||||
delete $Foo::{gwarf};
|
||||
|
||||
weaken($deferred);
|
||||
weaken($undeferred);
|
||||
|
||||
is $undeferred, undef,
|
||||
'no strong external refs kept for undeferred named subs';
|
||||
|
||||
is defer_info($undeferred_str), undef,
|
||||
'defer_info on expired undeferred named sub gives undef';
|
||||
|
||||
isnt refaddr(undefer_sub($undeferred_str)), $undeferred_addr,
|
||||
'undefer_sub on expired undeferred named sub does not give undeferred sub';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $deferred = defer_sub undef, sub { sub { $guff } };
|
||||
my $undeferred = undefer_sub($deferred);
|
||||
my $undeferred_addr = refaddr($undeferred);
|
||||
my $deferred_str = "$deferred";
|
||||
my $undeferred_str = "$undeferred";
|
||||
|
||||
weaken($deferred);
|
||||
weaken($undeferred);
|
||||
|
||||
is $undeferred, undef,
|
||||
'no strong external refs kept for undeferred unnamed subs';
|
||||
|
||||
is defer_info($undeferred_str), undef,
|
||||
'defer_info on expired undeferred unnamed sub gives undef';
|
||||
|
||||
isnt refaddr(undefer_sub($undeferred_str)), $undeferred_addr,
|
||||
'undefer_sub on expired undeferred unnamed sub does not give undeferred sub';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $deferred = defer_sub undef, sub { sub { $guff } };
|
||||
my $undeferred = undefer_sub($deferred);
|
||||
weaken($deferred);
|
||||
|
||||
ok defer_info($undeferred),
|
||||
'defer_info still returns info for undeferred unnamed subs after deferred sub expires';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $deferred = defer_sub undef, sub { sub { $guff } };
|
||||
my $undeferred = undefer_sub($deferred);
|
||||
weaken($deferred);
|
||||
|
||||
Sub::Defer->CLONE;
|
||||
|
||||
ok defer_info($undeferred),
|
||||
'defer_info still returns info for undeferred unnamed subs after deferred sub expires and CLONE';
|
||||
}
|
||||
|
||||
{
|
||||
my $guff;
|
||||
my $gen = sub { +sub :lvalue { $guff } };
|
||||
my $deferred = defer_sub 'Foo::blorp', $gen,
|
||||
{ attributes => [ 'lvalue' ] };
|
||||
|
||||
is_deeply defer_info($deferred),
|
||||
[ 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] } ],
|
||||
'defer_info gives name, generator, options before undefer';
|
||||
|
||||
my $undeferred = undefer_sub $deferred;
|
||||
|
||||
is_deeply defer_info($deferred),
|
||||
[ 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] }, $undeferred ],
|
||||
'defer_info on deferred gives name, generator, options after undefer';
|
||||
|
||||
is_deeply defer_info($undeferred),
|
||||
[ 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] }, $undeferred ],
|
||||
'defer_info on undeferred gives name, generator, options after undefer';
|
||||
}
|
||||
|
||||
is defer_info(undef), undef, 'defer_info on undef gives undef';
|
||||
|
||||
{
|
||||
my $x;
|
||||
my $sub = sub {
|
||||
$x++;
|
||||
(caller(0))[3];
|
||||
};
|
||||
Sub::Defer::_install_coderef('Blorp::foo', 'Farg::foo', $sub);
|
||||
is \&Blorp::foo, $sub,
|
||||
'_install_coderef properly installs subs';
|
||||
|
||||
SKIP: {
|
||||
skip 'no sub naming module available', 1
|
||||
unless Sub::Defer::_CAN_SUBNAME;
|
||||
|
||||
is Blorp::foo(), 'Farg::foo',
|
||||
'_install_coderef properly names subs';
|
||||
}
|
||||
my $sub2 = sub {
|
||||
$x++;
|
||||
(caller(0))[3];
|
||||
};
|
||||
Sub::Defer::_install_coderef('Blorp::foo', 'Farg::foo', $sub2);
|
||||
is \&Blorp::foo, $sub2,
|
||||
'_install_coderef properly replaces subs';
|
||||
}
|
||||
|
||||
{
|
||||
my $x;
|
||||
my $sub = sub { $x = 1; sub { $x } };
|
||||
my $deferred = defer_sub undef, $sub;
|
||||
my $info = $Sub::Defer::DEFERRED{$deferred};
|
||||
undef $deferred;
|
||||
# simulate reused memory address
|
||||
@{$Sub::Defer::DEFERRED{$sub}} = @$info;
|
||||
undefer_sub($sub);
|
||||
is $x, undef,
|
||||
'undefer_sub does not operate on non-deferred sub with reused memory address';
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
BEGIN {
|
||||
if ("$]" <= 5.008005) {
|
||||
print "1..0 # SKIP threads too unstable until perl 5.8.5\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
use lib 't/lib';
|
||||
use ThreadsCheck;
|
||||
use strict;
|
||||
use warnings;
|
||||
use threads;
|
||||
BEGIN {
|
||||
# lie to Test2 to avoid thread handling, which will crash on early 5.8.
|
||||
delete $INC{'threads.pm'};
|
||||
}
|
||||
use Test::More;
|
||||
|
||||
use Sub::Quote;
|
||||
|
||||
my $one = quote_sub q{
|
||||
BEGIN { $::EVALED{'one'} = 1 }
|
||||
42
|
||||
};
|
||||
my $one_code = quoted_from_sub($one)->[1];
|
||||
|
||||
my $two = quote_sub q{
|
||||
BEGIN { $::EVALED{'two'} = 1 }
|
||||
3 + $x++
|
||||
} => { '$x' => \do { my $x = 0 } };
|
||||
|
||||
is(threads->create(sub {
|
||||
my $quoted = quoted_from_sub($one);
|
||||
$quoted && $quoted->[1];
|
||||
})->join, $one_code, 'able to retrieve quoted sub in thread');
|
||||
|
||||
my $u_one = unquote_sub $one;
|
||||
|
||||
is(threads->create(sub { $one->() })->join, 42, 'One (quoted version)');
|
||||
|
||||
is(threads->create(sub { $u_one->() })->join, 42, 'One (unquoted version)');
|
||||
|
||||
my $r = threads->create(sub {
|
||||
my @r;
|
||||
push @r, $two->();
|
||||
push @r, unquote_sub($two)->();
|
||||
push @r, $two->();
|
||||
\@r;
|
||||
})->join;
|
||||
|
||||
is($r->[0], 3, 'Two in thread (quoted version)');
|
||||
is($r->[1], 4, 'Two in thread (unquoted version)');
|
||||
is($r->[2], 5, 'Two in thread (quoted version again)');
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,344 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use Test::More;
|
||||
use Test::Fatal;
|
||||
|
||||
use Sub::Quote qw(
|
||||
quote_sub
|
||||
quoted_from_sub
|
||||
unquote_sub
|
||||
qsub
|
||||
capture_unroll
|
||||
inlinify
|
||||
sanitize_identifier
|
||||
quotify
|
||||
);
|
||||
|
||||
use B;
|
||||
|
||||
our %EVALED;
|
||||
|
||||
my $one = quote_sub q{
|
||||
BEGIN { $::EVALED{'one'} = 1 }
|
||||
42
|
||||
};
|
||||
|
||||
my $two = quote_sub q{
|
||||
BEGIN { $::EVALED{'two'} = 1 }
|
||||
3 + $x++
|
||||
} => { '$x' => \do { my $x = 0 } };
|
||||
|
||||
ok(!keys %EVALED, 'Nothing evaled yet');
|
||||
|
||||
is unquote_sub(sub {}), undef,
|
||||
'unquote_sub returns undef for unknown subs';
|
||||
|
||||
my $u_one = unquote_sub $one;
|
||||
|
||||
is_deeply(
|
||||
[ sort keys %EVALED ], [ qw(one) ],
|
||||
'subs one evaled'
|
||||
);
|
||||
|
||||
is($one->(), 42, 'One (quoted version)');
|
||||
|
||||
is($u_one->(), 42, 'One (unquoted version)');
|
||||
|
||||
is($two->(), 3, 'Two (quoted version)');
|
||||
is(unquote_sub($two)->(), 4, 'Two (unquoted version)');
|
||||
is($two->(), 5, 'Two (quoted version again)');
|
||||
|
||||
my $three = quote_sub 'Foo::three' => q{
|
||||
$x = $_[1] if $_[1];
|
||||
die +(caller(0))[3] if @_ > 2;
|
||||
return $x;
|
||||
} => { '$x' => \do { my $x = 'spoon' } };
|
||||
|
||||
is(Foo->three, 'spoon', 'get ok (named method)');
|
||||
is(Foo->three('fork'), 'fork', 'set ok (named method)');
|
||||
is(Foo->three, 'fork', 're-get ok (named method)');
|
||||
like(
|
||||
exception { Foo->three(qw(full cutlery set)) }, qr/Foo::three/,
|
||||
'exception contains correct name'
|
||||
);
|
||||
|
||||
quote_sub 'Foo::four' => q{
|
||||
return 5;
|
||||
};
|
||||
|
||||
my $quoted = quoted_from_sub(\&Foo::four);
|
||||
like $quoted->[1], qr/return 5;/,
|
||||
'can get quoted from installed sub';
|
||||
Foo::four();
|
||||
my $quoted2 = quoted_from_sub(\&Foo::four);
|
||||
like $quoted2->[1], qr/return 5;/,
|
||||
"can still get quoted from installed sub after undefer";
|
||||
undef $quoted;
|
||||
|
||||
{
|
||||
package Bar;
|
||||
::quote_sub blorp => q{ 1; };
|
||||
}
|
||||
ok defined &Bar::blorp,
|
||||
'bare sub name installed in current package';
|
||||
|
||||
my $long = "a" x 251;
|
||||
is exception {
|
||||
(quote_sub "${long}a::${long}", q{ return 1; })->();
|
||||
}, undef,
|
||||
'long names work if package and sub are short enough';
|
||||
|
||||
like exception {
|
||||
quote_sub "${long}${long}::${long}", q{ return 1; };
|
||||
}, qr/^package name "$long$long" too long/,
|
||||
'over long package names error';
|
||||
|
||||
like exception {
|
||||
quote_sub "${long}::${long}${long}", q{ return 1; };
|
||||
}, qr/^sub name "$long$long" too long/,
|
||||
'over long sub names error';
|
||||
|
||||
like exception {
|
||||
quote_sub "got a space::gorp", q{ return 1; };
|
||||
}, qr/^package name "got a space" is not valid!/,
|
||||
'packages with spaces are invalid';
|
||||
|
||||
like exception {
|
||||
quote_sub "Gorp::got a space", q{ return 1; };
|
||||
}, qr/^sub name "got a space" is not valid!/,
|
||||
'sub names with spaces are invalid';
|
||||
|
||||
like exception {
|
||||
quote_sub "0welp::gorp", q{ return 1; };
|
||||
}, qr/^package name "0welp" is not valid!/,
|
||||
'package names starting with numbers are not valid';
|
||||
|
||||
like exception {
|
||||
quote_sub "Gorp::0welp", q{ return 1; };
|
||||
}, qr/^sub name "0welp" is not valid!/,
|
||||
'sub names starting with numbers are not valid';
|
||||
|
||||
my $broken_quoted = quote_sub q{
|
||||
return 5<;
|
||||
Guh
|
||||
};
|
||||
|
||||
my $err = exception { $broken_quoted->() };
|
||||
like(
|
||||
$err, qr/Eval went very, very wrong/,
|
||||
"quoted sub with syntax error dies when called"
|
||||
);
|
||||
|
||||
my ($location) = $err =~ /syntax error at .+? line (\d+)/;
|
||||
like(
|
||||
$err, qr/$location:\s*return 5<;/,
|
||||
"syntax errors include usable line numbers"
|
||||
);
|
||||
|
||||
sub in_main { 1 }
|
||||
is exception { quote_sub(q{ in_main(); })->(); }, undef,
|
||||
'package preserved from context';
|
||||
|
||||
{
|
||||
package Arf;
|
||||
sub in_arf { 1 }
|
||||
}
|
||||
|
||||
is exception { quote_sub(q{ in_arf(); }, {}, { package => 'Arf' })->(); }, undef,
|
||||
'package used from options';
|
||||
|
||||
|
||||
{
|
||||
my $foo = quote_sub '{}';
|
||||
my $foo_string = "$foo";
|
||||
my $foo2 = unquote_sub $foo;
|
||||
undef $foo;
|
||||
|
||||
my $foo_info = Sub::Quote::quoted_from_sub($foo_string);
|
||||
is $foo_info, undef,
|
||||
'quoted data not maintained for quoted sub deleted after being unquoted';
|
||||
|
||||
is quoted_from_sub($foo2)->[3], $foo2,
|
||||
'unquoted sub still included in quote info';
|
||||
}
|
||||
|
||||
my @stuff = (qsub q{ print "hello"; }, 1, 2);
|
||||
is scalar @stuff, 3, 'qsub only accepts a single parameter';
|
||||
|
||||
{
|
||||
my @warnings;
|
||||
local $ENV{SUB_QUOTE_DEBUG} = 1;
|
||||
local $SIG{__WARN__} = sub { push @warnings, @_ };
|
||||
|
||||
quote_sub(q{ "this is in the quoted sub" })->();
|
||||
like $warnings[0],
|
||||
qr/sub\s*{.*this is in the quoted sub/s,
|
||||
"SUB_QUOTE_DEBUG - package doesn't match anon other";
|
||||
is scalar @warnings, 1,
|
||||
'single debug warning';
|
||||
|
||||
$ENV{SUB_QUOTE_DEBUG} = 'Some::Package::';
|
||||
|
||||
@warnings = ();
|
||||
quote_sub(q{ "this is in the quoted sub" })->();
|
||||
is scalar @warnings, 0,
|
||||
"SUB_QUOTE_DEBUG - package doesn't match anon other";
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Package::etc', q{ "this is in the quoted sub" })->();
|
||||
like $warnings[0],
|
||||
qr/this is in the quoted sub/s,
|
||||
"SUB_QUOTE_DEBUG - package matches";
|
||||
|
||||
@warnings = ();
|
||||
quote_sub(q{ "this is in the quoted sub" }, {}, { package => 'Some::Package' })->();
|
||||
like $warnings[0],
|
||||
qr/this is in the quoted sub/s,
|
||||
"SUB_QUOTE_DEBUG - package matches anon";
|
||||
|
||||
$ENV{SUB_QUOTE_DEBUG} = 'etc';
|
||||
|
||||
@warnings = ();
|
||||
quote_sub(q{ "this is in the quoted sub" })->();
|
||||
is scalar @warnings, 0,
|
||||
"SUB_QUOTE_DEBUG - sub name doesn't match anon";
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Package::woop', q{ "this is in the quoted sub" })->();
|
||||
is scalar @warnings, 0,
|
||||
"SUB_QUOTE_DEBUG - sub name doesn't match other";
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Package::etc', q{ "this is in the quoted sub" })->();
|
||||
like $warnings[0],
|
||||
qr/this is in the quoted sub/s,
|
||||
'SUB_QUOTE_DEBUG - sub name matches';
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Other::Package::etc', q{ "this is in the quoted sub" })->();
|
||||
like $warnings[0],
|
||||
qr/this is in the quoted sub/s,
|
||||
'SUB_QUOTE_DEBUG - sub name matches';
|
||||
|
||||
$ENV{SUB_QUOTE_DEBUG} = 'Some::Package::foo';
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Package::foo', q{ "this is in the quoted sub" })->();
|
||||
like $warnings[0],
|
||||
qr/this is in the quoted sub/s,
|
||||
'SUB_QUOTE_DEBUG - fully qualified matches';
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Other::Package::foo', q{ "this is in the quoted sub" })->();
|
||||
is scalar @warnings,
|
||||
0,
|
||||
"SUB_QUOTE_DEBUG - fully qualified doesn't match other";
|
||||
|
||||
$ENV{SUB_QUOTE_DEBUG} = '/quoted/';
|
||||
|
||||
@warnings = ();
|
||||
quote_sub('Some::Package::quoted', q{ "this sub should not match" })->();
|
||||
is scalar @warnings,
|
||||
0,
|
||||
"SUB_QUOTE_DEBUG - regex doesn't match name";
|
||||
|
||||
quote_sub(q{ "this is in the quoted sub" })->();
|
||||
like $warnings[0],
|
||||
qr/this is in the quoted sub/s,
|
||||
"SUB_QUOTE_DEBUG - regex matches code";
|
||||
}
|
||||
|
||||
{
|
||||
my $sub = quote_sub q{
|
||||
BEGIN { $::EVALED{'no_defer'} = 1 }
|
||||
1;
|
||||
}, {}, {no_defer => 1};
|
||||
is $::EVALED{no_defer}, 1,
|
||||
'evaled immediately with no_defer option';
|
||||
}
|
||||
|
||||
{
|
||||
my $sub = quote_sub 'No::Defer::Test', q{
|
||||
BEGIN { $::EVALED{'no_defer'} = 1 }
|
||||
1;
|
||||
}, {}, {no_defer => 1};
|
||||
is $::EVALED{no_defer}, 1,
|
||||
'evaled immediately with no_defer option (named)';
|
||||
ok defined &No::Defer::Test,
|
||||
'sub installed with no_defer option';
|
||||
is No::Defer::Test(), 1,
|
||||
'sub callable with no_defer option';
|
||||
}
|
||||
|
||||
{
|
||||
my $caller;
|
||||
sub No::Install::Tester {
|
||||
$caller = (caller(1))[3];
|
||||
}
|
||||
my $sub = quote_sub 'No::Install::Test', q{
|
||||
No::Install::Tester();
|
||||
}, {}, {no_install => 1};
|
||||
ok !defined &No::Install::Test,
|
||||
'sub not installed with no_install option';
|
||||
$sub->();
|
||||
is $caller, 'No::Install::Test',
|
||||
'sub named properly with no_install option';
|
||||
}
|
||||
|
||||
{
|
||||
my $caller;
|
||||
sub No::Install::No::Defer::Tester {
|
||||
$caller = (caller(1))[3];
|
||||
}
|
||||
my $sub = quote_sub 'No::Install::No::Defer::Test', q{
|
||||
No::Install::No::Defer::Tester();
|
||||
}, {}, {no_install => 1, no_defer => 1};
|
||||
ok !defined &No::Install::No::Defer::Test,
|
||||
'sub not installed with no_install and no_defer options';
|
||||
$sub->();
|
||||
is $caller, 'No::Install::No::Defer::Test',
|
||||
'sub named properly with no_install and no_defer options';
|
||||
}
|
||||
|
||||
my $var = sanitize_identifier('erk-qro yuf (fid)');
|
||||
eval qq{ my \$$var = 5; \$var };
|
||||
is $@, '', 'sanitize_identifier gives valid identifier';
|
||||
|
||||
{
|
||||
my $var;
|
||||
my $sub = quote_sub q{ $$var }, { '$var' => \\$var }, { attributes => [ 'lvalue' ] };
|
||||
$sub->() = 5;
|
||||
is $var, 5,
|
||||
'attributes applied to quoted sub';
|
||||
}
|
||||
|
||||
{
|
||||
my $var;
|
||||
my $sub = quote_sub q{ $$var }, { '$var' => \\$var }, { attributes => [ 'lvalue' ], no_defer => 1 };
|
||||
$sub->() = 5;
|
||||
is $var, 5,
|
||||
'attributes applied to quoted sub with no_defer';
|
||||
}
|
||||
|
||||
{
|
||||
my $error;
|
||||
eval {
|
||||
my $sub = quote_sub q{ "gorf" }, {}, { attributes => [ 'oh boy' ] };
|
||||
1;
|
||||
} or $error = $@;
|
||||
like $error, qr/invalid attribute/,
|
||||
'invalid attributes are rejected';
|
||||
}
|
||||
|
||||
{
|
||||
my $sub = quote_sub q{ sub { join " line ", (caller(0))[1,2] }->() }, {}, { line => 42 };
|
||||
like $sub->(), qr/eval.* line 42\b/, "line provided";
|
||||
}
|
||||
|
||||
{
|
||||
my $sub = quote_sub q{ sub { join " line ", (caller(0))[1,2] }->() }, {}, { file => "welp.pl", line => 42 };
|
||||
is $sub->(), "welp.pl line 42", "file and line provided";
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use lib 't/lib';
|
||||
|
||||
use Test::More;
|
||||
use List::Util;
|
||||
BEGIN {
|
||||
delete $Sub::Util::{'set_subname'};
|
||||
delete $INC{'Sub/Util.pm'};
|
||||
}
|
||||
|
||||
use InlineModule
|
||||
'Sub::Name' => undef,
|
||||
'Sub::Util' => undef,
|
||||
;
|
||||
|
||||
use Sub::Defer;
|
||||
|
||||
ok !Sub::Defer::_CAN_SUBNAME;
|
||||
my $sub = sub { 'foo' };
|
||||
is Sub::Defer::_subname('foo', $sub), $sub;
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use lib 't/lib';
|
||||
|
||||
use Test::More;
|
||||
use List::Util;
|
||||
BEGIN {
|
||||
delete $Sub::Util::{'set_subname'};
|
||||
delete $INC{'Sub/Util.pm'};
|
||||
}
|
||||
|
||||
use InlineModule
|
||||
'Sub::Name' => <<'END_SN',
|
||||
package Sub::Name;
|
||||
sub subname {
|
||||
$::sub_named = $_[0];
|
||||
return $_[1];
|
||||
}
|
||||
1;
|
||||
END_SN
|
||||
'Sub::Util' => undef,
|
||||
;
|
||||
|
||||
use Sub::Name;
|
||||
use Sub::Defer;
|
||||
|
||||
ok Sub::Defer::_CAN_SUBNAME;
|
||||
my $sub = sub { 'foo' };
|
||||
is Sub::Defer::_subname('foo', $sub), $sub;
|
||||
is $::sub_named, 'foo';
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use lib 't/lib';
|
||||
|
||||
use Test::More;
|
||||
use List::Util;
|
||||
BEGIN {
|
||||
delete $Sub::Util::{'set_subname'};
|
||||
delete $INC{'Sub/Util.pm'};
|
||||
}
|
||||
|
||||
use InlineModule
|
||||
'Sub::Name' => <<'END_SN',
|
||||
package Sub::Name;
|
||||
sub subname {
|
||||
$::sub_named = $_[0];
|
||||
return $_[1];
|
||||
}
|
||||
1;
|
||||
END_SN
|
||||
'Sub::Util' => undef,
|
||||
;
|
||||
|
||||
use Sub::Defer;
|
||||
|
||||
ok Sub::Defer::_CAN_SUBNAME;
|
||||
my $sub = sub { 'foo' };
|
||||
is Sub::Defer::_subname('foo', $sub), $sub;
|
||||
is $::sub_named, 'foo';
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
use lib 't/lib';
|
||||
|
||||
use Test::More;
|
||||
use List::Util;
|
||||
BEGIN {
|
||||
delete $Sub::Util::{'set_subname'};
|
||||
delete $INC{'Sub/Util.pm'};
|
||||
}
|
||||
|
||||
use InlineModule
|
||||
'Sub::Name' => undef,
|
||||
'Sub::Util' => <<'END_SU',
|
||||
package Sub::Util;
|
||||
sub set_subname {
|
||||
$::sub_named = $_[0];
|
||||
return $_[1];
|
||||
}
|
||||
1;
|
||||
END_SU
|
||||
;
|
||||
|
||||
use Sub::Defer;
|
||||
|
||||
ok Sub::Defer::_CAN_SUBNAME;
|
||||
my $sub = sub { 'foo' };
|
||||
is Sub::Defer::_subname('foo', $sub), $sub;
|
||||
is $::sub_named, 'foo';
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
plan skip_all => 'these tests are for release candidate testing'
|
||||
unless $ENV{RELEASE_TESTING};
|
||||
}
|
||||
|
||||
use CPAN::Meta;
|
||||
use Test::Kwalitee 'kwalitee_ok';
|
||||
|
||||
my ($meta_file) = grep -e, qw(MYMETA.json MYMETA.yml META.json META.yml)
|
||||
or die "unable to find MYMETA or META file!";
|
||||
|
||||
my $meta = CPAN::Meta->load_file($meta_file)->as_struct;
|
||||
my @ignore = keys %{$meta->{x_cpants}{ignore}};
|
||||
|
||||
kwalitee_ok(map "-$_", @ignore);
|
||||
done_testing;
|
||||
Loading…
Reference in New Issue