Import Upstream version 0.16
This commit is contained in:
zhangyichun
commit
50b956e507
|
|
@ -0,0 +1,28 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib 'inc';
|
||||
use Module::Build::with::XSTests;
|
||||
|
||||
my $build = Module::Build::with::XSTests->new(
|
||||
module_name => 'XS::Parse::Sublike',
|
||||
requires => {
|
||||
'perl' => '5.016', # pad_add_name_pvn
|
||||
# Not actually needed but used by hax/lexer-additions.c.inc
|
||||
},
|
||||
test_requires => {
|
||||
'Sub::Util' => 0,
|
||||
'Test::Fatal' => 0,
|
||||
'Test::More' => '0.88', # done_testing
|
||||
},
|
||||
configure_requires => {
|
||||
'Module::Build' => '0.4004', # test_requires
|
||||
},
|
||||
license => 'perl',
|
||||
create_license => 1,
|
||||
create_readme => 1,
|
||||
|
||||
extra_compiler_flags => [qw( -I. -Ihax )],
|
||||
);
|
||||
|
||||
$build->create_build_script;
|
||||
|
|
@ -0,0 +1,109 @@
|
|||
Revision history for XS-Parse-Sublike
|
||||
|
||||
0.16 2021-12-16
|
||||
[CHANGES]
|
||||
* No longer support ABI version 3 even in back-compatibility mode
|
||||
|
||||
[BUGFIXES]
|
||||
* Remember to adjust the SET_CVNAME and INSTALL_SYMBOL actions bits
|
||||
in the non-dynamic-actions case
|
||||
* Avoid using C99-style `//` comments as some compilers dislike it
|
||||
(mistagged RT140487)
|
||||
|
||||
0.15 2021-12-15
|
||||
[CHANGES]
|
||||
* Added ctx->actions, the DYNAMIC_ACTIONS compat flag, and associated
|
||||
flags and machinery
|
||||
* Added ctx->moddata
|
||||
|
||||
0.14 2021-10-28
|
||||
[CHANGES]
|
||||
* Added XS_PARSE_SUBLIKE_FLAG_PREFIX; discourage the _any() function
|
||||
to achieve similar effect
|
||||
* Added XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL to permit bodyless sublike
|
||||
declarations
|
||||
* Better compiletime warnings when a sub declaration lacks a
|
||||
body-delimiting brace
|
||||
|
||||
[BUGFIXES]
|
||||
* Fix for Perl < 5.20 on Win32 (thanks ilmari) (RT139296)
|
||||
* Handle the new OP_ARGCHECK aux structure of perl 5.31.5 (thanks
|
||||
ilmari) (RT139295)
|
||||
* Accomodate newly-added core sv_setrv_*() functions
|
||||
|
||||
0.13 2021-08-30
|
||||
[CHANGES]
|
||||
* New ABI version 4
|
||||
+ Set up functions in PL_modglobal instead of perl-visible global
|
||||
symbol table
|
||||
+ Add a `permit_hintkey` convenient shortcut
|
||||
* Better code structure of XS::Parse::Sublike::Builder
|
||||
|
||||
0.12 2021-06-21
|
||||
[BUGFIXES]
|
||||
* Try to work around parse_block()'s unbalanced scopestack messups
|
||||
* Namespace the static variables in the .h file appropriately in case
|
||||
both this as XSParseKeyword are loaded
|
||||
|
||||
0.11 2021-01-18
|
||||
[BUGFIXES]
|
||||
* Don't SEGV on signature parse error (RT133865)
|
||||
* Account for change of signature validation error message in latest
|
||||
bleadperl (RT134012)
|
||||
|
||||
0.10 2020-06-20
|
||||
[BREAKING CHANGES]
|
||||
* New ABI version 3
|
||||
|
||||
[CHANGES]
|
||||
* Pass an additional 'hookdata' parameter around between caller and
|
||||
hook stage functions
|
||||
|
||||
0.09 2020-06-15
|
||||
[CHANGES]
|
||||
* Define API for an optional stage for filtering and applying
|
||||
attributes during parsing
|
||||
|
||||
0.08 2020-06-12
|
||||
[CHANGES]
|
||||
* Define API to either require or skip parsing the name of a sub, or
|
||||
skip parsing attributes or signatures
|
||||
|
||||
0.07 2020-04-02
|
||||
[BUGFIXES]
|
||||
* Ensure that empty-signature functions are still parsed correctly
|
||||
and include arg count check (RT132284)
|
||||
|
||||
0.06 2020-03-27
|
||||
[CHANGES]
|
||||
* Pass a standard shared context struct through the various hook
|
||||
stages
|
||||
* Add an early hook stage before the call to start_subparse()
|
||||
|
||||
0.05 2020-03-26
|
||||
[BUGFIXES]
|
||||
* Fix hax/parse_subsignature.c.inc to cope with whitespace between
|
||||
parameter declarations
|
||||
|
||||
0.04 2020-03-18
|
||||
[CHANGES]
|
||||
* Pass a required module version number to boot_xs_parse_sublike()
|
||||
* Added lots of unit tests
|
||||
|
||||
0.03 2020-03-18
|
||||
[CHANGES]
|
||||
* Added xs_parse_sublike_any() allowing custom keywords to combine
|
||||
with registered hooks
|
||||
|
||||
[BUGFIXES]
|
||||
* Avoid double-free of sigops in case of parse failure
|
||||
* Fix hax/parse_subsignature.c.inc for named parameters with default
|
||||
expressions
|
||||
|
||||
0.02 2020-03-17
|
||||
[CHANGES]
|
||||
* Added `register_xs_parse_sublike()` and the `permit` hook stage
|
||||
* Added toplevel PL_keyword_hook parser function
|
||||
|
||||
0.01 2020-03-15
|
||||
First version, released on an unsuspecting world.
|
||||
|
|
@ -0,0 +1,379 @@
|
|||
This software is copyright (c) 2021 by Paul Evans <leonerd@leonerd.org.uk>.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
Terms of the Perl programming language system itself
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
b) the "Artistic License"
|
||||
|
||||
--- The GNU General Public License, Version 1, February 1989 ---
|
||||
|
||||
This software is Copyright (c) 2021 by Paul Evans <leonerd@leonerd.org.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) 2021 by Paul Evans <leonerd@leonerd.org.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,52 @@
|
|||
Build.PL
|
||||
Changes
|
||||
hax/block_end.c.inc
|
||||
hax/block_start.c.inc
|
||||
hax/COP_SEQ_RANGE_HIGH_set.c.inc
|
||||
hax/lexer-additions.c.inc
|
||||
hax/make_argcheck_aux.c.inc
|
||||
hax/pad_block_start.c.inc
|
||||
hax/pad_leavemy.c.inc
|
||||
hax/parse_subsignature.c.inc
|
||||
hax/scalarseq.c.inc
|
||||
hax/sv_setrv.c.inc
|
||||
hax/wrap_keyword_plugin.c.inc
|
||||
inc/Module/Build/with/XSTests.pm
|
||||
lib/XS/Parse/Sublike.pm
|
||||
lib/XS/Parse/Sublike.xs
|
||||
lib/XS/Parse/Sublike/Builder.pm
|
||||
lib/XS/Parse/Sublike/Builder_data.pm.PL
|
||||
LICENSE
|
||||
MANIFEST This list of files
|
||||
META.json
|
||||
META.yml
|
||||
README
|
||||
t/00use.t
|
||||
t/01func.t
|
||||
t/02func-signatures.t
|
||||
t/03func-deparse.t
|
||||
t/10stages-permit.t
|
||||
t/11stages-pre_subparse.t
|
||||
t/12stages-post_blockstart.t
|
||||
t/13stages-pre_blockend.t
|
||||
t/14stages-post_newcv.t
|
||||
t/15stages-filter_attr.t
|
||||
t/20registrations.t
|
||||
t/30any.t
|
||||
t/31prefix.t
|
||||
t/40parts-name.t
|
||||
t/41parts-attrs.t
|
||||
t/42parts-signature.t
|
||||
t/50flags-no-body.t
|
||||
t/60actions.t
|
||||
t/99pod.t
|
||||
t/actions.xs
|
||||
t/any.xs
|
||||
t/flags.xs
|
||||
t/func.xs
|
||||
t/parts.xs
|
||||
t/prefix.xs
|
||||
t/registrations.xs
|
||||
t/stages.xs
|
||||
t/testcase.pm
|
||||
XSParseSublike.h
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
{
|
||||
"abstract" : "XS functions to assist in parsing C<sub>-like syntax",
|
||||
"author" : [
|
||||
"Paul Evans <leonerd@leonerd.org.uk>"
|
||||
],
|
||||
"dynamic_config" : 1,
|
||||
"generated_by" : "Module::Build version 0.4231",
|
||||
"license" : [
|
||||
"perl_5"
|
||||
],
|
||||
"meta-spec" : {
|
||||
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
|
||||
"version" : 2
|
||||
},
|
||||
"name" : "XS-Parse-Sublike",
|
||||
"prereqs" : {
|
||||
"build" : {
|
||||
"requires" : {
|
||||
"ExtUtils::CBuilder" : "0"
|
||||
}
|
||||
},
|
||||
"configure" : {
|
||||
"requires" : {
|
||||
"Module::Build" : "0.4004"
|
||||
}
|
||||
},
|
||||
"runtime" : {
|
||||
"requires" : {
|
||||
"perl" : "5.016"
|
||||
}
|
||||
},
|
||||
"test" : {
|
||||
"requires" : {
|
||||
"Sub::Util" : "0",
|
||||
"Test::Fatal" : "0",
|
||||
"Test::More" : "0.88"
|
||||
}
|
||||
}
|
||||
},
|
||||
"provides" : {
|
||||
"XS::Parse::Sublike" : {
|
||||
"file" : "lib/XS/Parse/Sublike.pm",
|
||||
"version" : "0.16"
|
||||
},
|
||||
"XS::Parse::Sublike::Builder" : {
|
||||
"file" : "lib/XS/Parse/Sublike/Builder.pm",
|
||||
"version" : "0.16"
|
||||
}
|
||||
},
|
||||
"release_status" : "stable",
|
||||
"resources" : {
|
||||
"license" : [
|
||||
"http://dev.perl.org/licenses/"
|
||||
]
|
||||
},
|
||||
"version" : "0.16",
|
||||
"x_serialization_backend" : "JSON::PP version 4.05"
|
||||
}
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
---
|
||||
abstract: 'XS functions to assist in parsing C<sub>-like syntax'
|
||||
author:
|
||||
- 'Paul Evans <leonerd@leonerd.org.uk>'
|
||||
build_requires:
|
||||
ExtUtils::CBuilder: '0'
|
||||
Sub::Util: '0'
|
||||
Test::Fatal: '0'
|
||||
Test::More: '0.88'
|
||||
configure_requires:
|
||||
Module::Build: '0.4004'
|
||||
dynamic_config: 1
|
||||
generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.150010'
|
||||
license: perl
|
||||
meta-spec:
|
||||
url: http://module-build.sourceforge.net/META-spec-v1.4.html
|
||||
version: '1.4'
|
||||
name: XS-Parse-Sublike
|
||||
provides:
|
||||
XS::Parse::Sublike:
|
||||
file: lib/XS/Parse/Sublike.pm
|
||||
version: '0.16'
|
||||
XS::Parse::Sublike::Builder:
|
||||
file: lib/XS/Parse/Sublike/Builder.pm
|
||||
version: '0.16'
|
||||
requires:
|
||||
perl: '5.016'
|
||||
resources:
|
||||
license: http://dev.perl.org/licenses/
|
||||
version: '0.16'
|
||||
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
|
||||
|
|
@ -0,0 +1,345 @@
|
|||
NAME
|
||||
|
||||
XS::Parse::Sublike - XS functions to assist in parsing sub-like syntax
|
||||
|
||||
DESCRIPTION
|
||||
|
||||
This module provides some XS functions to assist in writing parsers for
|
||||
sub-like syntax, primarily for authors of keyword plugins using the
|
||||
PL_keyword_plugin hook mechanism. It is unlikely to be of much use to
|
||||
anyone else; and highly unlikely to be any use when writing perl code
|
||||
using these. Unless you are writing a keyword plugin using XS, this
|
||||
module is not for you.
|
||||
|
||||
This module is also currently experimental, and the design is still
|
||||
evolving and subject to change. Later versions may break ABI
|
||||
compatibility, requiring changes or at least a rebuild of any module
|
||||
that depends on it.
|
||||
|
||||
XS FUNCTIONS
|
||||
|
||||
boot_xs_parse_sublike
|
||||
|
||||
void boot_xs_parse_sublike(double ver)
|
||||
|
||||
Call this function from your BOOT section in order to initialise the
|
||||
module and parsing hooks.
|
||||
|
||||
ver should either be 0 or a decimal number for the module version
|
||||
requirement; e.g.
|
||||
|
||||
boot_xs_parse_sublike(0.04);
|
||||
|
||||
xs_parse_sublike
|
||||
|
||||
int xs_parse_sublike(const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
|
||||
This function performs the actual parsing of a sub-like keyword. It
|
||||
expects the lexer to be at a position just after the introduction
|
||||
keyword has been consumed, and will proceed to parse an optional name,
|
||||
list of attributes, signature (if enabled by use feature 'signatures'),
|
||||
and code body. The return value and op_ptr can be used directly from
|
||||
the keyword plugin function. It is intended this function be invoked
|
||||
from it, and the result returned directly.
|
||||
|
||||
For a more automated handling of keywords, see
|
||||
"register_xs_parse_sublike".
|
||||
|
||||
hooks should be a structure that can provide optional function pointers
|
||||
used to customise the parsing process at various stages. hookdata is an
|
||||
opaque pointer which is passed through to each of the hook stage
|
||||
functions.
|
||||
|
||||
register_xs_parse_sublike
|
||||
|
||||
void register_xs_parse_sublike(const char *keyword,
|
||||
const struct XSParseSublikeHooks *hooks, void *hookdata)
|
||||
|
||||
This function installs a set of parsing hooks to be associated with the
|
||||
given keyword. Such a keyword will then be handled automatically by a
|
||||
keyword parser installed by XS::Parse::Sublike itself.
|
||||
|
||||
When the keyword is encountered, the hook's permit function is first
|
||||
tested to see if the keyword is permitted at this point. If the
|
||||
function returns true then the keyword is consumed and parsed as per
|
||||
"xs_parse_sublike".
|
||||
|
||||
hookdata is an opaque pointer which is passed through to each of the
|
||||
hook stage functions when they are invoked.
|
||||
|
||||
xs_parse_sublike_any
|
||||
|
||||
int xs_parse_sublike_any(const struct XSParseSublikeHooks *hooks, void *hookdata,
|
||||
OP **op_ptr)
|
||||
|
||||
This function expects to consume an introduction keyword at the lexer
|
||||
position which is either sub or the name of another sub-like keyword,
|
||||
which has been previously registered using "register_xs_parse_sublike".
|
||||
It then proceeds to parse the subsequent syntax similar to how it would
|
||||
have parsed if encountered by the module's own keyword parser plugin,
|
||||
except that the second set of hooks given here also take effect.
|
||||
|
||||
If a regular sub is encountered, then this is parsed using the hooks in
|
||||
a similar way to xs_parse_sublike().
|
||||
|
||||
If a different registered sub-like keyword is encountered, then parsing
|
||||
is performed using both sets of hooks - the ones given to this function
|
||||
as well as the ones registered with the keyword. This allows their
|
||||
effects to combined. The hooks given by the hooks argument are
|
||||
considered to be on the "outside" from those of the registered keyword
|
||||
"inside". The outside ones run first for all stages, except
|
||||
pre_blockend which runs them inside-out.
|
||||
|
||||
hookdata is an opaque pointer which is passed through to each of the
|
||||
hook stage functions when they are invoked.
|
||||
|
||||
Note that this function is now vaguely discouraged, in favour of using
|
||||
a prefixing keyword instead, by using the XS_PARSE_SUBLIKE_FLAG_PREFIX
|
||||
flag.
|
||||
|
||||
PARSE CONTEXT
|
||||
|
||||
The various hook stages all share state about the ongoing parse process
|
||||
using various fields of the XSParseSublikeContext structure.
|
||||
|
||||
struct XSParseSublikeContext {
|
||||
SV *name;
|
||||
OP *attrs;
|
||||
OP *body;
|
||||
CV *cv;
|
||||
U32 actions;
|
||||
HV *moddata;
|
||||
}
|
||||
|
||||
The actions field will contain a bitmask of action flags that control
|
||||
the various steps that XS::Parse::Sublike might take inbetween invoking
|
||||
hook stages. The initial value of this field is set after the
|
||||
name-parsing stage, depending on whether or not a name is found. Stage
|
||||
hook functions may modify the field to adjust the subsequent behaviour.
|
||||
|
||||
At the current ABI version, a module will have to set the
|
||||
XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS bit of the flags field in
|
||||
order to make use of the actions field. A future ABI version may remove
|
||||
this restriction.
|
||||
|
||||
XS_PARSE_SUBLIKE_ACTION_CVf_ANON
|
||||
|
||||
If set, the start_subparse() call will be set up for an anonymous
|
||||
function protosub; if not it will be set for a named function. This
|
||||
is set by default if a name was not found.
|
||||
|
||||
XS_PARSE_SUBLIKE_ACTION_SET_CVNAME
|
||||
|
||||
If set, the newly-constructed CV will have the given name set on it.
|
||||
This is set by default if a name was found.
|
||||
|
||||
On Perl versions 5.22 and above, this flag can be set even if
|
||||
XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL is not. In this case, the CV
|
||||
will not be reachable via the symbol table, even though it knows its
|
||||
own name and pretends that it is. On earlier versions of perl this
|
||||
flag will be ignored in that case.
|
||||
|
||||
XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL
|
||||
|
||||
If set, the newly-constructed CV will be installed into the symbol
|
||||
table at its given name. Note that it is not possible to enable this
|
||||
flag without also enabling XS_PARSE_SUBLIKE_ACTION_SET_CVNAME. This
|
||||
is set by default if a name was found.
|
||||
|
||||
XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE
|
||||
|
||||
If set, the syntax will yield the OP_REFGEN / OP_ANONCODE optree
|
||||
fragment typical of anonymous code expressions; if not it will be
|
||||
OP_NULL. This is set by default if a name was not found.
|
||||
|
||||
XS_PARSE_SUBLIKE_ACTION_RET_EXPR
|
||||
|
||||
If set, the syntax will parse like an expression; if not it will
|
||||
parse like a statement. This is set by default if a name was not
|
||||
found.
|
||||
|
||||
The moddata field will point towards an HV that modules can used to
|
||||
store extra data between stages. As a naming convention a module should
|
||||
prefix its keys with its own module name and a slash character,
|
||||
"Some::Module/field". The field will point to a newly-created HV for
|
||||
every parse invocation, and will be released when each parse is
|
||||
complete.
|
||||
|
||||
PARSE HOOKS
|
||||
|
||||
The XSParseSublikeHooks structure provides the following hook stages,
|
||||
which are invoked in the given order.
|
||||
|
||||
The structure has a flags field, which controls various optional parts
|
||||
of operation. The following flags are defined.
|
||||
|
||||
XS_PARSE_SUBLIKE_FLAG_FILTERATTRS
|
||||
|
||||
If set, the optional filter_attr stage will be invoked.
|
||||
|
||||
XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL
|
||||
|
||||
If not set, the require_parts field will imply the
|
||||
XS_PARSE_SUBLIKE_PART_BODY flag, making the body part required. By
|
||||
setting this flag this will no longer happen. If all hooks agree,
|
||||
then the body will become optional.
|
||||
|
||||
XS_PARSE_SUBLIKE_FLAG_PREFIX
|
||||
|
||||
If set, the keyword is considered to be a prefix that can be placed
|
||||
in front of sub or another sub-like keyword, to add its set of hooks
|
||||
in addition to those of the following keyword. These prefices may be
|
||||
further stacked.
|
||||
|
||||
In addition there are two U8 fields named require_parts and skip_parts
|
||||
which control the behaviour of various parts of the syntax which are
|
||||
usually optional. Any parts with bits set in require_parts become
|
||||
non-optional, and an error if they are missing. Any parts with bits set
|
||||
in skip_parts will skip the relevant part of the parsing process.
|
||||
|
||||
When multiple sets of hooks are combined by the xs_parse_sublike_any
|
||||
function, or as part of parsing prefixing keywords, these bitmasks are
|
||||
accumulated together with inclusive or. Any part required by any set of
|
||||
hooks will still be required; any step skipped by either will be
|
||||
skipped entirely.
|
||||
|
||||
If the same bit is set in both fields then the relevant parsing step
|
||||
will not be performed but it will still be an error for that section to
|
||||
be missing. This is likely not useful.
|
||||
|
||||
Note that for skipped parts, only the actual parsing steps are skipped.
|
||||
A hook function can still set the relevant fields in the context
|
||||
structure anyway to force a particular value for those parts.
|
||||
|
||||
XS_PARSE_SUBLIKE_PART_NAME
|
||||
|
||||
The name of the function.
|
||||
|
||||
XS_PARSE_SUBLIKE_PART_ATTRS
|
||||
|
||||
The attributes of the function.
|
||||
|
||||
This part can be skipped, but the bit is ignored when in
|
||||
require_parts. It is always permitted to not provide any additional
|
||||
attributes to a function definition.
|
||||
|
||||
XS_PARSE_SUBLIKE_PART_SIGNATURE
|
||||
|
||||
The parameter signature of the function.
|
||||
|
||||
This part can be skipped, but the bit is ignored when in
|
||||
require_parts. It is always permitted not to provide a signature for
|
||||
a function definition, because such syntax only applies when use
|
||||
feature 'signatures' is in effect, and only on supporting perl
|
||||
versions.
|
||||
|
||||
XS_PARSE_SUBLIKE_PART_BODY
|
||||
|
||||
The actual body of the function, expressed as a brace-delimited
|
||||
block.
|
||||
|
||||
This part cannot be skipped, but it can be made optional by omitting
|
||||
it from the require_parts field. Instead of the block, it is
|
||||
permitted to place a single semicolon (;) to act as a statement
|
||||
terminator; thus giving the same syntax as a subroutine forward
|
||||
declaration.
|
||||
|
||||
In this case, the body and cv fields of the context structure will
|
||||
remain NULL.
|
||||
|
||||
This flag is currently implied on the require_parts field if the hook
|
||||
does not supply the XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL flag; meaning
|
||||
that most use-cases will make it a required part.
|
||||
|
||||
The permit Stage
|
||||
|
||||
const char *permit_hintkey
|
||||
bool (*permit)(pTHX_ void *hookdata)
|
||||
|
||||
Called by the installed keyword parser hook which is used to handle
|
||||
keywords registered by "register_xs_parse_sublike".
|
||||
|
||||
As a shortcut for the common case, the permit_hintkey may point to a
|
||||
string to look up from the hints hash. If the given key name is not
|
||||
found in the hints hash then the keyword is not permitted. If the key
|
||||
is present then the permit function is invoked as normal.
|
||||
|
||||
If not rejected by a hint key that was not found in the hints hash, the
|
||||
function part of the stage is called next and should inspect whether
|
||||
the keyword is permitted at this time perhaps by inspecting other
|
||||
lexical clues, and return true only if the keyword is permitted.
|
||||
|
||||
Both the string and the function are optional. Either or both may be
|
||||
present. If neither is present then the keyword is always permitted -
|
||||
which is likely not what you wanted to do.
|
||||
|
||||
Parse Name
|
||||
|
||||
At this point, the optional name is parsed and filled into the name
|
||||
field of the context.
|
||||
|
||||
The pre_subparse Stage
|
||||
|
||||
void (*pre_subparse)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked just before start_subparse() is called.
|
||||
|
||||
Parse Attrs
|
||||
|
||||
At this point the optional sub attributes are parsed and filled into
|
||||
the attrs field of the context, then block_start() is called.
|
||||
|
||||
The optional filter_attr Stage
|
||||
|
||||
bool (*filter_attr)(pTHX_ struct XSParseSublikeContext *ctx,
|
||||
SV *attr, SV *val, void *hookdata);
|
||||
|
||||
If the flags field includes XS_PARSE_SUBLIKE_FLAG_FILTERATTRS then each
|
||||
individual attribute is passed through this optional filter function
|
||||
immediately as each is parsed. attr will be a string SV containing the
|
||||
name of the attribute, and val will either be NULL, or a string SV
|
||||
containing the contents of the parens after its name (without the
|
||||
parens themselves).
|
||||
|
||||
If the filter returns true, it indicates that it has in some way
|
||||
handled the attribute and it should not be added to the list given to
|
||||
newATTRSUB(). If the filter returns false it will be handled in the
|
||||
usual way; equivalent to the case where the filter function did not
|
||||
exist.
|
||||
|
||||
The post_blockstart Stage
|
||||
|
||||
void (*post_blockstart)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked after the block_start() function has been called. This hook
|
||||
stage may wish to perform any alterations of PL_compcv or related,
|
||||
inspect or alter the lexical pad, provide hints hash values, or any
|
||||
other tasks before the signature and code body are parsed.
|
||||
|
||||
Parse Body
|
||||
|
||||
At this point, the main body of the function is parsed and the optree
|
||||
is stored in the body field of the context. If the perl version
|
||||
supports sub signatures and they are enabled and found, the body will
|
||||
be prefixed with the signature ops as well.
|
||||
|
||||
The pre_blockend Stage
|
||||
|
||||
void (*pre_blockend)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked just before the block_end() function is invoked. The hook stage
|
||||
may wish to inspect or alter the optree stored in the body context
|
||||
field.
|
||||
|
||||
The post_newcv Stage
|
||||
|
||||
void (*post_newcv)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked just after newATTRSUB() has been invoked on the optree. The
|
||||
hook stage may wish to inspect or alter the CV stored in the cv context
|
||||
field.
|
||||
|
||||
AUTHOR
|
||||
|
||||
Paul Evans <leonerd@leonerd.org.uk>
|
||||
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
#ifndef __XS_PARSE_SUBLIKE_H__
|
||||
#define __XS_PARSE_SUBLIKE_H__
|
||||
|
||||
#define XSPARSESUBLIKE_ABI_VERSION 4
|
||||
|
||||
struct XSParseSublikeContext {
|
||||
SV *name; /* may be NULL for anon subs */
|
||||
/* STAGE pre_subparse */
|
||||
OP *attrs; /* may be NULL */
|
||||
/* STAGE post_blockstart */
|
||||
OP *body;
|
||||
/* STAGE pre_blockend */
|
||||
CV *cv;
|
||||
/* STAGE post_newcv */
|
||||
|
||||
U32 actions;
|
||||
|
||||
/* Unused by XS::Parse::Sublike itself but can be handy for modules to store
|
||||
* data in between stages */
|
||||
HV *moddata;
|
||||
};
|
||||
|
||||
enum {
|
||||
XS_PARSE_SUBLIKE_FLAG_FILTERATTRS = 1<<0,
|
||||
XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL = 1<<1,
|
||||
XS_PARSE_SUBLIKE_FLAG_PREFIX = 1<<2,
|
||||
|
||||
/* Back-compat flags we hope to remove in the next ABI version */
|
||||
XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS = 1<<15,
|
||||
};
|
||||
|
||||
enum {
|
||||
XS_PARSE_SUBLIKE_PART_NAME = 1<<0,
|
||||
XS_PARSE_SUBLIKE_PART_ATTRS = 1<<1,
|
||||
XS_PARSE_SUBLIKE_PART_SIGNATURE = 1<<2,
|
||||
XS_PARSE_SUBLIKE_PART_BODY = 1<<3,
|
||||
};
|
||||
|
||||
enum {
|
||||
XS_PARSE_SUBLIKE_ACTION_CVf_ANON = (1<<0), /* should start_subparse() take CVf_ANON ? */
|
||||
XS_PARSE_SUBLIKE_ACTION_SET_CVNAME = (1<<1), /* do we set a CvNAME? */
|
||||
XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL = (1<<2), /* do we install the new CV into the symbol table? */
|
||||
XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE = (1<<3), /* do we emit OP_REFGEN of OP_ANONCODE, or simply OP_NULL ? */
|
||||
XS_PARSE_SUBLIKE_ACTION_RET_EXPR = (1<<4), /* do we return KEYWORD_PLUGIN_EXPR, or KEYWORD_PLUGIN_STMT ? */
|
||||
};
|
||||
|
||||
struct XSParseSublikeHooks {
|
||||
U16 flags;
|
||||
U8 require_parts;
|
||||
U8 skip_parts;
|
||||
|
||||
/* These two hooks are ANDed together; both must pass, if present */
|
||||
const char *permit_hintkey;
|
||||
bool (*permit)(pTHX_ void *hookdata);
|
||||
|
||||
void (*pre_subparse) (pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
void (*post_blockstart)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
void (*pre_blockend) (pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
void (*post_newcv) (pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
|
||||
/* if flags & XS_PARSE_SUBLIKE_FLAG_FILTERATTRS */
|
||||
bool (*filter_attr) (pTHX_ struct XSParseSublikeContext *ctx, SV *attr, SV *val, void *hookdata);
|
||||
};
|
||||
|
||||
static int (*parse_xs_parse_sublike_func)(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr);
|
||||
#define xs_parse_sublike(hooks, hookdata, op_ptr) S_xs_parse_sublike(aTHX_ hooks, hookdata, op_ptr)
|
||||
static int S_xs_parse_sublike(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
{
|
||||
if(!parse_xs_parse_sublike_func)
|
||||
croak("Must call boot_xs_parse_sublike() first");
|
||||
|
||||
return (*parse_xs_parse_sublike_func)(aTHX_ hooks, hookdata, op_ptr);
|
||||
}
|
||||
|
||||
static void (*register_xs_parse_sublike_func)(pTHX_ const char *kw, const struct XSParseSublikeHooks *hooks, void *hookdata);
|
||||
#define register_xs_parse_sublike(kw, hooks, hookdata) S_register_xs_parse_sublike(aTHX_ kw, hooks, hookdata)
|
||||
static void S_register_xs_parse_sublike(pTHX_ const char *kw, const struct XSParseSublikeHooks *hooks, void *hookdata)
|
||||
{
|
||||
if(!register_xs_parse_sublike_func)
|
||||
croak("Must call boot_xs_parse_sublike() first");
|
||||
|
||||
return (*register_xs_parse_sublike_func)(aTHX_ kw, hooks, hookdata);
|
||||
}
|
||||
|
||||
static int (*parseany_xs_parse_sublike_func)(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr);
|
||||
#define xs_parse_sublike_any(hooks, hookdata, op_ptr) S_xs_parse_sublike_any(aTHX_ hooks, hookdata, op_ptr)
|
||||
static int S_xs_parse_sublike_any(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
{
|
||||
if(!parseany_xs_parse_sublike_func)
|
||||
croak("Must call boot_xs_parse_sublike() first");
|
||||
|
||||
return (*parseany_xs_parse_sublike_func)(aTHX_ hooks, hookdata, op_ptr);
|
||||
}
|
||||
|
||||
#define boot_xs_parse_sublike(ver) S_boot_xs_parse_sublike(aTHX_ ver)
|
||||
static void S_boot_xs_parse_sublike(pTHX_ double ver) {
|
||||
SV **svp;
|
||||
SV *versv = ver ? newSVnv(ver) : NULL;
|
||||
|
||||
load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("XS::Parse::Sublike"), versv, NULL);
|
||||
|
||||
svp = hv_fetchs(PL_modglobal, "XS::Parse::Sublike/ABIVERSION_MIN", 0);
|
||||
if(!svp)
|
||||
croak("XS::Parse::Sublike ABI minimum version missing");
|
||||
int abi_ver = SvIV(*svp);
|
||||
if(abi_ver > XSPARSESUBLIKE_ABI_VERSION)
|
||||
croak("XS::Parse::Sublike ABI version mismatch - library supports >= %d, compiled for %d",
|
||||
abi_ver, XSPARSESUBLIKE_ABI_VERSION);
|
||||
|
||||
svp = hv_fetchs(PL_modglobal, "XS::Parse::Sublike/ABIVERSION_MAX", 0);
|
||||
abi_ver = SvIV(*svp);
|
||||
if(abi_ver < XSPARSESUBLIKE_ABI_VERSION)
|
||||
croak("XS::Parse::Sublike ABI version mismatch - library supports <= %d, compiled for %d",
|
||||
abi_ver, XSPARSESUBLIKE_ABI_VERSION);
|
||||
|
||||
parse_xs_parse_sublike_func = INT2PTR(int (*)(pTHX_ const struct XSParseSublikeHooks *, void *, OP**),
|
||||
SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parse()@4", 0)));
|
||||
|
||||
register_xs_parse_sublike_func = INT2PTR(void (*)(pTHX_ const char *, const struct XSParseSublikeHooks *, void *),
|
||||
SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/register()@4", 0)));
|
||||
|
||||
parseany_xs_parse_sublike_func = INT2PTR(int (*)(pTHX_ const struct XSParseSublikeHooks *, void *, OP**),
|
||||
SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parseany()@4", 0)));
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef COP_SEQ_RANGE_HIGH_set
|
||||
|
||||
#define COP_SEQ_RANGE_HIGH_set(SV, VAL) \
|
||||
STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef block_end
|
||||
|
||||
#include "scalarseq.c.inc"
|
||||
#include "pad_leavemy.c.inc"
|
||||
|
||||
#define block_end(A, B) S_block_end(aTHX_ A, B)
|
||||
|
||||
static OP *S_block_end(pTHX_ I32 floor, OP *seq) {
|
||||
dVAR;
|
||||
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
|
||||
OP *retval = scalarseq(seq);
|
||||
OP *o;
|
||||
|
||||
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
|
||||
|
||||
LEAVE_SCOPE(floor);
|
||||
#if !HAVE_PERL_VERSION(5, 19, 3)
|
||||
CopHINTS_set(&PL_compiling, PL_hints);
|
||||
#endif
|
||||
if (needblockscope)
|
||||
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
|
||||
|
||||
o = pad_leavemy();
|
||||
if (o) {
|
||||
#if HAVE_PERL_VERSION(5, 17, 4)
|
||||
OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
|
||||
OP *const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
|
||||
for (;; kid = kid->op_sibling) {
|
||||
OP *newkid = newOP(OP_CLONECV, 0);
|
||||
newkid->op_targ = kid->op_targ;
|
||||
o = op_append_elem(OP_LINESEQ, o, newkid);
|
||||
if (kid == last) break;
|
||||
}
|
||||
retval = op_prepend_elem(OP_LINESEQ, o, retval);
|
||||
#endif
|
||||
}
|
||||
|
||||
CALL_BLOCK_HOOKS(bhk_post_end, &retval);
|
||||
|
||||
return retval;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef block_start
|
||||
|
||||
#include "pad_block_start.c.inc"
|
||||
|
||||
#define block_start(A) S_block_start(aTHX_ A)
|
||||
|
||||
static int S_block_start(pTHX_ int full) {
|
||||
dVAR;
|
||||
const int retval = PL_savestack_ix;
|
||||
|
||||
pad_block_start(full);
|
||||
SAVEHINTS();
|
||||
PL_hints &= ~HINT_BLOCK_SCOPE;
|
||||
SAVECOMPILEWARNINGS();
|
||||
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
|
||||
|
||||
CALL_BLOCK_HOOKS(bhk_start, full);
|
||||
|
||||
return retval;
|
||||
}
|
||||
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,298 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
/* Perls before 5.18 lack isIDCONT_uni, but baring minor differences of weird
|
||||
* Unicode characters, isALNUM_uni is close enough
|
||||
*/
|
||||
#ifndef isIDCONT_uni
|
||||
#define isIDCONT_uni(c) isALNUM_uni(c)
|
||||
#endif
|
||||
|
||||
#define sv_cat_c(sv, c) MY_sv_cat_c(aTHX_ sv, c)
|
||||
static void MY_sv_cat_c(pTHX_ SV *sv, U32 c)
|
||||
{
|
||||
char ds[UTF8_MAXBYTES + 1], *d;
|
||||
d = (char *)uvchr_to_utf8((U8 *)ds, c);
|
||||
if (d - ds > 1) {
|
||||
sv_utf8_upgrade(sv);
|
||||
}
|
||||
sv_catpvn(sv, ds, d - ds);
|
||||
}
|
||||
|
||||
#define lex_consume(s) MY_lex_consume(aTHX_ s)
|
||||
static int MY_lex_consume(pTHX_ char *s)
|
||||
{
|
||||
/* I want strprefix() */
|
||||
size_t i;
|
||||
for(i = 0; s[i]; i++) {
|
||||
if(s[i] != PL_parser->bufptr[i])
|
||||
return 0;
|
||||
}
|
||||
|
||||
lex_read_to(PL_parser->bufptr + i);
|
||||
return i;
|
||||
}
|
||||
|
||||
enum {
|
||||
LEX_IDENT_PACKAGENAME = (1<<0),
|
||||
};
|
||||
|
||||
#define lex_scan_ident( ) MY_lex_scan_ident(aTHX_ 0)
|
||||
#define lex_scan_packagename() MY_lex_scan_ident(aTHX_ LEX_IDENT_PACKAGENAME)
|
||||
static SV *MY_lex_scan_ident(pTHX_ int flags)
|
||||
{
|
||||
I32 c;
|
||||
bool at_start = TRUE;
|
||||
|
||||
char *ident = PL_parser->bufptr;
|
||||
|
||||
while((c = lex_peek_unichar(0))) {
|
||||
if(at_start ? isIDFIRST_uni(c) : isALNUM_uni(c))
|
||||
at_start = FALSE;
|
||||
/* TODO: This sucks in the case of a false Foo:Bar match */
|
||||
else if((flags & LEX_IDENT_PACKAGENAME) && (c == ':')) {
|
||||
lex_read_unichar(0);
|
||||
if(lex_read_unichar(0) != ':')
|
||||
croak("Expected colon to be followed by another in package name");
|
||||
}
|
||||
else
|
||||
break;
|
||||
|
||||
lex_read_unichar(0);
|
||||
}
|
||||
|
||||
STRLEN len = PL_parser->bufptr - ident;
|
||||
if(!len)
|
||||
return NULL;
|
||||
|
||||
SV *ret = newSVpvn(ident, len);
|
||||
if(lex_bufutf8())
|
||||
SvUTF8_on(ret);
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
#define lex_scan_attrval_into(name, val) MY_lex_scan_attrval_into(aTHX_ name, val)
|
||||
static bool MY_lex_scan_attrval_into(pTHX_ SV *name, SV *val)
|
||||
{
|
||||
/* TODO: really want lex_scan_ident_into() */
|
||||
SV *n = lex_scan_ident();
|
||||
if(!n)
|
||||
return FALSE;
|
||||
|
||||
sv_setsv(name, n);
|
||||
SvREFCNT_dec(n);
|
||||
|
||||
if(name != val)
|
||||
SvPOK_off(val);
|
||||
|
||||
/* Do not read space here as space is not allowed between NAME(ARGS) */
|
||||
|
||||
if(lex_peek_unichar(0) != '(')
|
||||
return TRUE;
|
||||
|
||||
lex_read_unichar(0);
|
||||
if(name == val)
|
||||
sv_cat_c(val, '(');
|
||||
else
|
||||
sv_setpvs(val, "");
|
||||
|
||||
int count = 1;
|
||||
I32 c = lex_peek_unichar(0);
|
||||
while(count && c != -1) {
|
||||
if(c == '(')
|
||||
count++;
|
||||
if(c == ')')
|
||||
count--;
|
||||
if(c == '\\') {
|
||||
/* The next char does not bump count even if it is ( or );
|
||||
* the \\ is still captured
|
||||
*/
|
||||
sv_cat_c(val, lex_read_unichar(0));
|
||||
c = lex_peek_unichar(0);
|
||||
if(c == -1)
|
||||
goto unterminated;
|
||||
}
|
||||
|
||||
/* Don't append final closing ')' on split name/val */
|
||||
if(count || (name == val))
|
||||
sv_cat_c(val, c);
|
||||
lex_read_unichar(0);
|
||||
|
||||
c = lex_peek_unichar(0);
|
||||
}
|
||||
|
||||
if(c == -1)
|
||||
return FALSE;
|
||||
|
||||
return TRUE;
|
||||
|
||||
unterminated:
|
||||
croak("Unterminated attribute parameter in attribute list");
|
||||
}
|
||||
|
||||
#define lex_scan_attr() MY_lex_scan_attr(aTHX)
|
||||
static SV *MY_lex_scan_attr(pTHX)
|
||||
{
|
||||
SV *ret = newSV(0);
|
||||
if(MY_lex_scan_attrval_into(aTHX_ ret, ret))
|
||||
return ret;
|
||||
|
||||
SvREFCNT_dec(ret);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
#define lex_scan_attrs(compcv) MY_lex_scan_attrs(aTHX_ compcv)
|
||||
static OP *MY_lex_scan_attrs(pTHX_ CV *compcv)
|
||||
{
|
||||
/* Attributes are supplied to newATTRSUB() as an OP_LIST containing
|
||||
* OP_CONSTs, one attribute in each as a plain SV. Note that we don't have
|
||||
* to parse inside the contents of the parens; that is handled by the
|
||||
* attribute handlers themselves
|
||||
*/
|
||||
OP *attrs = NULL;
|
||||
SV *attr;
|
||||
|
||||
lex_read_space(0);
|
||||
while((attr = lex_scan_attr())) {
|
||||
lex_read_space(0);
|
||||
|
||||
if(compcv && strEQ(SvPV_nolen(attr), "lvalue")) {
|
||||
CvLVALUE_on(compcv);
|
||||
}
|
||||
|
||||
if(!attrs)
|
||||
attrs = newLISTOP(OP_LIST, 0, NULL, NULL);
|
||||
|
||||
attrs = op_append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, attr));
|
||||
|
||||
/* Accept additional colons to prefix additional attrs */
|
||||
if(lex_peek_unichar(0) == ':') {
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
}
|
||||
}
|
||||
|
||||
return attrs;
|
||||
}
|
||||
|
||||
#define lex_scan_lexvar() MY_lex_scan_lexvar(aTHX)
|
||||
static SV *MY_lex_scan_lexvar(pTHX)
|
||||
{
|
||||
int sigil = lex_peek_unichar(0);
|
||||
switch(sigil) {
|
||||
case '$':
|
||||
case '@':
|
||||
case '%':
|
||||
lex_read_unichar(0);
|
||||
break;
|
||||
|
||||
default:
|
||||
croak("Expected a lexical variable");
|
||||
}
|
||||
|
||||
SV *ret = lex_scan_ident();
|
||||
if(!ret)
|
||||
return NULL;
|
||||
|
||||
/* prepend sigil - which we know to be a single byte */
|
||||
SvGROW(ret, SvCUR(ret) + 1);
|
||||
Move(SvPVX(ret), SvPVX(ret) + 1, SvCUR(ret), char);
|
||||
SvPVX(ret)[0] = sigil;
|
||||
SvCUR(ret)++;
|
||||
|
||||
SvPVX(ret)[SvCUR(ret)] = 0;
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
#define lex_scan_parenthesized() MY_lex_scan_parenthesized(aTHX)
|
||||
static SV *MY_lex_scan_parenthesized(pTHX)
|
||||
{
|
||||
I32 c;
|
||||
int parencount = 0;
|
||||
SV *ret = newSVpvs("");
|
||||
if(lex_bufutf8())
|
||||
SvUTF8_on(ret);
|
||||
|
||||
c = lex_peek_unichar(0);
|
||||
|
||||
while(c != -1) {
|
||||
sv_cat_c(ret, lex_read_unichar(0));
|
||||
|
||||
switch(c) {
|
||||
case '(': parencount++; break;
|
||||
case ')': parencount--; break;
|
||||
}
|
||||
if(!parencount)
|
||||
break;
|
||||
|
||||
c = lex_peek_unichar(0);
|
||||
}
|
||||
|
||||
if(SvCUR(ret))
|
||||
return ret;
|
||||
|
||||
SvREFCNT_dec(ret);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
#define lex_scan_version(flags) MY_lex_scan_version(aTHX_ flags)
|
||||
static SV *MY_lex_scan_version(pTHX_ int flags)
|
||||
{
|
||||
I32 c;
|
||||
SV *tmpsv = sv_2mortal(newSVpvs(""));
|
||||
|
||||
/* scan_version() expects a version to end in linefeed, semicolon or
|
||||
* openbrace; gets confused if other keywords are fine. We'll have to
|
||||
* extract it first.
|
||||
* https://rt.cpan.org/Ticket/Display.html?id=132903
|
||||
*/
|
||||
|
||||
while((c = lex_peek_unichar(0))) {
|
||||
/* Allow a single leading v before accepting only digits, dot, underscore */
|
||||
if((!SvCUR(tmpsv) && (c == 'v')) || strchr("0123456789._", c))
|
||||
sv_cat_c(tmpsv, lex_read_unichar(0));
|
||||
else
|
||||
break;
|
||||
}
|
||||
|
||||
if(!SvCUR(tmpsv) && (flags & PARSE_OPTIONAL))
|
||||
return NULL;
|
||||
|
||||
SV *ret = newSV(0);
|
||||
scan_version(SvPVX(tmpsv), ret, FALSE);
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
#define parse_lexvar() MY_parse_lexvar(aTHX)
|
||||
static PADOFFSET MY_parse_lexvar(pTHX)
|
||||
{
|
||||
/* TODO: Rewrite this in terms of using lex_scan_lexvar()
|
||||
*/
|
||||
char *lexname = PL_parser->bufptr;
|
||||
|
||||
if(lex_read_unichar(0) != '$')
|
||||
croak("Expected a lexical scalar at %s", lexname);
|
||||
|
||||
if(!isIDFIRST_uni(lex_peek_unichar(0)))
|
||||
croak("Expected a lexical scalar at %s", lexname);
|
||||
lex_read_unichar(0);
|
||||
while(isIDCONT_uni(lex_peek_unichar(0)))
|
||||
lex_read_unichar(0);
|
||||
|
||||
/* Forbid $_ */
|
||||
if(PL_parser->bufptr - lexname == 2 && lexname[1] == '_')
|
||||
croak("Can't use global $_ in \"my\"");
|
||||
|
||||
return pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL);
|
||||
}
|
||||
|
||||
#define parse_scoped_block(flags) MY_parse_scoped_block(aTHX_ flags)
|
||||
static OP *MY_parse_scoped_block(pTHX_ int flags)
|
||||
{
|
||||
OP *ret;
|
||||
I32 save_ix = block_start(TRUE);
|
||||
ret = parse_block(flags);
|
||||
return block_end(save_ix, ret);
|
||||
}
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef make_argcheck_aux
|
||||
|
||||
#define make_argcheck_aux(params, opt_params, slurpy) S_make_argcheck_aux(aTHX_ params, opt_params, slurpy)
|
||||
static inline UNOP_AUX_item *S_make_argcheck_aux(pTHX_ UV params, UV opt_params, char slurpy)
|
||||
{
|
||||
# if HAVE_PERL_VERSION(5, 31, 5)
|
||||
struct op_argcheck_aux *aux = (struct op_argcheck_aux*)
|
||||
PerlMemShared_malloc(sizeof(struct op_argcheck_aux));
|
||||
aux->params = params;
|
||||
aux->opt_params = opt_params;
|
||||
aux->slurpy = slurpy;
|
||||
return (UNOP_AUX_item *)aux;
|
||||
# else
|
||||
UNOP_AUX_item *aux = (UNOP_AUX_item *)PerlMemShared_malloc(sizeof(UNOP_AUX_item) * 3);
|
||||
aux[0].iv = params;
|
||||
aux[1].iv = opt_params;
|
||||
aux[2].iv = slurpy;
|
||||
return aux;
|
||||
# endif
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef pad_block_start
|
||||
|
||||
#define pad_block_start(A) S_pad_block_start(aTHX_ A)
|
||||
|
||||
static void S_pad_block_start(pTHX_ int full) {
|
||||
dVAR;
|
||||
ASSERT_CURPAD_ACTIVE("pad_block_start");
|
||||
SAVEI32(PL_comppad_name_floor);
|
||||
PL_comppad_name_floor = AvFILLp(PL_comppad_name);
|
||||
if (full)
|
||||
PL_comppad_name_fill = PL_comppad_name_floor;
|
||||
if (PL_comppad_name_floor < 0)
|
||||
PL_comppad_name_floor = 0;
|
||||
SAVEI32(PL_min_intro_pending);
|
||||
SAVEI32(PL_max_intro_pending);
|
||||
PL_min_intro_pending = 0;
|
||||
SAVEI32(PL_comppad_name_fill);
|
||||
SAVEI32(PL_padix_floor);
|
||||
PL_padix_floor = PL_padix;
|
||||
PL_pad_reset_pending = FALSE;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef pad_leavemy
|
||||
|
||||
#include "COP_SEQ_RANGE_HIGH_set.c.inc"
|
||||
|
||||
#define pad_leavemy() S_pad_leavemy(aTHX)
|
||||
|
||||
#if HAVE_PERL_VERSION(5, 19, 3)
|
||||
#define IF_HAVE_PERL_5_19_3(YES, NO) YES
|
||||
#else
|
||||
#define IF_HAVE_PERL_5_19_3(YES, NO) NO
|
||||
#endif
|
||||
|
||||
static OP *S_pad_leavemy(pTHX) {
|
||||
dVAR;
|
||||
I32 off;
|
||||
OP *o = NULL;
|
||||
SV * const * const svp = AvARRAY(PL_comppad_name);
|
||||
|
||||
PL_pad_reset_pending = FALSE;
|
||||
|
||||
ASSERT_CURPAD_ACTIVE("pad_leavemy");
|
||||
if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
|
||||
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
|
||||
const SV * const sv = svp[off];
|
||||
if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv))
|
||||
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
|
||||
"%"SVf" never introduced",
|
||||
SVfARG(sv));
|
||||
}
|
||||
}
|
||||
/* "Deintroduce" my variables that are leaving with this scope. */
|
||||
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
|
||||
SV * const sv = svp[off];
|
||||
if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv)
|
||||
&& COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
|
||||
{
|
||||
COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
|
||||
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
|
||||
"Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
|
||||
(long)off, SvPVX_const(sv),
|
||||
(unsigned long)COP_SEQ_RANGE_LOW(sv),
|
||||
(unsigned long)COP_SEQ_RANGE_HIGH(sv))
|
||||
);
|
||||
#if HAVE_PERL_VERSION(5, 17, 4)
|
||||
if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
|
||||
&& *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
|
||||
OP *kid = newOP(OP_INTROCV, 0);
|
||||
kid->op_targ = off;
|
||||
o = op_prepend_elem(OP_LINESEQ, kid, o);
|
||||
}
|
||||
#endif
|
||||
}
|
||||
}
|
||||
PL_cop_seqmax++;
|
||||
if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
|
||||
PL_cop_seqmax++;
|
||||
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
|
||||
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
|
||||
return o;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,220 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef parse_subsignature
|
||||
|
||||
#define PERL_EXT
|
||||
#include "feature.h"
|
||||
|
||||
#include "make_argcheck_aux.c.inc"
|
||||
|
||||
/*
|
||||
* Need to grab some things that aren't quite core perl API
|
||||
*/
|
||||
|
||||
/* yyerror() is a long function and hard to emulate or copy-paste for our
|
||||
* purposes; we'll reïmplement a smaller version of it
|
||||
*/
|
||||
|
||||
#define LEX_IGNORE_UTF8_HINTS 0x00000002
|
||||
|
||||
#define PL_linestr (PL_parser->linestr)
|
||||
|
||||
#ifdef USE_UTF8_SCRIPTS
|
||||
# define UTF cBOOL(!IN_BYTES)
|
||||
#else
|
||||
# define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
|
||||
#endif
|
||||
|
||||
#define yyerror(s) S_yyerror(aTHX_ s)
|
||||
void S_yyerror(pTHX_ const char *s)
|
||||
{
|
||||
SV *message = sv_2mortal(newSVpvs_flags("", 0));
|
||||
|
||||
char *context = PL_parser->oldbufptr;
|
||||
STRLEN contlen = PL_parser->bufptr - PL_parser->oldbufptr;
|
||||
|
||||
sv_catpvf(message, "%s at %s line %" IVdf,
|
||||
s, OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
|
||||
|
||||
if(context)
|
||||
sv_catpvf(message, ", near \"%" UTF8f "\"",
|
||||
UTF8fARG(UTF, contlen, context));
|
||||
|
||||
sv_catpvf(message, "\n");
|
||||
|
||||
PL_parser->error_count++;
|
||||
warn_sv(message);
|
||||
}
|
||||
|
||||
/* Stolen from op.c */
|
||||
#define OpTYPE_set(op, type) \
|
||||
STMT_START { \
|
||||
op->op_type = (OPCODE)type; \
|
||||
op->op_ppaddr = PL_ppaddr[type]; \
|
||||
} STMT_END
|
||||
|
||||
#define alloc_LOGOP(a,b,c) S_alloc_LOGOP(aTHX_ a,b,c)
|
||||
static LOGOP *S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
|
||||
{
|
||||
dVAR;
|
||||
LOGOP *logop;
|
||||
OP *kid = first;
|
||||
NewOp(1101, logop, 1, LOGOP);
|
||||
OpTYPE_set(logop, type);
|
||||
logop->op_first = first;
|
||||
logop->op_other = other;
|
||||
if (first)
|
||||
logop->op_flags = OPf_KIDS;
|
||||
while (kid && OpHAS_SIBLING(kid))
|
||||
kid = OpSIBLING(kid);
|
||||
if (kid)
|
||||
OpLASTSIB_set(kid, (OP*)logop);
|
||||
return logop;
|
||||
}
|
||||
|
||||
#define parse_sigelem() S_parse_sigelem(aTHX)
|
||||
static OP *S_parse_sigelem(pTHX)
|
||||
{
|
||||
yy_parser *parser = PL_parser;
|
||||
|
||||
int c = lex_peek_unichar(0);
|
||||
int flags;
|
||||
|
||||
switch(c) {
|
||||
case '$': flags = OPpARGELEM_SV; break;
|
||||
case '@': flags = OPpARGELEM_AV; break;
|
||||
case '%': flags = OPpARGELEM_HV; break;
|
||||
default:
|
||||
croak("Expected a signature element at <%s>\n", parser->bufptr);
|
||||
}
|
||||
|
||||
char *lexname = parser->bufptr;
|
||||
OP *varop = NULL;
|
||||
|
||||
/* Consume sigil */
|
||||
lex_read_unichar(0);
|
||||
|
||||
if(isIDFIRST_uni(lex_peek_unichar(0))) {
|
||||
lex_read_unichar(0);
|
||||
while(isALNUM_uni(lex_peek_unichar(0)))
|
||||
lex_read_unichar(0);
|
||||
|
||||
varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (parser->sig_elems)));
|
||||
varop->op_private |= flags;
|
||||
|
||||
varop->op_targ = pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL);
|
||||
|
||||
lex_read_space(0);
|
||||
}
|
||||
|
||||
if(c == '$') {
|
||||
if(parser->sig_slurpy)
|
||||
yyerror("Slurpy parameters not last");
|
||||
|
||||
parser->sig_elems++;
|
||||
|
||||
if(lex_peek_unichar(0) == '=') {
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
|
||||
parser->sig_optelems++;
|
||||
|
||||
OP *defexpr = parse_termexpr(0);
|
||||
|
||||
OP *defop = (OP *)alloc_LOGOP(OP_ARGDEFELEM, defexpr, LINKLIST(defexpr));
|
||||
defop->op_targ = (PADOFFSET)(parser->sig_elems - 1);
|
||||
|
||||
varop->op_flags |= OPf_STACKED;
|
||||
op_sibling_splice(varop, NULL, 0, defop);
|
||||
defop = op_contextualize(defop, G_SCALAR);
|
||||
|
||||
LINKLIST(varop);
|
||||
|
||||
varop->op_next = defop;
|
||||
defexpr->op_next = varop;
|
||||
}
|
||||
else {
|
||||
if(parser->sig_optelems)
|
||||
yyerror("Mandatory parameter follows optional parameter");
|
||||
}
|
||||
}
|
||||
else {
|
||||
if(parser->sig_slurpy)
|
||||
yyerror("Multiple slurpy parameters not allowed");
|
||||
|
||||
parser->sig_slurpy = c;
|
||||
|
||||
if(lex_peek_unichar(0) == '=')
|
||||
yyerror("A slurpy parameter may not have a default value");
|
||||
}
|
||||
|
||||
return varop ? newSTATEOP(0, NULL, varop) : NULL;
|
||||
}
|
||||
|
||||
#define parse_subsignature(flags) S_parse_subsignature(aTHX_ flags)
|
||||
static OP *S_parse_subsignature(pTHX_ int flags)
|
||||
{
|
||||
/* Mostly reconstructed logic from perl 5.28.0's toke.c and perly.y
|
||||
*/
|
||||
yy_parser *parser = PL_parser;
|
||||
|
||||
ENTER;
|
||||
SAVEIV(parser->sig_elems);
|
||||
SAVEIV(parser->sig_optelems);
|
||||
SAVEI8(parser->sig_slurpy);
|
||||
|
||||
parser->sig_elems = 0;
|
||||
parser->sig_optelems = 0;
|
||||
parser->sig_slurpy = 0;
|
||||
|
||||
OP *elems = NULL;
|
||||
while(lex_peek_unichar(0) != ')') {
|
||||
lex_read_space(0);
|
||||
OP *elem = parse_sigelem();
|
||||
elems = op_append_list(OP_LINESEQ, elems, elem);
|
||||
|
||||
if(PL_parser->error_count) {
|
||||
LEAVE;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
lex_read_space(0);
|
||||
switch(lex_peek_unichar(0)) {
|
||||
case ')': goto endofelems;
|
||||
case ',': break;
|
||||
default:
|
||||
fprintf(stderr, "ARGH unsure how to proceed parse_subsignature at <%s>\n",
|
||||
parser->bufptr);
|
||||
croak("ARGH");
|
||||
break;
|
||||
}
|
||||
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
}
|
||||
endofelems:
|
||||
|
||||
if (!FEATURE_SIGNATURES_IS_ENABLED)
|
||||
croak("Experimental subroutine signatures not enabled");
|
||||
|
||||
Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SIGNATURES),
|
||||
"The signatures feature is experimental");
|
||||
|
||||
UNOP_AUX_item *aux = make_argcheck_aux(
|
||||
parser->sig_elems, parser->sig_optelems, parser->sig_slurpy);
|
||||
|
||||
OP *checkop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux);
|
||||
|
||||
checkop = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL),
|
||||
op_prepend_elem(OP_LINESEQ, checkop, elems));
|
||||
|
||||
/* a nextstate at the end handles context correctly for an empty
|
||||
* sub body */
|
||||
checkop = op_append_elem(OP_LINESEQ, checkop, newSTATEOP(0, NULL, NULL));
|
||||
|
||||
LEAVE;
|
||||
|
||||
return checkop;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef scalarseq
|
||||
|
||||
#define scalarseq(A) S_scalarseq(aTHX_ A)
|
||||
|
||||
static OP *S_scalarseq(pTHX_ OP *o) {
|
||||
dVAR;
|
||||
if (o) {
|
||||
const OPCODE type = o->op_type;
|
||||
|
||||
if (type == OP_LINESEQ || type == OP_SCOPE ||
|
||||
type == OP_LEAVE || type == OP_LEAVETRY)
|
||||
{
|
||||
OP *kid;
|
||||
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
|
||||
if (kid->op_sibling) {
|
||||
op_contextualize(kid, G_VOID);
|
||||
}
|
||||
}
|
||||
PL_curcop = &PL_compiling;
|
||||
}
|
||||
o->op_flags &= ~OPf_PARENS;
|
||||
if (PL_hints & HINT_BLOCK_SCOPE)
|
||||
o->op_flags |= OPf_PARENS;
|
||||
}
|
||||
else
|
||||
o = newOP(OP_STUB, 0);
|
||||
return o;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef sv_setrv_noinc
|
||||
# define sv_setrv_noinc(sv, rv) S_sv_setrv(aTHX_ sv, rv)
|
||||
# define sv_setrv_inc(sv, rv) S_sv_setrv(aTHX_ sv, SvREFCNT_inc(rv))
|
||||
#endif
|
||||
|
||||
static void S_sv_setrv(pTHX_ SV *sv, SV *rv)
|
||||
{
|
||||
SV *tmp = newRV_noinc(rv);
|
||||
sv_setsv(sv, tmp);
|
||||
SvREFCNT_dec(tmp);
|
||||
}
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
/* vi: set ft=c : */
|
||||
|
||||
#ifndef OP_CHECK_MUTEX_LOCK /* < 5.15.8 */
|
||||
# define OP_CHECK_MUTEX_LOCK ((void)0)
|
||||
# define OP_CHECK_MUTEX_UNLOCK ((void)0)
|
||||
#endif
|
||||
|
||||
#define wrap_keyword_plugin(func, var) S_wrap_keyword_plugin(aTHX_ func, var)
|
||||
|
||||
static void S_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t func, Perl_keyword_plugin_t *var)
|
||||
{
|
||||
/* BOOT can potentially race with other threads (RT123547) */
|
||||
|
||||
/* Perl doesn't really provide us a nice mutex for doing this so this is the
|
||||
* best we can find. See also
|
||||
* https://rt.perl.org/Public/Bug/Display.html?id=132413
|
||||
*/
|
||||
if(*var)
|
||||
return;
|
||||
|
||||
OP_CHECK_MUTEX_LOCK;
|
||||
if(!*var) {
|
||||
*var = PL_keyword_plugin;
|
||||
PL_keyword_plugin = func;
|
||||
}
|
||||
|
||||
OP_CHECK_MUTEX_UNLOCK;
|
||||
}
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
package Module::Build::with::XSTests;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base qw( Module::Build );
|
||||
|
||||
# Stolen and edited from Module::Build::Base::_infer_xs_spec
|
||||
sub _infer_xs_spec
|
||||
{
|
||||
my $self = shift;
|
||||
my ( $file ) = @_;
|
||||
|
||||
my $spec = $self->SUPER::_infer_xs_spec( $file );
|
||||
|
||||
if( $file =~ m{^t/} ) {
|
||||
$spec->{$_} = File::Spec->catdir( "t", $spec->{$_} )
|
||||
for qw( archdir bs_file lib_file );
|
||||
}
|
||||
|
||||
return $spec;
|
||||
}
|
||||
|
||||
# Various bits stolen from Module::Build::Base::
|
||||
# process_xs_files()
|
||||
sub ACTION_testlib
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $testxsfiles = $self->_find_file_by_type('xs', 't');
|
||||
|
||||
foreach my $from ( sort keys %$testxsfiles ) {
|
||||
my $to = $testxsfiles->{$from};
|
||||
|
||||
if( $to ne $from ) {
|
||||
$self->add_to_cleanup( $to );
|
||||
$self->copy_if_modified( from => $from, to => $to );
|
||||
}
|
||||
|
||||
$self->process_xs( $to );
|
||||
}
|
||||
}
|
||||
|
||||
sub ACTION_test
|
||||
{
|
||||
my $self = shift;
|
||||
$self->depends_on( "testlib" );
|
||||
|
||||
$self->SUPER::ACTION_test( @_ );
|
||||
}
|
||||
|
||||
0x55AA;
|
||||
|
|
@ -0,0 +1,360 @@
|
|||
# You may distribute under the terms of either the GNU General Public License
|
||||
# or the Artistic License (the same terms as Perl itself)
|
||||
#
|
||||
# (C) Paul Evans, 2020-2021 -- leonerd@leonerd.org.uk
|
||||
|
||||
package XS::Parse::Sublike 0.16;
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
require XSLoader;
|
||||
XSLoader::load( __PACKAGE__, our $VERSION );
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
C<XS::Parse::Sublike> - XS functions to assist in parsing C<sub>-like syntax
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some XS functions to assist in writing parsers for
|
||||
C<sub>-like syntax, primarily for authors of keyword plugins using the
|
||||
C<PL_keyword_plugin> hook mechanism. It is unlikely to be of much use to
|
||||
anyone else; and highly unlikely to be any use when writing perl code using
|
||||
these. Unless you are writing a keyword plugin using XS, this module is not
|
||||
for you.
|
||||
|
||||
This module is also currently experimental, and the design is still evolving
|
||||
and subject to change. Later versions may break ABI compatibility, requiring
|
||||
changes or at least a rebuild of any module that depends on it.
|
||||
|
||||
=head1 XS FUNCTIONS
|
||||
|
||||
=head2 boot_xs_parse_sublike
|
||||
|
||||
void boot_xs_parse_sublike(double ver)
|
||||
|
||||
Call this function from your C<BOOT> section in order to initialise the module
|
||||
and parsing hooks.
|
||||
|
||||
I<ver> should either be 0 or a decimal number for the module version
|
||||
requirement; e.g.
|
||||
|
||||
boot_xs_parse_sublike(0.04);
|
||||
|
||||
=head2 xs_parse_sublike
|
||||
|
||||
int xs_parse_sublike(const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
|
||||
This function performs the actual parsing of a C<sub>-like keyword. It expects
|
||||
the lexer to be at a position just after the introduction keyword has been
|
||||
consumed, and will proceed to parse an optional name, list of attributes,
|
||||
signature (if enabled by C<use feature 'signatures'>), and code body. The
|
||||
return value and C<op_ptr> can be used directly from the keyword plugin
|
||||
function. It is intended this function be invoked from it, and the result
|
||||
returned directly.
|
||||
|
||||
For a more automated handling of keywords, see L</register_xs_parse_sublike>.
|
||||
|
||||
I<hooks> should be a structure that can provide optional function pointers
|
||||
used to customise the parsing process at various stages. I<hookdata> is an
|
||||
opaque pointer which is passed through to each of the hook stage functions.
|
||||
|
||||
=head2 register_xs_parse_sublike
|
||||
|
||||
void register_xs_parse_sublike(const char *keyword,
|
||||
const struct XSParseSublikeHooks *hooks, void *hookdata)
|
||||
|
||||
This function installs a set of parsing hooks to be associated with the given
|
||||
keyword. Such a keyword will then be handled automatically by a keyword parser
|
||||
installed by C<XS::Parse::Sublike> itself.
|
||||
|
||||
When the keyword is encountered, the hook's C<permit> function is first tested
|
||||
to see if the keyword is permitted at this point. If the function returns true
|
||||
then the keyword is consumed and parsed as per L</xs_parse_sublike>.
|
||||
|
||||
I<hookdata> is an opaque pointer which is passed through to each of the hook
|
||||
stage functions when they are invoked.
|
||||
|
||||
=head2 xs_parse_sublike_any
|
||||
|
||||
int xs_parse_sublike_any(const struct XSParseSublikeHooks *hooks, void *hookdata,
|
||||
OP **op_ptr)
|
||||
|
||||
This function expects to consume an introduction keyword at the lexer position
|
||||
which is either C<sub> or the name of another C<sub>-like keyword, which has
|
||||
been previously registered using L</register_xs_parse_sublike>. It then
|
||||
proceeds to parse the subsequent syntax similar to how it would have parsed if
|
||||
encountered by the module's own keyword parser plugin, except that the second
|
||||
set of hooks given here also take effect.
|
||||
|
||||
If a regular C<sub> is encountered, then this is parsed using the I<hooks> in
|
||||
a similar way to C<xs_parse_sublike()>.
|
||||
|
||||
If a different registered C<sub>-like keyword is encountered, then parsing is
|
||||
performed using B<both> sets of hooks - the ones given to this function as
|
||||
well as the ones registered with the keyword. This allows their effects to
|
||||
combined. The hooks given by the I<hooks> argument are considered to be on the
|
||||
"outside" from those of the registered keyword "inside". The outside ones run
|
||||
first for all stages, except C<pre_blockend> which runs them inside-out.
|
||||
|
||||
I<hookdata> is an opaque pointer which is passed through to each of the hook
|
||||
stage functions when they are invoked.
|
||||
|
||||
Note that this function is now vaguely discouraged, in favour of using a
|
||||
prefixing keyword instead, by using the C<XS_PARSE_SUBLIKE_FLAG_PREFIX> flag.
|
||||
|
||||
=head1 PARSE CONTEXT
|
||||
|
||||
The various hook stages all share state about the ongoing parse process using
|
||||
various fields of the C<XSParseSublikeContext> structure.
|
||||
|
||||
struct XSParseSublikeContext {
|
||||
SV *name;
|
||||
OP *attrs;
|
||||
OP *body;
|
||||
CV *cv;
|
||||
U32 actions;
|
||||
HV *moddata;
|
||||
}
|
||||
|
||||
The C<actions> field will contain a bitmask of action flags that control the
|
||||
various steps that C<XS::Parse::Sublike> might take inbetween invoking hook
|
||||
stages. The initial value of this field is set after the name-parsing stage,
|
||||
depending on whether or not a name is found. Stage hook functions may modify
|
||||
the field to adjust the subsequent behaviour.
|
||||
|
||||
At the current ABI version, a module will have to set the
|
||||
C<XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS> bit of the C<flags> field in
|
||||
order to make use of the I<actions> field. A future ABI version may remove
|
||||
this restriction.
|
||||
|
||||
=over 4
|
||||
|
||||
=item XS_PARSE_SUBLIKE_ACTION_CVf_ANON
|
||||
|
||||
If set, the C<start_subparse()> call will be set up for an anonymous function
|
||||
protosub; if not it will be set for a named function. This is set by default
|
||||
if a name was not found.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_ACTION_SET_CVNAME
|
||||
|
||||
If set, the newly-constructed CV will have the given name set on it. This is
|
||||
set by default if a name was found.
|
||||
|
||||
On Perl versions 5.22 and above, this flag can be set even if
|
||||
C<XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL> is not. In this case, the CV will
|
||||
not be reachable via the symbol table, even though it knows its own name and
|
||||
pretends that it is. On earlier versions of perl this flag will be ignored in
|
||||
that case.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL
|
||||
|
||||
If set, the newly-constructed CV will be installed into the symbol table at
|
||||
its given name. Note that it is not possible to enable this flag without also
|
||||
enabling C<XS_PARSE_SUBLIKE_ACTION_SET_CVNAME>. This is set by default if a
|
||||
name was found.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE
|
||||
|
||||
If set, the syntax will yield the C<OP_REFGEN> / C<OP_ANONCODE> optree
|
||||
fragment typical of anonymous code expressions; if not it will be C<OP_NULL>.
|
||||
This is set by default if a name was not found.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_ACTION_RET_EXPR
|
||||
|
||||
If set, the syntax will parse like an expression; if not it will parse like a
|
||||
statement. This is set by default if a name was not found.
|
||||
|
||||
=back
|
||||
|
||||
The I<moddata> field will point towards an HV that modules can used to store
|
||||
extra data between stages. As a naming convention a module should prefix its
|
||||
keys with its own module name and a slash character, C<"Some::Module/field">.
|
||||
The field will point to a newly-created HV for every parse invocation, and
|
||||
will be released when each parse is complete.
|
||||
|
||||
=head1 PARSE HOOKS
|
||||
|
||||
The C<XSParseSublikeHooks> structure provides the following hook stages, which
|
||||
are invoked in the given order.
|
||||
|
||||
The structure has a I<flags> field, which controls various optional parts of
|
||||
operation. The following flags are defined.
|
||||
|
||||
=over 4
|
||||
|
||||
=item XS_PARSE_SUBLIKE_FLAG_FILTERATTRS
|
||||
|
||||
If set, the optional C<filter_attr> stage will be invoked.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL
|
||||
|
||||
If B<not> set, the I<require_parts> field will imply the
|
||||
C<XS_PARSE_SUBLIKE_PART_BODY> flag, making the body part required. By setting
|
||||
this flag this will no longer happen. If all hooks agree, then the body will
|
||||
become optional.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_FLAG_PREFIX
|
||||
|
||||
If set, the keyword is considered to be a prefix that can be placed in front
|
||||
of C<sub> or another sub-like keyword, to add its set of hooks in addition to
|
||||
those of the following keyword. These prefices may be further stacked.
|
||||
|
||||
=back
|
||||
|
||||
In addition there are two C<U8> fields named I<require_parts> and
|
||||
I<skip_parts> which control the behaviour of various parts of the syntax which
|
||||
are usually optional. Any parts with bits set in I<require_parts> become
|
||||
non-optional, and an error if they are missing. Any parts with bits set in
|
||||
I<skip_parts> will skip the relevant part of the parsing process.
|
||||
|
||||
When multiple sets of hooks are combined by the C<xs_parse_sublike_any>
|
||||
function, or as part of parsing prefixing keywords, these bitmasks are
|
||||
accumulated together with inclusive or. Any part required by any set of hooks
|
||||
will still be required; any step skipped by either will be skipped entirely.
|
||||
|
||||
If the same bit is set in both fields then the relevant parsing step will not
|
||||
be performed but it will still be an error for that section to be missing.
|
||||
This is likely not useful.
|
||||
|
||||
Note that for skipped parts, only the actual parsing steps are skipped. A hook
|
||||
function can still set the relevant fields in the context structure anyway to
|
||||
force a particular value for those parts.
|
||||
|
||||
=over 4
|
||||
|
||||
=item XS_PARSE_SUBLIKE_PART_NAME
|
||||
|
||||
The name of the function.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_PART_ATTRS
|
||||
|
||||
The attributes of the function.
|
||||
|
||||
This part can be skipped, but the bit is ignored when in I<require_parts>. It
|
||||
is always permitted to not provide any additional attributes to a function
|
||||
definition.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_PART_SIGNATURE
|
||||
|
||||
The parameter signature of the function.
|
||||
|
||||
This part can be skipped, but the bit is ignored when in I<require_parts>. It
|
||||
is always permitted not to provide a signature for a function definition,
|
||||
because such syntax only applies when C<use feature 'signatures'> is in
|
||||
effect, and only on supporting perl versions.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_PART_BODY
|
||||
|
||||
The actual body of the function, expressed as a brace-delimited block.
|
||||
|
||||
This part cannot be skipped, but it can be made optional by omitting it from
|
||||
the I<require_parts> field. Instead of the block, it is permitted to place a
|
||||
single semicolon (C<;>) to act as a statement terminator; thus giving the same
|
||||
syntax as a subroutine forward declaration.
|
||||
|
||||
In this case, the C<body> and C<cv> fields of the context structure will
|
||||
remain C<NULL>.
|
||||
|
||||
This flag is currently implied on the I<require_parts> field if the hook does
|
||||
not supply the C<XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL> flag; meaning that most
|
||||
use-cases will make it a required part.
|
||||
|
||||
=back
|
||||
|
||||
=head2 The C<permit> Stage
|
||||
|
||||
const char *permit_hintkey
|
||||
bool (*permit)(pTHX_ void *hookdata)
|
||||
|
||||
Called by the installed keyword parser hook which is used to handle keywords
|
||||
registered by L</register_xs_parse_sublike>.
|
||||
|
||||
As a shortcut for the common case, the C<permit_hintkey> may point to a string
|
||||
to look up from the hints hash. If the given key name is not found in the
|
||||
hints hash then the keyword is not permitted. If the key is present then the
|
||||
C<permit> function is invoked as normal.
|
||||
|
||||
If not rejected by a hint key that was not found in the hints hash, the
|
||||
function part of the stage is called next and should inspect whether the
|
||||
keyword is permitted at this time perhaps by inspecting other lexical clues,
|
||||
and return true only if the keyword is permitted.
|
||||
|
||||
Both the string and the function are optional. Either or both may be present.
|
||||
If neither is present then the keyword is always permitted - which is likely
|
||||
not what you wanted to do.
|
||||
|
||||
=head2 Parse Name
|
||||
|
||||
At this point, the optional name is parsed and filled into the C<name> field
|
||||
of the context.
|
||||
|
||||
=head2 The C<pre_subparse> Stage
|
||||
|
||||
void (*pre_subparse)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked just before C<start_subparse()> is called.
|
||||
|
||||
=head2 Parse Attrs
|
||||
|
||||
At this point the optional sub attributes are parsed and filled into the
|
||||
C<attrs> field of the context, then C<block_start()> is called.
|
||||
|
||||
=head2 The optional C<filter_attr> Stage
|
||||
|
||||
bool (*filter_attr)(pTHX_ struct XSParseSublikeContext *ctx,
|
||||
SV *attr, SV *val, void *hookdata);
|
||||
|
||||
If the I<flags> field includes C<XS_PARSE_SUBLIKE_FLAG_FILTERATTRS> then each
|
||||
individual attribute is passed through this optional filter function
|
||||
immediately as each is parsed. I<attr> will be a string SV containing the name
|
||||
of the attribute, and I<val> will either be C<NULL>, or a string SV containing
|
||||
the contents of the parens after its name (without the parens themselves).
|
||||
|
||||
If the filter returns C<true>, it indicates that it has in some way handled
|
||||
the attribute and it should not be added to the list given to C<newATTRSUB()>.
|
||||
If the filter returns C<false> it will be handled in the usual way; equivalent
|
||||
to the case where the filter function did not exist.
|
||||
|
||||
=head2 The C<post_blockstart> Stage
|
||||
|
||||
void (*post_blockstart)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked after the C<block_start()> function has been called. This hook stage
|
||||
may wish to perform any alterations of C<PL_compcv> or related, inspect or
|
||||
alter the lexical pad, provide hints hash values, or any other tasks before
|
||||
the signature and code body are parsed.
|
||||
|
||||
=head2 Parse Body
|
||||
|
||||
At this point, the main body of the function is parsed and the optree is
|
||||
stored in the C<body> field of the context. If the perl version supports sub
|
||||
signatures and they are enabled and found, the body will be prefixed with the
|
||||
signature ops as well.
|
||||
|
||||
=head2 The C<pre_blockend> Stage
|
||||
|
||||
void (*pre_blockend)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked just before the C<block_end()> function is invoked. The hook stage may
|
||||
wish to inspect or alter the optree stored in the C<body> context field.
|
||||
|
||||
=head2 The C<post_newcv> Stage
|
||||
|
||||
void (*post_newcv)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata)
|
||||
|
||||
Invoked just after C<newATTRSUB()> has been invoked on the optree. The hook
|
||||
stage may wish to inspect or alter the CV stored in the C<cv> context field.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Evans <leonerd@leonerd.org.uk>
|
||||
|
||||
=cut
|
||||
|
||||
0x55AA;
|
||||
|
|
@ -0,0 +1,579 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2019-2021 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
#define HAVE_PERL_VERSION(R, V, S) \
|
||||
(PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
|
||||
|
||||
#if HAVE_PERL_VERSION(5, 26, 0)
|
||||
# if !HAVE_PERL_VERSION(5, 31, 3)
|
||||
# include "parse_subsignature.c.inc"
|
||||
# endif
|
||||
|
||||
# include "make_argcheck_aux.c.inc"
|
||||
|
||||
# define HAVE_PARSE_SUBSIGNATURE
|
||||
#endif
|
||||
|
||||
#if !HAVE_PERL_VERSION(5, 22, 0)
|
||||
# include "block_start.c.inc"
|
||||
# include "block_end.c.inc"
|
||||
#endif
|
||||
|
||||
#ifndef wrap_keyword_plugin
|
||||
# include "wrap_keyword_plugin.c.inc"
|
||||
#endif
|
||||
|
||||
#include "lexer-additions.c.inc"
|
||||
|
||||
struct HooksAndData {
|
||||
const struct XSParseSublikeHooks *hooks;
|
||||
void *data;
|
||||
};
|
||||
|
||||
#define FOREACH_HOOKS_FORWARD \
|
||||
for(hooki = 0; \
|
||||
(hooki < nhooks) && (hooks = hooksanddata[hooki].hooks, hookdata = hooksanddata[hooki].data), (hooki < nhooks); \
|
||||
hooki++)
|
||||
|
||||
#define FOREACH_HOOKS_REVERSE \
|
||||
for(hooki = nhooks - 1; \
|
||||
(hooki >= 0) && (hooks = hooksanddata[hooki].hooks, hookdata = hooksanddata[hooki].data), (hooki >= 0); \
|
||||
hooki--)
|
||||
|
||||
static int parse(pTHX_
|
||||
struct HooksAndData hooksanddata[],
|
||||
size_t nhooks,
|
||||
OP **op_ptr)
|
||||
{
|
||||
struct XSParseSublikeContext ctx = { 0 };
|
||||
|
||||
IV hooki;
|
||||
const struct XSParseSublikeHooks *hooks;
|
||||
void *hookdata;
|
||||
|
||||
U8 require_parts = 0, skip_parts = 0;
|
||||
bool have_dynamic_actions = FALSE;
|
||||
|
||||
ENTER_with_name("parse_sublike");
|
||||
/* From here onwards any `return` must be prefixed by LEAVE_with_name() */
|
||||
U32 was_scopestack_ix = PL_scopestack_ix;
|
||||
|
||||
ctx.moddata = newHV();
|
||||
SAVEFREESV(ctx.moddata);
|
||||
|
||||
FOREACH_HOOKS_FORWARD {
|
||||
require_parts |= hooks->require_parts;
|
||||
skip_parts |= hooks->skip_parts;
|
||||
if(!(hooks->flags & XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL))
|
||||
require_parts |= XS_PARSE_SUBLIKE_PART_BODY;
|
||||
if(hooks->flags & XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS)
|
||||
have_dynamic_actions = TRUE;
|
||||
}
|
||||
|
||||
if(!(skip_parts & XS_PARSE_SUBLIKE_PART_NAME)) {
|
||||
ctx.name = lex_scan_ident();
|
||||
lex_read_space(0);
|
||||
}
|
||||
if((require_parts & XS_PARSE_SUBLIKE_PART_NAME) && !ctx.name)
|
||||
croak("Expected name for sub-like construction");
|
||||
|
||||
/* Initial idea of actions are determined by whether we have a name */
|
||||
ctx.actions = ctx.name
|
||||
? /* named */ XS_PARSE_SUBLIKE_ACTION_SET_CVNAME|XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL
|
||||
: /* anon */ XS_PARSE_SUBLIKE_ACTION_CVf_ANON|XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE|XS_PARSE_SUBLIKE_ACTION_RET_EXPR;
|
||||
|
||||
FOREACH_HOOKS_FORWARD {
|
||||
if(hooks->pre_subparse)
|
||||
(*hooks->pre_subparse)(aTHX_ &ctx, hookdata);
|
||||
}
|
||||
|
||||
#ifdef DEBUGGING
|
||||
if(PL_scopestack_ix != was_scopestack_ix)
|
||||
croak("ARGH: pre_subparse broke the scopestack (was %d, now %d)\n",
|
||||
was_scopestack_ix, PL_scopestack_ix);
|
||||
#endif
|
||||
|
||||
if(!have_dynamic_actions) {
|
||||
if(ctx.name)
|
||||
ctx.actions &= ~XS_PARSE_SUBLIKE_ACTION_CVf_ANON;
|
||||
else
|
||||
ctx.actions |= XS_PARSE_SUBLIKE_ACTION_CVf_ANON;
|
||||
}
|
||||
|
||||
I32 floor_ix = start_subparse(FALSE, ctx.actions & XS_PARSE_SUBLIKE_ACTION_CVf_ANON ? CVf_ANON : 0);
|
||||
SAVEFREESV(PL_compcv);
|
||||
|
||||
if(!(skip_parts & XS_PARSE_SUBLIKE_PART_ATTRS) && (lex_peek_unichar(0) == ':')) {
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
|
||||
ctx.attrs = newLISTOP(OP_LIST, 0, NULL, NULL);
|
||||
|
||||
while(1) {
|
||||
SV *attr = newSV(0);
|
||||
SV *val = newSV(0);
|
||||
if(!lex_scan_attrval_into(attr, val))
|
||||
break;
|
||||
lex_read_space(0);
|
||||
if(lex_peek_unichar(0) == ':') {
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
}
|
||||
|
||||
bool handled = FALSE;
|
||||
|
||||
FOREACH_HOOKS_FORWARD {
|
||||
if((hooks->flags & XS_PARSE_SUBLIKE_FLAG_FILTERATTRS) && (hooks->filter_attr))
|
||||
handled |= (*hooks->filter_attr)(aTHX_ &ctx, attr, val, hookdata);
|
||||
}
|
||||
|
||||
if(handled) {
|
||||
SvREFCNT_dec(attr);
|
||||
SvREFCNT_dec(val);
|
||||
continue;
|
||||
}
|
||||
|
||||
if(strEQ(SvPVX(attr), "lvalue")) {
|
||||
CvLVALUE_on(PL_compcv);
|
||||
continue;
|
||||
}
|
||||
|
||||
if(SvPOK(val))
|
||||
sv_catpvf(attr, "(%" SVf ")", val);
|
||||
SvREFCNT_dec(val);
|
||||
|
||||
ctx.attrs = op_append_elem(OP_LIST, ctx.attrs, newSVOP(OP_CONST, 0, attr));
|
||||
}
|
||||
}
|
||||
|
||||
PL_hints |= HINT_LOCALIZE_HH;
|
||||
I32 save_ix = block_start(TRUE);
|
||||
|
||||
FOREACH_HOOKS_FORWARD {
|
||||
if(hooks->post_blockstart)
|
||||
(*hooks->post_blockstart)(aTHX_ &ctx, hookdata);
|
||||
}
|
||||
|
||||
#ifdef DEBUGGING
|
||||
if(PL_scopestack_ix != was_scopestack_ix)
|
||||
croak("ARGH: post_blockstart broke the scopestack (was %d, now %d)\n",
|
||||
was_scopestack_ix, PL_scopestack_ix);
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_PARSE_SUBSIGNATURE
|
||||
OP *sigop = NULL;
|
||||
if(!(skip_parts & XS_PARSE_SUBLIKE_PART_SIGNATURE) && (lex_peek_unichar(0) == '(')) {
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
|
||||
#if HAVE_PERL_VERSION(5, 31, 3)
|
||||
/* core's parse_subsignature doesn't seem able to handle empty sigs
|
||||
* RT132284
|
||||
* https://github.com/Perl/perl5/issues/17689
|
||||
*/
|
||||
if(lex_peek_unichar(0) == ')') {
|
||||
/* Inject an empty OP_ARGCHECK much as core would do if it encountered
|
||||
* an empty signature */
|
||||
UNOP_AUX_item *aux = make_argcheck_aux(0, 0, 0);
|
||||
|
||||
sigop = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL),
|
||||
newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux));
|
||||
|
||||
/* a nextstate at the end handles context correctly for an empty
|
||||
* sub body */
|
||||
sigop = op_append_elem(OP_LINESEQ, sigop, newSTATEOP(0, NULL, NULL));
|
||||
|
||||
#if HAVE_PERL_VERSION(5,31,5)
|
||||
/* wrap the list of arg ops in a NULL aux op. This serves two
|
||||
* purposes. First, it makes the arg list a separate subtree
|
||||
* from the body of the sub, and secondly the null op may in
|
||||
* future be upgraded to an OP_SIGNATURE when implemented. For
|
||||
* now leave it as ex-argcheck
|
||||
*/
|
||||
sigop = newUNOP_AUX(OP_ARGCHECK, 0, sigop, NULL);
|
||||
op_null(sigop);
|
||||
#endif
|
||||
}
|
||||
else
|
||||
#endif
|
||||
{
|
||||
sigop = parse_subsignature(0);
|
||||
|
||||
if(PL_parser->error_count) {
|
||||
assert(PL_scopestack_ix == was_scopestack_ix);
|
||||
LEAVE_with_name("parse_sublike");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if(lex_peek_unichar(0) != ')')
|
||||
croak("Expected ')'");
|
||||
lex_read_unichar(0);
|
||||
lex_read_space(0);
|
||||
}
|
||||
#endif
|
||||
|
||||
if(lex_peek_unichar(0) == '{') {
|
||||
/* TODO: technically possible to have skip body flag */
|
||||
ctx.body = parse_block(0);
|
||||
SvREFCNT_inc(PL_compcv);
|
||||
}
|
||||
else if(require_parts & XS_PARSE_SUBLIKE_PART_BODY)
|
||||
croak("Expected '{' for block body");
|
||||
else if(lex_peek_unichar(0) == ';') {
|
||||
/* nothing to be done */
|
||||
}
|
||||
else
|
||||
croak("Expected '{' for block body or ';'");
|
||||
|
||||
#ifdef HAVE_PARSE_SUBSIGNATURE
|
||||
if(ctx.body && sigop) {
|
||||
/* parse_block() returns an empy block as a stub op.
|
||||
* no need to keep that if we we have a signature.
|
||||
*/
|
||||
if (ctx.body->op_type == OP_STUB) {
|
||||
op_free(ctx.body);
|
||||
ctx.body = NULL;
|
||||
}
|
||||
ctx.body = op_append_list(OP_LINESEQ, sigop, ctx.body);
|
||||
}
|
||||
#endif
|
||||
|
||||
if(PL_parser->error_count) {
|
||||
/* parse_block() still sometimes returns a valid body even if a parse
|
||||
* error happens.
|
||||
* We need to destroy this partial body before returning a valid(ish)
|
||||
* state to the keyword hook mechanism, so it will find the error count
|
||||
* correctly
|
||||
* See https://rt.cpan.org/Ticket/Display.html?id=130417
|
||||
*/
|
||||
op_free(ctx.body);
|
||||
|
||||
/* REALLY??! Do I really have to do this??
|
||||
* See also:
|
||||
* https://www.nntp.perl.org/group/perl.perl5.porters/2021/06/msg260642.html
|
||||
*/
|
||||
while(PL_scopestack_ix > was_scopestack_ix)
|
||||
LEAVE;
|
||||
|
||||
*op_ptr = newOP(OP_NULL, 0);
|
||||
if(ctx.name) {
|
||||
SvREFCNT_dec(ctx.name);
|
||||
assert(PL_scopestack_ix == was_scopestack_ix);
|
||||
LEAVE_with_name("parse_sublike");
|
||||
return KEYWORD_PLUGIN_STMT;
|
||||
}
|
||||
else {
|
||||
assert(PL_scopestack_ix == was_scopestack_ix);
|
||||
LEAVE_with_name("parse_sublike");
|
||||
return KEYWORD_PLUGIN_EXPR;
|
||||
}
|
||||
}
|
||||
|
||||
FOREACH_HOOKS_REVERSE {
|
||||
if(hooks->pre_blockend)
|
||||
(*hooks->pre_blockend)(aTHX_ &ctx, hookdata);
|
||||
}
|
||||
|
||||
#ifdef DEBUGGING
|
||||
if(PL_scopestack_ix != was_scopestack_ix)
|
||||
croak("ARGH: pre_blockend broke the scopestack (was %d, now %d)\n",
|
||||
was_scopestack_ix, PL_scopestack_ix);
|
||||
#endif
|
||||
|
||||
if(ctx.body) {
|
||||
ctx.body = block_end(save_ix, ctx.body);
|
||||
|
||||
if(!have_dynamic_actions) {
|
||||
if(ctx.name)
|
||||
ctx.actions |= XS_PARSE_SUBLIKE_ACTION_SET_CVNAME|XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL;
|
||||
else
|
||||
ctx.actions &= ~(XS_PARSE_SUBLIKE_ACTION_SET_CVNAME|XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL);
|
||||
}
|
||||
|
||||
/* If we want both SET_CVNAME and INSTALL_SYMBOL actions we might as well
|
||||
* let newATTRSUB() do it. If we only wanted one we need to be more subtle
|
||||
*/
|
||||
bool action_set_cvname = ctx.actions & XS_PARSE_SUBLIKE_ACTION_SET_CVNAME;
|
||||
bool action_install_symbol = ctx.actions & XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL;
|
||||
OP *nameop = NULL;
|
||||
if(ctx.name && action_set_cvname && action_install_symbol)
|
||||
nameop = newSVOP(OP_CONST, 0, SvREFCNT_inc(ctx.name));
|
||||
|
||||
if(!nameop && action_install_symbol)
|
||||
warn("Setting XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL without _ACTION_SET_CVNAME is nonsensical");
|
||||
|
||||
ctx.cv = newATTRSUB(floor_ix, nameop, NULL, ctx.attrs, ctx.body);
|
||||
|
||||
if(!nameop && action_set_cvname) {
|
||||
#if HAVE_PERL_VERSION(5,22,0)
|
||||
STRLEN namelen;
|
||||
const char *name = SvPV_const(ctx.name, namelen);
|
||||
U32 hash;
|
||||
PERL_HASH(hash, name, namelen);
|
||||
|
||||
/* Core's CvNAME_HEK_set macro uses unshare_hek() which isn't exposed. But we
|
||||
* likely don't need it here */
|
||||
#ifndef unshare_hek
|
||||
# define unshare_hek(h) (void)0
|
||||
#endif
|
||||
assert(!CvNAME_HEK(ctx.cv));
|
||||
|
||||
CvNAME_HEK_set(ctx.cv,
|
||||
share_hek(name, SvUTF8(ctx.name) ? -namelen : namelen, hash));
|
||||
#endif
|
||||
}
|
||||
|
||||
ctx.attrs = NULL;
|
||||
ctx.body = NULL;
|
||||
}
|
||||
|
||||
FOREACH_HOOKS_FORWARD {
|
||||
if(hooks->post_newcv)
|
||||
(*hooks->post_newcv)(aTHX_ &ctx, hookdata);
|
||||
}
|
||||
|
||||
assert(PL_scopestack_ix == was_scopestack_ix);
|
||||
LEAVE_with_name("parse_sublike");
|
||||
|
||||
if(!have_dynamic_actions) {
|
||||
if(!ctx.name)
|
||||
ctx.actions |= XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE;
|
||||
else
|
||||
ctx.actions &= ~XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE;
|
||||
}
|
||||
|
||||
if(!(ctx.actions & XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE)) {
|
||||
*op_ptr = newOP(OP_NULL, 0);
|
||||
|
||||
SvREFCNT_dec(ctx.name);
|
||||
}
|
||||
else {
|
||||
*op_ptr = newUNOP(OP_REFGEN, 0,
|
||||
newSVOP(OP_ANONCODE, 0, (SV *)ctx.cv));
|
||||
}
|
||||
|
||||
if(!have_dynamic_actions) {
|
||||
if(!ctx.name)
|
||||
ctx.actions |= XS_PARSE_SUBLIKE_ACTION_RET_EXPR;
|
||||
else
|
||||
ctx.actions &= ~XS_PARSE_SUBLIKE_ACTION_RET_EXPR;
|
||||
}
|
||||
|
||||
return (ctx.actions & XS_PARSE_SUBLIKE_ACTION_RET_EXPR) ? KEYWORD_PLUGIN_EXPR : KEYWORD_PLUGIN_STMT;
|
||||
}
|
||||
|
||||
static int IMPL_xs_parse_sublike_v4(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
{
|
||||
struct HooksAndData hd = { .hooks = hooks, .data = hookdata };
|
||||
return parse(aTHX_ &hd, 1, op_ptr);
|
||||
}
|
||||
|
||||
static int IMPL_xs_parse_sublike_v3(pTHX_ const void *hooks, void *hookdata, OP **op_ptr)
|
||||
{
|
||||
croak("XS::Parse::Sublike ABI v3 is no longer supported; the caller should be rebuilt to use v4");
|
||||
}
|
||||
|
||||
struct Registration;
|
||||
struct Registration {
|
||||
int ver;
|
||||
struct Registration *next;
|
||||
const char *kw;
|
||||
STRLEN kwlen;
|
||||
union {
|
||||
const struct XSParseSublikeHooks *hooks;
|
||||
};
|
||||
void *hookdata;
|
||||
|
||||
STRLEN permit_hintkey_len;
|
||||
};
|
||||
|
||||
#define REGISTRATIONS_LOCK OP_CHECK_MUTEX_LOCK
|
||||
#define REGISTRATIONS_UNLOCK OP_CHECK_MUTEX_UNLOCK
|
||||
|
||||
static struct Registration *registrations;
|
||||
|
||||
static void register_sublike(pTHX_ const char *kw, const void *hooks, void *hookdata, int ver)
|
||||
{
|
||||
struct Registration *reg;
|
||||
Newx(reg, 1, struct Registration);
|
||||
|
||||
reg->kw = savepv(kw);
|
||||
reg->kwlen = strlen(kw);
|
||||
reg->ver = ver;
|
||||
reg->hooks = hooks;
|
||||
reg->hookdata = hookdata;
|
||||
|
||||
if(reg->ver >= 4 && reg->hooks->permit_hintkey)
|
||||
reg->permit_hintkey_len = strlen(reg->hooks->permit_hintkey);
|
||||
else
|
||||
reg->permit_hintkey_len = 0;
|
||||
|
||||
REGISTRATIONS_LOCK;
|
||||
{
|
||||
reg->next = registrations;
|
||||
registrations = reg;
|
||||
}
|
||||
REGISTRATIONS_UNLOCK;
|
||||
}
|
||||
|
||||
static void IMPL_register_xs_parse_sublike_v4(pTHX_ const char *kw, const struct XSParseSublikeHooks *hooks, void *hookdata)
|
||||
{
|
||||
register_sublike(aTHX_ kw, hooks, hookdata, 4);
|
||||
}
|
||||
|
||||
static void IMPL_register_xs_parse_sublike_v3(pTHX_ const char *kw, const void *hooks, void *hookdata)
|
||||
{
|
||||
croak("XS::Parse::Sublike ABI v3 is no longer supported; the caller should be rebuilt to use v4");
|
||||
}
|
||||
|
||||
static const struct Registration *find_permitted(pTHX_ const char *kw, STRLEN kwlen)
|
||||
{
|
||||
const struct Registration *reg;
|
||||
|
||||
HV *hints = GvHV(PL_hintgv);
|
||||
|
||||
for(reg = registrations; reg; reg = reg->next) {
|
||||
if(reg->kwlen != kwlen || !strEQ(reg->kw, kw))
|
||||
continue;
|
||||
|
||||
if(reg->hooks->permit_hintkey &&
|
||||
(!hints || !hv_fetch(hints, reg->hooks->permit_hintkey, reg->permit_hintkey_len, 0)))
|
||||
continue;
|
||||
|
||||
if(reg->hooks->permit &&
|
||||
!(*reg->hooks->permit)(aTHX_ reg->hookdata))
|
||||
continue;
|
||||
|
||||
return reg;
|
||||
}
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static int IMPL_xs_parse_sublike_any_v4(pTHX_ const struct XSParseSublikeHooks *hooksA, void *hookdataA, OP **op_ptr)
|
||||
{
|
||||
SV *kwsv = lex_scan_ident();
|
||||
if(!kwsv || !SvCUR(kwsv))
|
||||
croak("Expected a keyword to introduce a sub or sub-like construction");
|
||||
|
||||
const char *kw = SvPV_nolen(kwsv);
|
||||
STRLEN kwlen = SvCUR(kwsv);
|
||||
|
||||
lex_read_space(0);
|
||||
|
||||
const struct Registration *reg = NULL;
|
||||
/* We permit 'sub' as a NULL set of hooks; anything else should be a registered keyword */
|
||||
if(kwlen != 3 || !strEQ(kw, "sub")) {
|
||||
reg = find_permitted(aTHX_ kw, kwlen);
|
||||
if(!reg)
|
||||
croak("Expected a keyword to introduce a sub or sub-like construction, found \"%.*s\"",
|
||||
kwlen, kw);
|
||||
}
|
||||
|
||||
SvREFCNT_dec(kwsv);
|
||||
|
||||
struct HooksAndData hd[] = {
|
||||
{ .hooks = hooksA, .data = hookdataA },
|
||||
{ 0 }
|
||||
};
|
||||
struct XSParseSublikeHooks hooks;
|
||||
|
||||
if(reg) {
|
||||
hd[1].hooks = reg->hooks;
|
||||
hd[1].data = reg->hookdata;
|
||||
}
|
||||
|
||||
return parse(aTHX_ hd, 1 + !!reg, op_ptr);
|
||||
}
|
||||
|
||||
static int IMPL_xs_parse_sublike_any_v3(pTHX_ const void *hooksA, void *hookdataA, OP **op_ptr)
|
||||
{
|
||||
croak("XS::Parse::Sublike ABI v3 is no longer supported; the caller should be rebuilt to use v4");
|
||||
}
|
||||
|
||||
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
|
||||
|
||||
static int my_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op_ptr)
|
||||
{
|
||||
const struct Registration *reg = find_permitted(aTHX_ kw, kwlen);
|
||||
|
||||
if(!reg)
|
||||
return (*next_keyword_plugin)(aTHX_ kw, kwlen, op_ptr);
|
||||
|
||||
lex_read_space(0);
|
||||
|
||||
/* We'll abuse the SvPVX storage of an SV to keep an array of HooksAndData
|
||||
* structures
|
||||
*/
|
||||
SV *hdlsv = newSV(4 * sizeof(struct HooksAndData));
|
||||
SAVEFREESV(hdlsv);
|
||||
struct HooksAndData *hd = (struct HooksAndData *)SvPVX(hdlsv);
|
||||
size_t nhooks = 1;
|
||||
|
||||
struct XSParseSublikeHooks *hooks = (struct XSParseSublikeHooks *)reg->hooks;
|
||||
hd[0].hooks = hooks;
|
||||
hd[0].data = reg->hookdata;
|
||||
|
||||
while(hooks->flags & XS_PARSE_SUBLIKE_FLAG_PREFIX) {
|
||||
/* After a prefixing keyword, expect another one */
|
||||
SV *kwsv = lex_scan_ident();
|
||||
SAVEFREESV(kwsv);
|
||||
|
||||
if(!kwsv || !SvCUR(kwsv))
|
||||
croak("Expected a keyword to introduce a sub or sub-like construction");
|
||||
|
||||
kw = SvPV_nolen(kwsv);
|
||||
kwlen = SvCUR(kwsv);
|
||||
|
||||
lex_read_space(0);
|
||||
|
||||
/* We permit 'sub' as a NULL set of hooks; anything else should be a registered keyword */
|
||||
if(kwlen == 3 && strEQ(kw, "sub"))
|
||||
break;
|
||||
|
||||
reg = find_permitted(aTHX_ kw, kwlen);
|
||||
if(!reg)
|
||||
croak("Expected a keyword to introduce a sub or sub-like construction, found \"%.*s\"",
|
||||
kwlen, kw);
|
||||
|
||||
hooks = (struct XSParseSublikeHooks *)reg->hooks;
|
||||
|
||||
if(SvLEN(hdlsv) < (nhooks + 1) * sizeof(struct HooksAndData)) {
|
||||
SvGROW(hdlsv, SvLEN(hdlsv) * 2);
|
||||
hd = (struct HooksAndData *)SvPVX(hdlsv);
|
||||
}
|
||||
hd[nhooks].hooks = hooks;
|
||||
hd[nhooks].data = reg->hookdata;
|
||||
nhooks++;
|
||||
}
|
||||
|
||||
return parse(aTHX_ hd, nhooks, op_ptr);
|
||||
}
|
||||
|
||||
MODULE = XS::Parse::Sublike PACKAGE = XS::Parse::Sublike
|
||||
|
||||
BOOT:
|
||||
/* Legacy lookup mechanism using perl symbol table */
|
||||
sv_setiv(get_sv("XS::Parse::Sublike::ABIVERSION", GV_ADDMULTI), 4);
|
||||
sv_setuv(get_sv("XS::Parse::Sublike::PARSE", GV_ADDMULTI), PTR2UV(&IMPL_xs_parse_sublike_v3));
|
||||
sv_setuv(get_sv("XS::Parse::Sublike::REGISTER", GV_ADDMULTI), PTR2UV(&IMPL_register_xs_parse_sublike_v3));
|
||||
sv_setuv(get_sv("XS::Parse::Sublike::PARSEANY", GV_ADDMULTI), PTR2UV(&IMPL_xs_parse_sublike_any_v3));
|
||||
|
||||
/* Newer mechanism */
|
||||
sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/ABIVERSION_MIN", 1), 4);
|
||||
sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/ABIVERSION_MAX", 1), XSPARSESUBLIKE_ABI_VERSION);
|
||||
sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parse()@4", 1), PTR2UV(&IMPL_xs_parse_sublike_v4));
|
||||
sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/register()@4", 1), PTR2UV(&IMPL_register_xs_parse_sublike_v4));
|
||||
sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parseany()@4", 1), PTR2UV(&IMPL_xs_parse_sublike_any_v4));
|
||||
|
||||
wrap_keyword_plugin(&my_keyword_plugin, &next_keyword_plugin);
|
||||
|
|
@ -0,0 +1,208 @@
|
|||
# You may distribute under the terms of either the GNU General Public License
|
||||
# or the Artistic License (the same terms as Perl itself)
|
||||
#
|
||||
# (C) Paul Evans, 2020-2021 -- leonerd@leonerd.org.uk
|
||||
|
||||
package XS::Parse::Sublike::Builder 0.16;
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
C<XS::Parse::Sublike::Builder> - build-time support for C<XS::Parse::Sublike>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
In F<Build.PL>:
|
||||
|
||||
use XS::Parse::Sublike::Builder;
|
||||
|
||||
my $build = Module::Build->new(
|
||||
...,
|
||||
configure_requires => {
|
||||
...
|
||||
'XS::Parse::Sublike::Builder' => 0,
|
||||
}
|
||||
);
|
||||
|
||||
XS::Parse::Sublike::Builder->extend_module_build( $build );
|
||||
|
||||
...
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a build-time helper to assist authors writing XS modules
|
||||
that use L<XS::Parse::Sublike>. It prepares a L<Module::Build>-using
|
||||
distribution to be able to make use of C<XS::Parse::Sublike>.
|
||||
|
||||
=cut
|
||||
|
||||
require XS::Parse::Sublike::Builder_data;
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
=head2 write_XSParseSublike_h
|
||||
|
||||
XS::Parse::Sublike::Builder->write_XSParseSublike_h
|
||||
|
||||
Writes the F<XSParseSublike.h> file to the current working directory. To cause
|
||||
the compiler to actually find this file, see L</extra_compiler_flags>.
|
||||
|
||||
=cut
|
||||
|
||||
sub write_XSParseSublike_h
|
||||
{
|
||||
shift;
|
||||
|
||||
open my $out, ">", "XSParseSublike.h" or
|
||||
die "Cannot open XSParseSublike.h for writing - $!\n";
|
||||
|
||||
$out->print( XS::Parse::Sublike::Builder_data->XSPARSESUBLIKE_H );
|
||||
}
|
||||
|
||||
=head2 extra_compiler_flags
|
||||
|
||||
@flags = XS::Parse::Sublike::Builder->extra_compiler_flags
|
||||
|
||||
Returns a list of extra flags that the build scripts should add to the
|
||||
compiler invocation. This enables the C compiler to find the
|
||||
F<XSParseSublike.h> file.
|
||||
|
||||
=cut
|
||||
|
||||
sub extra_compiler_flags
|
||||
{
|
||||
shift;
|
||||
return "-I.";
|
||||
}
|
||||
|
||||
=head2 extend_module_build
|
||||
|
||||
XS::Parse::Sublike::Builder->extend_module_build( $build )
|
||||
|
||||
A convenient shortcut for performing all the tasks necessary to make a
|
||||
L<Module::Build>-based distribution use the helper.
|
||||
|
||||
=cut
|
||||
|
||||
sub extend_module_build
|
||||
{
|
||||
my $self = shift;
|
||||
my ( $build ) = @_;
|
||||
|
||||
eval { $self->write_XSParseSublike_h } or do {
|
||||
warn $@;
|
||||
return;
|
||||
};
|
||||
|
||||
# preserve existing flags
|
||||
my @flags = @{ $build->extra_compiler_flags };
|
||||
push @flags, $self->extra_compiler_flags;
|
||||
|
||||
$build->extra_compiler_flags( @flags );
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Evans <leonerd@leonerd.org.uk>
|
||||
|
||||
=cut
|
||||
|
||||
0x55AA;
|
||||
|
||||
__DATA__
|
||||
#ifndef __XS_PARSE_SUBLIKE_H__
|
||||
#define __XS_PARSE_SUBLIKE_H__
|
||||
|
||||
#define XSPARSESUBLIKE_ABI_VERSION 3
|
||||
|
||||
struct XSParseSublikeContext {
|
||||
SV *name; /* may be NULL for anon subs */
|
||||
/* STAGE pre_subparse */
|
||||
OP *attrs; /* may be NULL */
|
||||
/* STAGE post_blockstart */
|
||||
OP *body;
|
||||
/* STAGE pre_blockend */
|
||||
CV *cv;
|
||||
/* STAGE post_newcv */
|
||||
};
|
||||
|
||||
enum {
|
||||
XS_PARSE_SUBLIKE_FLAG_FILTERATTRS = 1<<0,
|
||||
};
|
||||
|
||||
enum {
|
||||
XS_PARSE_SUBLIKE_PART_NAME = 1<<0,
|
||||
XS_PARSE_SUBLIKE_PART_ATTRS = 1<<1,
|
||||
XS_PARSE_SUBLIKE_PART_SIGNATURE = 1<<2,
|
||||
};
|
||||
|
||||
struct XSParseSublikeHooks {
|
||||
U16 flags;
|
||||
U8 require_parts;
|
||||
U8 skip_parts;
|
||||
bool (*permit) (pTHX_ void *hookdata);
|
||||
void (*pre_subparse) (pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
void (*post_blockstart)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
void (*pre_blockend) (pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
void (*post_newcv) (pTHX_ struct XSParseSublikeContext *ctx, void *hookdata);
|
||||
|
||||
/* if flags & XS_PARSE_SUBLIKE_FLAG_FILTERATTRS */
|
||||
bool (*filter_attr) (pTHX_ struct XSParseSublikeContext *ctx, SV *attr, SV *val, void *hookdata);
|
||||
};
|
||||
|
||||
static int (*parse_xs_parse_sublike_func)(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr);
|
||||
#define xs_parse_sublike(hooks, hookdata, op_ptr) S_xs_parse_sublike(aTHX_ hooks, hookdata, op_ptr)
|
||||
static int S_xs_parse_sublike(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
{
|
||||
if(!parse_xs_parse_sublike_func)
|
||||
croak("Must call boot_xs_parse_sublike() first");
|
||||
|
||||
return (*parse_xs_parse_sublike_func)(aTHX_ hooks, hookdata, op_ptr);
|
||||
}
|
||||
|
||||
static void (*register_xs_parse_sublike_func)(pTHX_ const char *kw, const struct XSParseSublikeHooks *hooks, void *hookdata);
|
||||
#define register_xs_parse_sublike(kw, hooks, hookdata) S_register_xs_parse_sublike(aTHX_ kw, hooks, hookdata)
|
||||
static void S_register_xs_parse_sublike(pTHX_ const char *kw, const struct XSParseSublikeHooks *hooks, void *hookdata)
|
||||
{
|
||||
if(!register_xs_parse_sublike_func)
|
||||
croak("Must call boot_xs_parse_sublike() first");
|
||||
|
||||
return (*register_xs_parse_sublike_func)(aTHX_ kw, hooks, hookdata);
|
||||
}
|
||||
|
||||
static int (*parseany_xs_parse_sublike_func)(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr);
|
||||
#define xs_parse_sublike_any(hooks, hookdata, op_ptr) S_xs_parse_sublike_any(aTHX_ hooks, hookdata, op_ptr)
|
||||
static int S_xs_parse_sublike_any(pTHX_ const struct XSParseSublikeHooks *hooks, void *hookdata, OP **op_ptr)
|
||||
{
|
||||
if(!parseany_xs_parse_sublike_func)
|
||||
croak("Must call boot_xs_parse_sublike() first");
|
||||
|
||||
return (*parseany_xs_parse_sublike_func)(aTHX_ hooks, hookdata, op_ptr);
|
||||
}
|
||||
|
||||
#define boot_xs_parse_sublike(ver) S_boot_xs_parse_sublike(aTHX_ ver)
|
||||
static void S_boot_xs_parse_sublike(pTHX_ double ver) {
|
||||
SV *versv = ver ? newSVnv(ver) : NULL;
|
||||
|
||||
load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("XS::Parse::Sublike"), versv, NULL);
|
||||
|
||||
int abi_version = SvIV(get_sv("XS::Parse::Sublike::ABIVERSION", 0));
|
||||
if(abi_version != XSPARSESUBLIKE_ABI_VERSION)
|
||||
croak("XS::Parse::Sublike ABI version mismatch - library provides %d, compiled for %d",
|
||||
abi_version, XSPARSESUBLIKE_ABI_VERSION);
|
||||
|
||||
parse_xs_parse_sublike_func = INT2PTR(int (*)(pTHX_ const struct XSParseSublikeHooks *, void *, OP**),
|
||||
SvUV(get_sv("XS::Parse::Sublike::PARSE", 0)));
|
||||
|
||||
register_xs_parse_sublike_func = INT2PTR(void (*)(pTHX_ const char *, const struct XSParseSublikeHooks *, void *),
|
||||
SvUV(get_sv("XS::Parse::Sublike::REGISTER", 0)));
|
||||
|
||||
parseany_xs_parse_sublike_func = INT2PTR(int (*)(pTHX_ const struct XSParseSublikeHooks *, void *, OP**),
|
||||
SvUV(get_sv("XS::Parse::Sublike::PARSEANY", 0)));
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
# You may distribute under the terms of either the GNU General Public License
|
||||
# or the Artistic License (the same terms as Perl itself)
|
||||
#
|
||||
# (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use B qw( perlstring );
|
||||
use Module::Build;
|
||||
|
||||
open my $outh, ">", $ARGV[0] or
|
||||
die "Cannot write $ARGV[0] - $!\n";
|
||||
|
||||
local $/;
|
||||
|
||||
$outh->print( scalar do { <DATA> } );
|
||||
|
||||
$outh->print( scalar do {
|
||||
open my $in_h, "<", "XSParseSublike.h" or
|
||||
die "Cannot open XSParseSublike.h - $!";
|
||||
<$in_h> } );
|
||||
|
||||
__DATA__
|
||||
package XS::Parse::Sublike::Builder_data 0.16;
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
# The contents of the "XSParseSublike.h" file
|
||||
my $XSParseSublike_h = do {
|
||||
local $/;
|
||||
readline DATA;
|
||||
};
|
||||
sub XSPARSESUBLIKE_H() { $XSParseSublike_h }
|
||||
|
||||
0x55AA;
|
||||
|
||||
__DATA__
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use_ok( "XS::Parse::Sublike" );
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::func";
|
||||
|
||||
# named func
|
||||
{
|
||||
func example { return 123; }
|
||||
|
||||
is( example(), 123, 'named func' );
|
||||
}
|
||||
|
||||
# anon func
|
||||
{
|
||||
my $ex2 = func { return 456; };
|
||||
|
||||
is( $ex2->(), 456, 'anon func' );
|
||||
}
|
||||
|
||||
# func still obtains :ATTRS
|
||||
{
|
||||
my $modify_invoked;
|
||||
|
||||
sub MODIFY_CODE_ATTRIBUTES
|
||||
{
|
||||
my ( $pkg, $sub, $attr ) = @_;
|
||||
$modify_invoked++;
|
||||
Test::More::is( $attr, "MyCustomAttribute(value here)",
|
||||
'MODIFY_CODE_ATTRIBUTES takes attribute' );
|
||||
|
||||
return ();
|
||||
}
|
||||
|
||||
func withattr :MyCustomAttribute(value here) { }
|
||||
is( $modify_invoked, 1, 'MODIFY_CODE_ATTRIBUTES invoked' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
$] >= 5.026000 or plan skip_all => "No parse_subsignature()";
|
||||
}
|
||||
use Test::Fatal;
|
||||
|
||||
use feature 'signatures';
|
||||
no warnings 'experimental';
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::func";
|
||||
|
||||
# basic sig
|
||||
{
|
||||
func withparam($x) { return $x + 1 }
|
||||
|
||||
is( withparam( 4 ), 5, 'func with param' );
|
||||
}
|
||||
|
||||
# The following are additional tests that our pre-5.31.3 backported
|
||||
# parse_subsignature() works correctly
|
||||
{
|
||||
func sum(@x) {
|
||||
my $ret = 0;
|
||||
$ret += $_ for @x;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
is( sum( 10, 20, 30 ), 60, 'func with slurpy parameter' );
|
||||
|
||||
func firstandthird($x, $, $z) {
|
||||
return $x . $z;
|
||||
}
|
||||
|
||||
is( firstandthird(qw( a b c )), "ac", 'func with unnamed parameter' );
|
||||
|
||||
func withoptparam($one = 1) { return $one + 2 }
|
||||
|
||||
is( withoptparam, 3, 'func with optional param missing' );
|
||||
is( withoptparam( 2 ), 4, 'func with optional param present' );
|
||||
|
||||
func has_whitespace (
|
||||
$x
|
||||
) {
|
||||
return $x;
|
||||
}
|
||||
|
||||
is( has_whitespace( "value" ), "value", 'func with whitespace in signature' );
|
||||
|
||||
# RT132284
|
||||
func noparams() { return "constant" }
|
||||
|
||||
is( noparams, "constant", 'func with no params' );
|
||||
like( exception { noparams( 1, 2, 3 ) },
|
||||
# message was extended somewhere in perl 5.33
|
||||
qr/^Too many arguments for subroutine 'main::noparams' (\(.*\) )?at /,
|
||||
'Exception thrown from empty signature validation failure' );
|
||||
}
|
||||
|
||||
# RT131571
|
||||
{
|
||||
func withattr :method ($self, @args) { }
|
||||
|
||||
ok( scalar( grep { m/^method$/ } attributes::get( \&withattr ) ),
|
||||
'func with attr and signture does not collide' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
$] >= 5.026000 or plan skip_all => "No parse_subsignature()";
|
||||
}
|
||||
|
||||
use feature 'signatures';
|
||||
no warnings 'experimental';
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::func";
|
||||
|
||||
use B::Deparse;
|
||||
|
||||
my $deparser = B::Deparse->new();
|
||||
|
||||
# check that signatured functions deparse the right way
|
||||
# (RT132335)
|
||||
|
||||
# with signature
|
||||
{
|
||||
my $sub = sub ($x, $y) { return $x + $y; };
|
||||
my $func = func ($x, $y) { return $x + $y; };
|
||||
|
||||
my $code = $deparser->coderef2text( $sub ); # the reference source text
|
||||
is( $deparser->coderef2text( $func ), $code,
|
||||
'Deparsed func with signature identical to deparsed code' );
|
||||
}
|
||||
|
||||
# empty signature
|
||||
{
|
||||
my $sub = sub () { return 123; };
|
||||
my $func = func () { return 123; };
|
||||
|
||||
my $code = $deparser->coderef2text( $sub ); # the reference source text
|
||||
is( $deparser->coderef2text( $func ), $code,
|
||||
'Deparsed func with empty signature identical to deparsed code' );
|
||||
}
|
||||
|
||||
# empty body
|
||||
{
|
||||
my $sub = sub () {};
|
||||
my $func = func () {};
|
||||
|
||||
my $code = $deparser->coderef2text( $sub ); # the reference source text
|
||||
is( $deparser->coderef2text( $func ), $code,
|
||||
'Deparsed func with empty body identical to deparsed code' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
||||
sub stages { return $_[0] }
|
||||
|
||||
# not permitted
|
||||
{
|
||||
my $ret = stages { one => "one" };
|
||||
|
||||
is_deeply( $ret, { one => "one" },
|
||||
'not permitted keyword falls through to regular symbol lookup' );
|
||||
}
|
||||
|
||||
# permitted
|
||||
{
|
||||
BEGIN { $^H{"t::stages/permit"} = 1; }
|
||||
|
||||
my $ret = stages { two => "two" };
|
||||
|
||||
is( ref $ret, "CODE",
|
||||
'permitted keyword becomes a CODE ref' );
|
||||
}
|
||||
|
||||
# TODO: test that it can throw
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
||||
our $VAR;
|
||||
BEGIN { $^H{"t::stages/permit"} = 1; }
|
||||
|
||||
{
|
||||
BEGIN { $^H{'t::stages/pre_subparse-capture'} = 1; }
|
||||
|
||||
BEGIN { $VAR = "before" }
|
||||
stages capture {
|
||||
BEGIN { $VAR = "inside" }
|
||||
}
|
||||
|
||||
is( $t::stages::captured, "before",
|
||||
'captured value of $VAR before block' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
||||
our $VAR;
|
||||
BEGIN { $^H{"t::stages/permit"} = 1; }
|
||||
|
||||
{
|
||||
BEGIN { $^H{'t::stages/post_blockstart-capture'} = 1; }
|
||||
|
||||
BEGIN { $VAR = "before" }
|
||||
stages capture {
|
||||
BEGIN { $VAR = "inside" }
|
||||
}
|
||||
|
||||
is( $t::stages::captured, "before",
|
||||
'captured value of $VAR before block' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
||||
our $VAR;
|
||||
BEGIN { $^H{"t::stages/permit"} = 1; }
|
||||
|
||||
{
|
||||
BEGIN { $^H{'t::stages/pre_blockend-capture'} = 1; }
|
||||
|
||||
BEGIN { $VAR = "before" }
|
||||
stages capture {
|
||||
BEGIN { $VAR = "inside" }
|
||||
}
|
||||
|
||||
is( $t::stages::captured, "inside",
|
||||
'captured value of $VAR inside block' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
||||
BEGIN { $^H{"t::stages/permit"} = 1; }
|
||||
|
||||
{
|
||||
BEGIN { $^H{'t::stages/post_newcv-capture-cv'} = 1; }
|
||||
|
||||
stages capture { }
|
||||
|
||||
is( $t::stages::captured, \&capture,
|
||||
'captured value of new CV' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
||||
our $VAR;
|
||||
BEGIN { $^H{"t::stages/permit"} = 1; }
|
||||
|
||||
{
|
||||
BEGIN { $^H{'t::stages/filter_attr-capture'} = 1; }
|
||||
|
||||
stages withattr :atname(atvalue) { }
|
||||
|
||||
is_deeply( $t::stages::captured, [ atname => "atvalue" ],
|
||||
'captured an attribute by attr filter' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::registrations";
|
||||
|
||||
# Check the individual `func` registrations do not clash
|
||||
{
|
||||
{
|
||||
BEGIN { $^H{"t::registrations/red"} = 1 }
|
||||
func returns_red { }
|
||||
}
|
||||
{
|
||||
BEGIN { $^H{"t::registrations/blue"} = 1 }
|
||||
func returns_blue { }
|
||||
}
|
||||
|
||||
is( returns_red(), "red", 'returns red' );
|
||||
is( returns_blue(), "blue", 'returns blue' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::any";
|
||||
|
||||
our $LOG; BEGIN { $LOG = "" };
|
||||
|
||||
prefixed func example {
|
||||
BEGIN { $LOG .= "B" }
|
||||
}
|
||||
|
||||
is( $LOG, "SpSfEpEfBLfLpNpNf", 'stages run in correct order' );
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::prefix";
|
||||
|
||||
our $LOG; BEGIN { $LOG = "" };
|
||||
|
||||
prefixed func example {
|
||||
BEGIN { $LOG .= "B" }
|
||||
}
|
||||
|
||||
is( $LOG, "SpSfEpEfBLfLpNpNf", 'stages run in correct order' );
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::parts";
|
||||
|
||||
# name optional
|
||||
{
|
||||
parts NAME { }
|
||||
|
||||
my $code = parts { };
|
||||
is( ref $code, "CODE", '$code is CODEref' );
|
||||
}
|
||||
|
||||
# name required
|
||||
{
|
||||
BEGIN { $^H{"t::parts/require-name"} = 1; }
|
||||
|
||||
ok( !defined eval 'my $code = parts { };',
|
||||
'anon func fails to parse when name required' );
|
||||
}
|
||||
|
||||
# name skipped
|
||||
{
|
||||
BEGIN { $^H{"t::parts/skip-name"} = 1; }
|
||||
|
||||
ok( !defined eval 'parts OTHERNAME { }; 1',
|
||||
'named func fails to parse when name skipped' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::parts";
|
||||
|
||||
# attrs optional
|
||||
{
|
||||
parts NAME { }
|
||||
|
||||
parts ANAME :method { }
|
||||
|
||||
pass( 'Optional attributes permitted but not required' );
|
||||
}
|
||||
|
||||
# attrs skipped
|
||||
{
|
||||
BEGIN { $^H{"t::parts/skip-attrs"} = 1; }
|
||||
|
||||
ok( !defined eval 'parts OTHERNAME :method { }; 1',
|
||||
'func with attrs to parse when attrs skipped' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
$] >= 5.026000 or plan skip_all => "No parse_subsignature()";
|
||||
}
|
||||
|
||||
use feature 'signatures';
|
||||
no warnings 'experimental';
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::parts";
|
||||
|
||||
# signature optional
|
||||
{
|
||||
parts NAME { }
|
||||
|
||||
parts ANAME ($x) { }
|
||||
|
||||
pass( 'Optional attributes permitted but not required' );
|
||||
}
|
||||
|
||||
# signature skipped
|
||||
{
|
||||
BEGIN { $^H{"t::parts/skip-signature"} = 1; }
|
||||
|
||||
ok( !defined eval 'parts OTHERNAME ($x) { }; 1',
|
||||
'func with signature to parse when signature skipped' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::flags";
|
||||
|
||||
BEGIN { $^H{"t::flags/no_body"} = 1 }
|
||||
|
||||
{
|
||||
no_body justaname;
|
||||
my $name; BEGIN { $name = $t::flags::captured_name; }
|
||||
is( $name, "justaname", 'no_body saw just the function name' );
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Sub::Util 'subname';
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::actions";
|
||||
|
||||
BEGIN { $^H{"t::actions/action"} = 1 }
|
||||
|
||||
{
|
||||
action name { "OK" }
|
||||
ok( name(), 'default actions parses like named sub' );
|
||||
ok( defined &name, '&name is on symbol table' );
|
||||
is( subname( \&name ), "main::name", '&name has subname' );
|
||||
}
|
||||
|
||||
{
|
||||
my $code = action nameER { "OK" };
|
||||
ok( $code->(), 'RET_EXRP + REFGEN_ANONCODE behaves as anon sub' );
|
||||
ok( defined &nameER, '&nameER is on symbol table' );
|
||||
is( subname( $code ), "main::nameER", '$code has subname' );
|
||||
}
|
||||
|
||||
{
|
||||
my $code = action nameiER { "OK" };
|
||||
ok( $code->(), 'Unininstalled CV is still invokable' );
|
||||
ok( !defined &nameiER, '&nameiER not on symbol table' );
|
||||
# CvNAME_HEK_set() doesn't work before perl 5.22
|
||||
is( subname( $code ), "main::nameiER", '$code still has a subname anyway' ) if $] >= 5.022;
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
eval "use Test::Pod 1.00";
|
||||
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
|
||||
|
||||
all_pod_files_ok();
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
static void action_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
const char *namestr = SvPVX(ctx->name);
|
||||
|
||||
if(strchr(namestr, 'i'))
|
||||
ctx->actions &= ~XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL;
|
||||
if(strchr(namestr, 'R'))
|
||||
ctx->actions |= XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE;
|
||||
if(strchr(namestr, 'E'))
|
||||
ctx->actions |= XS_PARSE_SUBLIKE_ACTION_RET_EXPR;
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_action_hooks = {
|
||||
.permit_hintkey = "t::actions/action",
|
||||
.flags = XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS,
|
||||
.require_parts = XS_PARSE_SUBLIKE_PART_NAME,
|
||||
|
||||
.pre_subparse = action_pre_subparse,
|
||||
};
|
||||
|
||||
MODULE = t::actions PACKAGE = t::actions
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("action", &parse_action_hooks, NULL);
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
#ifndef wrap_keyword_plugin
|
||||
# include "wrap_keyword_plugin.c.inc"
|
||||
#endif
|
||||
|
||||
static void func_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Sf");
|
||||
}
|
||||
|
||||
static void func_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Ef");
|
||||
}
|
||||
|
||||
static void func_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Lf");
|
||||
}
|
||||
|
||||
static void func_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Nf");
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_func_hooks = {
|
||||
.pre_subparse = func_pre_subparse,
|
||||
.post_blockstart = func_post_blockstart,
|
||||
.pre_blockend = func_pre_blockend,
|
||||
.post_newcv = func_post_newcv,
|
||||
};
|
||||
|
||||
static void prefixed_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Sp");
|
||||
}
|
||||
|
||||
static void prefixed_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Ep");
|
||||
}
|
||||
|
||||
static void prefixed_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Lp");
|
||||
}
|
||||
|
||||
static void prefixed_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Np");
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_prefixed_hooks = {
|
||||
.pre_subparse = prefixed_pre_subparse,
|
||||
.post_blockstart = prefixed_post_blockstart,
|
||||
.pre_blockend = prefixed_pre_blockend,
|
||||
.post_newcv = prefixed_post_newcv,
|
||||
};
|
||||
|
||||
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
|
||||
|
||||
static int my_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op_ptr)
|
||||
{
|
||||
if(kwlen != 8 || !strEQ(kw, "prefixed"))
|
||||
return (*next_keyword_plugin)(aTHX_ kw, kwlen, op_ptr);
|
||||
|
||||
lex_read_space(0);
|
||||
|
||||
return xs_parse_sublike_any(&parse_prefixed_hooks, SvREFCNT_inc(get_sv("main::LOG", 0)),
|
||||
op_ptr);
|
||||
}
|
||||
|
||||
MODULE = t::any PACKAGE = t::any
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("func", &parse_func_hooks, SvREFCNT_inc(get_sv("main::LOG", GV_ADD)));
|
||||
|
||||
wrap_keyword_plugin(&my_keyword_plugin, &next_keyword_plugin);
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
static void no_body_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
if(ctx->body)
|
||||
croak("Expected no_body to have ctx->body == NULL");
|
||||
if(ctx->cv)
|
||||
croak("Expected no_body to have ctx->cv == NULL");
|
||||
|
||||
sv_setsv(get_sv("t::flags::captured_name", GV_ADD), ctx->name);
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_no_body_hooks = {
|
||||
.permit_hintkey = "t::flags/no_body",
|
||||
.flags = XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL,
|
||||
|
||||
.post_newcv = no_body_post_newcv,
|
||||
};
|
||||
|
||||
MODULE = t::flags PACKAGE = t::flags
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("no_body", &parse_no_body_hooks, NULL);
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
static const struct XSParseSublikeHooks parse_func_hooks = {
|
||||
/* empty */
|
||||
};
|
||||
|
||||
MODULE = t::func PACKAGE = t::func
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("func", &parse_func_hooks, NULL);
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
static bool parts_permit(pTHX_ void *_);
|
||||
|
||||
static struct XSParseSublikeHooks parse_parts_hooks = {
|
||||
.permit = parts_permit,
|
||||
};
|
||||
|
||||
static bool parts_permit(pTHX_ void *_)
|
||||
{
|
||||
parse_parts_hooks.require_parts = 0;
|
||||
parse_parts_hooks.skip_parts = 0;
|
||||
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::parts/require-name", 0))
|
||||
parse_parts_hooks.require_parts |= XS_PARSE_SUBLIKE_PART_NAME;
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::parts/skip-name", 0))
|
||||
parse_parts_hooks.skip_parts |= XS_PARSE_SUBLIKE_PART_NAME;
|
||||
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::parts/skip-attrs", 0))
|
||||
parse_parts_hooks.skip_parts |= XS_PARSE_SUBLIKE_PART_ATTRS;
|
||||
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::parts/skip-signature", 0))
|
||||
parse_parts_hooks.skip_parts |= XS_PARSE_SUBLIKE_PART_SIGNATURE;
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
MODULE = t::parts PACKAGE = t::parts
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("parts", &parse_parts_hooks, NULL);
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
static void func_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Sf");
|
||||
}
|
||||
|
||||
static void func_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Ef");
|
||||
}
|
||||
|
||||
static void func_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Lf");
|
||||
}
|
||||
|
||||
static void func_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Nf");
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_func_hooks = {
|
||||
.pre_subparse = func_pre_subparse,
|
||||
.post_blockstart = func_post_blockstart,
|
||||
.pre_blockend = func_pre_blockend,
|
||||
.post_newcv = func_post_newcv,
|
||||
};
|
||||
|
||||
static void prefixed_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Sp");
|
||||
}
|
||||
|
||||
static void prefixed_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Ep");
|
||||
}
|
||||
|
||||
static void prefixed_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Lp");
|
||||
}
|
||||
|
||||
static void prefixed_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_logsv)
|
||||
{
|
||||
SV *logsv = _logsv;
|
||||
sv_catpvs(logsv, "Np");
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_prefixed_hooks = {
|
||||
.flags = XS_PARSE_SUBLIKE_FLAG_PREFIX,
|
||||
|
||||
.pre_subparse = prefixed_pre_subparse,
|
||||
.post_blockstart = prefixed_post_blockstart,
|
||||
.pre_blockend = prefixed_pre_blockend,
|
||||
.post_newcv = prefixed_post_newcv,
|
||||
};
|
||||
|
||||
MODULE = t::prefix PACKAGE = t::prefix
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("func", &parse_func_hooks, SvREFCNT_inc(get_sv("main::LOG", GV_ADD)));
|
||||
register_xs_parse_sublike("prefixed", &parse_prefixed_hooks, SvREFCNT_inc(get_sv("main::LOG", GV_ADD)));
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
static void red_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
/* Throw away the entire function body; replace it with a constant */
|
||||
op_free(ctx->body);
|
||||
ctx->body = newSVOP(OP_CONST, 0, newSVpv("red", 0));
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_red_hooks = {
|
||||
.permit_hintkey = "t::registrations/red",
|
||||
.pre_blockend = red_pre_blockend,
|
||||
};
|
||||
|
||||
static void blue_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
/* Throw away the entire function body; replace it with a constant */
|
||||
op_free(ctx->body);
|
||||
ctx->body = newSVOP(OP_CONST, 0, newSVpv("blue", 0));
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_blue_hooks = {
|
||||
.permit_hintkey = "t::registrations/blue",
|
||||
.pre_blockend = blue_pre_blockend,
|
||||
};
|
||||
|
||||
MODULE = t::registrations PACKAGE = t::registrations
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("func", &parse_red_hooks, NULL);
|
||||
register_xs_parse_sublike("func", &parse_blue_hooks, NULL);
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
/* You may distribute under the terms of either the GNU General Public License
|
||||
* or the Artistic License (the same terms as Perl itself)
|
||||
*
|
||||
* (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "XSParseSublike.h"
|
||||
|
||||
#include "sv_setrv.c.inc"
|
||||
|
||||
static bool stage_permit(pTHX_ void *_)
|
||||
{
|
||||
if(!hv_fetchs(GvHV(PL_hintgv), "t::stages/permit", 0))
|
||||
return FALSE;
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
static void stage_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::stages/pre_subparse-capture", 0)) {
|
||||
sv_setsv(get_sv("t::stages::captured", GV_ADD), get_sv("main::VAR", 0));
|
||||
}
|
||||
}
|
||||
|
||||
static void stage_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::stages/post_blockstart-capture", 0)) {
|
||||
sv_setsv(get_sv("t::stages::captured", GV_ADD), get_sv("main::VAR", 0));
|
||||
}
|
||||
}
|
||||
|
||||
static void stage_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::stages/pre_blockend-capture", 0)) {
|
||||
sv_setsv(get_sv("t::stages::captured", GV_ADD), get_sv("main::VAR", 0));
|
||||
}
|
||||
}
|
||||
|
||||
static void stage_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_)
|
||||
{
|
||||
if(hv_fetchs(GvHV(PL_hintgv), "t::stages/post_newcv-capture-cv", 0)) {
|
||||
sv_setrv_inc(get_sv("t::stages::captured", GV_ADD), (SV *)ctx->cv);
|
||||
}
|
||||
}
|
||||
|
||||
static bool stage_filter_attr(pTHX_ struct XSParseSublikeContext *ctx, SV *attr, SV *value, void *_)
|
||||
{
|
||||
if(!hv_fetchs(GvHV(PL_hintgv), "t::stages/filter_attr-capture", 0))
|
||||
return FALSE;
|
||||
|
||||
AV *av = newAV();
|
||||
av_push(av, SvREFCNT_inc(attr));
|
||||
av_push(av, SvREFCNT_inc(value));
|
||||
|
||||
sv_setrv_noinc(get_sv("t::stages::captured", GV_ADD), (SV *)av);
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
static const struct XSParseSublikeHooks parse_stages_hooks = {
|
||||
.flags = XS_PARSE_SUBLIKE_FLAG_FILTERATTRS,
|
||||
.permit = stage_permit,
|
||||
.pre_subparse = stage_pre_subparse,
|
||||
.post_blockstart = stage_post_blockstart,
|
||||
.pre_blockend = stage_pre_blockend,
|
||||
.post_newcv = stage_post_newcv,
|
||||
|
||||
.filter_attr = stage_filter_attr,
|
||||
};
|
||||
|
||||
MODULE = t::stages PACKAGE = t::stages
|
||||
|
||||
BOOT:
|
||||
boot_xs_parse_sublike(0);
|
||||
|
||||
register_xs_parse_sublike("stages", &parse_stages_hooks, NULL);
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
package testcase;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib "t/blib", "t/blib/arch";
|
||||
|
||||
use XS::Parse::Sublike;
|
||||
|
||||
sub import
|
||||
{
|
||||
shift;
|
||||
require XSLoader;
|
||||
XSLoader::load( $_[0], $XS::Parse::Sublike::VERSION );
|
||||
}
|
||||
|
||||
0x55AA;
|
||||
Loading…
Reference in New Issue