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