commit 50b956e507afb7bec14c8f0e3e87dded47dfc934 Author: zhangyichun Date: Fri Sep 30 15:36:19 2022 +0800 Import Upstream version 0.16 diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..265d8da --- /dev/null +++ b/Build.PL @@ -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; diff --git a/Changes b/Changes new file mode 100644 index 0000000..785727c --- /dev/null +++ b/Changes @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f15476d --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 2021 by Paul Evans . + +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 . + +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. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2021 by Paul Evans . + +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 + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1622bf9 --- /dev/null +++ b/MANIFEST @@ -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 diff --git a/META.json b/META.json new file mode 100644 index 0000000..c15b573 --- /dev/null +++ b/META.json @@ -0,0 +1,58 @@ +{ + "abstract" : "XS functions to assist in parsing C-like syntax", + "author" : [ + "Paul Evans " + ], + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7ec4e7b --- /dev/null +++ b/META.yml @@ -0,0 +1,31 @@ +--- +abstract: 'XS functions to assist in parsing C-like syntax' +author: + - 'Paul Evans ' +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' diff --git a/README b/README new file mode 100644 index 0000000..a58fe9d --- /dev/null +++ b/README @@ -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 + diff --git a/XSParseSublike.h b/XSParseSublike.h new file mode 100644 index 0000000..c0a266e --- /dev/null +++ b/XSParseSublike.h @@ -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 diff --git a/hax/COP_SEQ_RANGE_HIGH_set.c.inc b/hax/COP_SEQ_RANGE_HIGH_set.c.inc new file mode 100644 index 0000000..d41f052 --- /dev/null +++ b/hax/COP_SEQ_RANGE_HIGH_set.c.inc @@ -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 diff --git a/hax/block_end.c.inc b/hax/block_end.c.inc new file mode 100644 index 0000000..d34cfdd --- /dev/null +++ b/hax/block_end.c.inc @@ -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 diff --git a/hax/block_start.c.inc b/hax/block_start.c.inc new file mode 100644 index 0000000..e0fa39a --- /dev/null +++ b/hax/block_start.c.inc @@ -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 diff --git a/hax/lexer-additions.c.inc b/hax/lexer-additions.c.inc new file mode 100644 index 0000000..0aa0d60 --- /dev/null +++ b/hax/lexer-additions.c.inc @@ -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); +} diff --git a/hax/make_argcheck_aux.c.inc b/hax/make_argcheck_aux.c.inc new file mode 100644 index 0000000..4ac257a --- /dev/null +++ b/hax/make_argcheck_aux.c.inc @@ -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 diff --git a/hax/pad_block_start.c.inc b/hax/pad_block_start.c.inc new file mode 100644 index 0000000..0914c46 --- /dev/null +++ b/hax/pad_block_start.c.inc @@ -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 diff --git a/hax/pad_leavemy.c.inc b/hax/pad_leavemy.c.inc new file mode 100644 index 0000000..31564ac --- /dev/null +++ b/hax/pad_leavemy.c.inc @@ -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 diff --git a/hax/parse_subsignature.c.inc b/hax/parse_subsignature.c.inc new file mode 100644 index 0000000..f6570e0 --- /dev/null +++ b/hax/parse_subsignature.c.inc @@ -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 diff --git a/hax/scalarseq.c.inc b/hax/scalarseq.c.inc new file mode 100644 index 0000000..7bce64d --- /dev/null +++ b/hax/scalarseq.c.inc @@ -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 diff --git a/hax/sv_setrv.c.inc b/hax/sv_setrv.c.inc new file mode 100644 index 0000000..15ddf26 --- /dev/null +++ b/hax/sv_setrv.c.inc @@ -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); +} diff --git a/hax/wrap_keyword_plugin.c.inc b/hax/wrap_keyword_plugin.c.inc new file mode 100644 index 0000000..25dc214 --- /dev/null +++ b/hax/wrap_keyword_plugin.c.inc @@ -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; +} diff --git a/inc/Module/Build/with/XSTests.pm b/inc/Module/Build/with/XSTests.pm new file mode 100644 index 0000000..da57607 --- /dev/null +++ b/inc/Module/Build/with/XSTests.pm @@ -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; diff --git a/lib/XS/Parse/Sublike.pm b/lib/XS/Parse/Sublike.pm new file mode 100644 index 0000000..1c8a32c --- /dev/null +++ b/lib/XS/Parse/Sublike.pm @@ -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 functions to assist in parsing C-like syntax + +=head1 DESCRIPTION + +This module provides some XS functions to assist in writing parsers for +C-like syntax, primarily for authors of keyword plugins using the +C 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 section in order to initialise the module +and parsing hooks. + +I 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-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), and code body. The +return value and C 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. + +I should be a structure that can provide optional function pointers +used to customise the parsing process at various stages. I 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 itself. + +When the keyword is encountered, the hook's C 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. + +I 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 or the name of another C-like keyword, which has +been previously registered using L. 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 is encountered, then this is parsed using the I in +a similar way to C. + +If a different registered C-like keyword is encountered, then parsing is +performed using B 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 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 which runs them inside-out. + +I 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 flag. + +=head1 PARSE CONTEXT + +The various hook stages all share state about the ongoing parse process using +various fields of the C structure. + + struct XSParseSublikeContext { + SV *name; + OP *attrs; + OP *body; + CV *cv; + U32 actions; + HV *moddata; + } + +The C field will contain a bitmask of action flags that control the +various steps that C 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 bit of the C field in +order to make use of the I field. A future ABI version may remove +this restriction. + +=over 4 + +=item XS_PARSE_SUBLIKE_ACTION_CVf_ANON + +If set, the C 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 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. 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 / C optree +fragment typical of anonymous code expressions; if not it will be C. +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 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 structure provides the following hook stages, which +are invoked in the given order. + +The structure has a I 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 stage will be invoked. + +=item XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL + +If B set, the I field will imply the +C 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 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 fields named I and +I which control the behaviour of various parts of the syntax which +are usually optional. Any parts with bits set in I become +non-optional, and an error if they are missing. Any parts with bits set in +I will skip the relevant part of the parsing process. + +When multiple sets of hooks are combined by the C +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. 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. It +is always permitted not to provide a signature for a function definition, +because such syntax only applies when C 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 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 and C fields of the context structure will +remain C. + +This flag is currently implied on the I field if the hook does +not supply the C flag; meaning that most +use-cases will make it a required part. + +=back + +=head2 The C 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. + +As a shortcut for the common case, the C 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 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 field +of the context. + +=head2 The C Stage + + void (*pre_subparse)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) + +Invoked just before C is called. + +=head2 Parse Attrs + +At this point the optional sub attributes are parsed and filled into the +C field of the context, then C is called. + +=head2 The optional C Stage + + bool (*filter_attr)(pTHX_ struct XSParseSublikeContext *ctx, + SV *attr, SV *val, void *hookdata); + +If the I field includes C then each +individual attribute is passed through this optional filter function +immediately as each is parsed. I will be a string SV containing the name +of the attribute, and I will either be C, or a string SV containing +the contents of the parens after its name (without the parens themselves). + +If the filter returns C, it indicates that it has in some way handled +the attribute and it should not be added to the list given to C. +If the filter returns C it will be handled in the usual way; equivalent +to the case where the filter function did not exist. + +=head2 The C Stage + + void (*post_blockstart)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) + +Invoked after the C function has been called. This hook stage +may wish to perform any alterations of C 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 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 Stage + + void (*pre_blockend)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) + +Invoked just before the C function is invoked. The hook stage may +wish to inspect or alter the optree stored in the C context field. + +=head2 The C Stage + + void (*post_newcv)(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) + +Invoked just after C has been invoked on the optree. The hook +stage may wish to inspect or alter the CV stored in the C context field. + +=cut + +=head1 AUTHOR + +Paul Evans + +=cut + +0x55AA; diff --git a/lib/XS/Parse/Sublike.xs b/lib/XS/Parse/Sublike.xs new file mode 100644 index 0000000..075d3d9 --- /dev/null +++ b/lib/XS/Parse/Sublike.xs @@ -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); diff --git a/lib/XS/Parse/Sublike/Builder.pm b/lib/XS/Parse/Sublike/Builder.pm new file mode 100644 index 0000000..b0e7036 --- /dev/null +++ b/lib/XS/Parse/Sublike/Builder.pm @@ -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 - build-time support for C + +=head1 SYNOPSIS + +In F: + + 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. It prepares a L-using +distribution to be able to make use of C. + +=cut + +require XS::Parse::Sublike::Builder_data; + +=head1 FUNCTIONS + +=cut + +=head2 write_XSParseSublike_h + + XS::Parse::Sublike::Builder->write_XSParseSublike_h + +Writes the F file to the current working directory. To cause +the compiler to actually find this file, see L. + +=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 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-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 + +=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 diff --git a/lib/XS/Parse/Sublike/Builder_data.pm.PL b/lib/XS/Parse/Sublike/Builder_data.pm.PL new file mode 100644 index 0000000..042164e --- /dev/null +++ b/lib/XS/Parse/Sublike/Builder_data.pm.PL @@ -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 { } ); + +$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__ diff --git a/t/00use.t b/t/00use.t new file mode 100644 index 0000000..6d9b5e9 --- /dev/null +++ b/t/00use.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use_ok( "XS::Parse::Sublike" ); + +done_testing; diff --git a/t/01func.t b/t/01func.t new file mode 100644 index 0000000..2699683 --- /dev/null +++ b/t/01func.t @@ -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; diff --git a/t/02func-signatures.t b/t/02func-signatures.t new file mode 100644 index 0000000..17fa70f --- /dev/null +++ b/t/02func-signatures.t @@ -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; diff --git a/t/03func-deparse.t b/t/03func-deparse.t new file mode 100644 index 0000000..58a9318 --- /dev/null +++ b/t/03func-deparse.t @@ -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; diff --git a/t/10stages-permit.t b/t/10stages-permit.t new file mode 100644 index 0000000..240098d --- /dev/null +++ b/t/10stages-permit.t @@ -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; diff --git a/t/11stages-pre_subparse.t b/t/11stages-pre_subparse.t new file mode 100644 index 0000000..fe1a507 --- /dev/null +++ b/t/11stages-pre_subparse.t @@ -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; diff --git a/t/12stages-post_blockstart.t b/t/12stages-post_blockstart.t new file mode 100644 index 0000000..aff4653 --- /dev/null +++ b/t/12stages-post_blockstart.t @@ -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; diff --git a/t/13stages-pre_blockend.t b/t/13stages-pre_blockend.t new file mode 100644 index 0000000..d8bef1e --- /dev/null +++ b/t/13stages-pre_blockend.t @@ -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; diff --git a/t/14stages-post_newcv.t b/t/14stages-post_newcv.t new file mode 100644 index 0000000..8b9253c --- /dev/null +++ b/t/14stages-post_newcv.t @@ -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; diff --git a/t/15stages-filter_attr.t b/t/15stages-filter_attr.t new file mode 100644 index 0000000..3de3c20 --- /dev/null +++ b/t/15stages-filter_attr.t @@ -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; diff --git a/t/20registrations.t b/t/20registrations.t new file mode 100644 index 0000000..5bd0bd9 --- /dev/null +++ b/t/20registrations.t @@ -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; diff --git a/t/30any.t b/t/30any.t new file mode 100644 index 0000000..aee03d7 --- /dev/null +++ b/t/30any.t @@ -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; diff --git a/t/31prefix.t b/t/31prefix.t new file mode 100644 index 0000000..c595785 --- /dev/null +++ b/t/31prefix.t @@ -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; diff --git a/t/40parts-name.t b/t/40parts-name.t new file mode 100644 index 0000000..e195355 --- /dev/null +++ b/t/40parts-name.t @@ -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; diff --git a/t/41parts-attrs.t b/t/41parts-attrs.t new file mode 100644 index 0000000..095d2f5 --- /dev/null +++ b/t/41parts-attrs.t @@ -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; diff --git a/t/42parts-signature.t b/t/42parts-signature.t new file mode 100644 index 0000000..8a995c0 --- /dev/null +++ b/t/42parts-signature.t @@ -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; diff --git a/t/50flags-no-body.t b/t/50flags-no-body.t new file mode 100644 index 0000000..ea4b070 --- /dev/null +++ b/t/50flags-no-body.t @@ -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; diff --git a/t/60actions.t b/t/60actions.t new file mode 100644 index 0000000..536cc01 --- /dev/null +++ b/t/60actions.t @@ -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; diff --git a/t/99pod.t b/t/99pod.t new file mode 100644 index 0000000..d1972ce --- /dev/null +++ b/t/99pod.t @@ -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(); diff --git a/t/actions.xs b/t/actions.xs new file mode 100644 index 0000000..59172de --- /dev/null +++ b/t/actions.xs @@ -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); diff --git a/t/any.xs b/t/any.xs new file mode 100644 index 0000000..485c06c --- /dev/null +++ b/t/any.xs @@ -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); diff --git a/t/flags.xs b/t/flags.xs new file mode 100644 index 0000000..c4f135b --- /dev/null +++ b/t/flags.xs @@ -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); diff --git a/t/func.xs b/t/func.xs new file mode 100644 index 0000000..4168572 --- /dev/null +++ b/t/func.xs @@ -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); diff --git a/t/parts.xs b/t/parts.xs new file mode 100644 index 0000000..c080564 --- /dev/null +++ b/t/parts.xs @@ -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); diff --git a/t/prefix.xs b/t/prefix.xs new file mode 100644 index 0000000..1b44599 --- /dev/null +++ b/t/prefix.xs @@ -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))); diff --git a/t/registrations.xs b/t/registrations.xs new file mode 100644 index 0000000..fd02124 --- /dev/null +++ b/t/registrations.xs @@ -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); diff --git a/t/stages.xs b/t/stages.xs new file mode 100644 index 0000000..73fbea5 --- /dev/null +++ b/t/stages.xs @@ -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); diff --git a/t/testcase.pm b/t/testcase.pm new file mode 100644 index 0000000..dff8351 --- /dev/null +++ b/t/testcase.pm @@ -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;