XS-Parse-Keyword-0.21000755001750001750 014131246633 13204 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/Build.PL000444001750001750 421114131246632 14632 0ustar00leoleo000000000000use strict; use warnings; use lib 'inc'; use ExtUtils::CChecker 0.11; use Module::Build::with::XSTests; my $MIN_PERL = '5.014'; # PL_keyword_plugin # MSWin32 needs at least perl 5.22 # https://rt.cpan.org/Ticket/Display.html?id=136577 $MIN_PERL = '5.022' if $^O eq "MSWin32"; my $cc = ExtUtils::CChecker->new( quiet => 1 ); $cc->try_find_cflags_for( cflags => [ # Most systems will need no extra cflags [], # HPUX may need to be told +std=gnu in order to accept anon inner unions ( $^O eq "hpux" ) ? [ "+std=gnu" ] : (), ], source => <<'EOF' struct Named { union { int a, b; }; int c; }; int main(void) { struct Named n; n.a = 0; return n.a; } EOF ) or die "OS unsupported - C compiler does not support anonymous inner unions\n"; { print "Checking for PL_infix_plugin...\n"; my $have_pl_infix_plugin = 0; # No released version of perl (yet) has PL_infix_plugin. This commandline # argument allows it to build if patched correctly. $have_pl_infix_plugin = 1 if grep { $_ eq "--have-pl_infix_plugin" } @ARGV; $have_pl_infix_plugin ||= $cc->try_compile_run( source => <<'EOF' #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(void) { struct Perl_custom_infix def; return 0; } EOF ) if $] >= 5.035005; if( $have_pl_infix_plugin ) { print "Including support for core perl PL_infix_plugin\n"; # ->define isn't currently documented but it will be in next version; it # has been present since v0.04, basically forever $cc->define( "HAVE_PL_INFIX_PLUGIN" ) } } my $build = Module::Build::with::XSTests->new( module_name => 'XS::Parse::Keyword', requires => { 'perl' => $MIN_PERL, }, test_requires => { 'Test::More' => '0.88', # done_testing }, configure_requires => { 'ExtUtils::CChecker' => '0.11', 'Module::Build' => '0.4004', # test_requires }, license => 'perl', create_license => 1, create_readme => 1, extra_compiler_flags => [qw( -I. -Ihax )], c_source => [ "src/" ], ); $cc->extend_module_build( $build ); $build->notes( builder_cflags => $cc->extra_compiler_flags ); $build->create_build_script; XS-Parse-Keyword-0.21/Changes000444001750001750 1236014131246632 14655 0ustar00leoleo000000000000Revision history for XS-Parse-Keyword 0.20 2021-10-11 [BUGFIXES] * Fix for perl 5.20 - cannot use assert() as an expression 0.19 2021-10-05 [CHANGES] * Defined XPK_PREFIXED_BLOCK_ENTERLEAVE and XPK_SETUP for customizing the parser context around blocks 0.18 2021-09-28 [CHANGES] * Define the XPI_OPERAND_ONLY_LOOK flag * Define a callchecker for list/list infix operators. Add a callchecker that can optimise out certain kinds of operations (ref to padav or pkgav, anonlist if XPI_OPERAND_ONLY_LOOK is set) [BUGFIXES] * cygwin requires deparse_infix to be declared with XS_INTERNAL() (RT139449) * Some architectures require intermediate storage for values in the test function pp_addpairs (RT139445) * Fix conditions in lexical variable type checking (RT139444) 0.17 2021-09-23 [CHANGES] * Support certain kinds of list operands on LHS of infix operators * Generate wrapper functions around list-list infix operators, which unpack their argument lists from two ARRAYrefs 0.16 2021-09-21 [CHANGES] * Attempt automatic deparsing of infix operators * Support certain kinds of list operands on RHS of infix operators 0.15 2021-09-06 [CHANGES] * Optional generation of wrapper functions around scalar-infix operators * Quieter Build.PL by skipping PL_infix_plugin check on versions of perl known to be too old it 0.14 2021-08-31 [CHANGES] * Added the entire XS::Parse::Infix subsystem * Added XPK_INFIX_* token types 0.13 2021-08-26 [CHANGES] * Bump to ABI version 2; pass build1's arg0 param as a pointer, not a direct struct copy [BUGFIXES] * Back-compat for ABI version 1's build1 arg0 param not having a line number (RT138708) 0.12 2021-08-16 [CHANGES] * Support probe on XPK_IDENT, XPK_PACKAGENAME, XPK_COMMALIST * Provide optional versions of XPK_IDENT and XPK_PACKAGENAME * Report the line number each piece was parsed from 0.11 2021-08-03 [BUGFIXES] * Split Builder.pm into two parts (static + dynamic), so the static part can be indexed as normal by usual CPAN toolchain (RT138313) 0.10 2021-07-13 [CHANGES] * Better configure-time probing for HPUX compiler support [BUGFIXES] * Fix for CHOICE/TAGGEDCHOICE corrupting the value of ->i in the result (RT136845) 0.09 2021-07-12 [CHANGES] * Attempt to support HPUX, which may need additional compiletime arguments to support anonymous inner unions * Better compiletime error messages by attempting to include some source context in the same style as yyerror() * Slight compiletime performance boost by setting PERL_NO_GET_CONTEXT [BUGFIXES] * Check for recursive parser errors and abort (RT137458) 0.08 2021-06-17 [CHANGES] * Support probe in XPK_CHOICE and XPK_TAGGEDCHOICE [BUGFIXES] * Remember to mask off the typeflags in probe_piece() 0.07 2021-06-16 [CHANGES] * Added XPK_BLOCK_VOIDCTX and XPK_TERMEXPR_VOIDCTX * Undocumented the _flags() variants of XPK_BLOCK and XPK_TERMEXPR, and all the flags for them * Support probing in XPK_BLOCK * (undocumented) trial to see if all supported platforms support anonymous unions 0.06 2021-06-01 [BREAKING CHANGES] * ABI version is now 1 - this will require a from-source rebuild of all modules using it. [CHANGES] * Renamed XPK_STRING to XPK_LITERAL * Support probe on the four bracketed scope types * Added _OPT-suffixed versions of the four bracketed scope types * Added more token types: + XPK_LEXVAR_MY + XPK_COMMA + XPK_PREFIXED_BLOCK + XPK_SEQUENCE 0.05 2021-05-31 [CHANGES] * Added context-setting variants of block/expr types: + XPK_BLOCK_SCALARCTX, XPK_BLOCK_LISTCTX + XPK_TERMEXPR_SCALARCTX + XPK_LISTEXPR_LISTCTX 0.04 2021-05-24 [CHANGES] * Added many more token types: XPK_LEXVARNAME, XPK_ATTRIBUTES, XPK_VSTRING, XPK_VSTRING_OPT, XPK_EQUALS * Added XPK_COMMALIST structure type * Defined hooks flags XPK_FLAG_STMT, XPK_FLAG_EXPR, XPK_FLAG_AUTOSEMI * API change to the way .build is invoked, allowing greater future compatibility for args structures 0.03 2021-04-27 [BUGFIXES] * Fix the `VAR never introduced at ...` warnings from uses of XPK_BLOCK * Make sure the Builder.pm file is mentioned in META.{yml,json} so CPAN tools can find it 0.02 2021-04-21 [CHANGES] * Back-compat to perl 5.14 * Avoid passing user strings directly to printf, by emitting XPK_FAILURE using croak("%s", str) * Various documentation wording improvements 0.01 2021-04-14 First version, released on an unsuspecting world. XS-Parse-Keyword-0.21/LICENSE000444001750001750 4376214131246632 14401 0ustar00leoleo000000000000This 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 XS-Parse-Keyword-0.21/MANIFEST000444001750001750 214714131246632 14475 0ustar00leoleo000000000000Build.PL Changes hax/force_list_keeping_pushmark.c.inc hax/lexer-additions.c.inc hax/make_argcheck_aux.c.inc hax/make_argcheck_ops.c.inc hax/newOP_CUSTOM.c.inc hax/op_sibling_splice.c.inc hax/perl-backcompat.c.inc hax/wrap_keyword_plugin.c.inc inc/Module/Build/with/XSTests.pm lib/XS/Parse/Infix.pm lib/XS/Parse/Infix/Builder.pm lib/XS/Parse/Infix/Builder_data.pm.PL lib/XS/Parse/Keyword.pm lib/XS/Parse/Keyword.xs lib/XS/Parse/Keyword/Builder.pm lib/XS/Parse/Keyword/Builder_data.pm.PL LICENSE MANIFEST This list of files META.json META.yml README src/infix.c src/infix.h src/keyword.c src/keyword.h t/00use.t t/10stages-permit.t t/11stages-check.t t/30pieces-literal.t t/31pieces-block.t t/32pieces-anonsub.t t/33pieces-listexpr.t t/33pieces-termexpr.t t/34pieces-ident.t t/35pieces-lexvar.t t/36pieces-attrs.t t/37pieces-vstring.t t/38pieces-infix.t t/40build.t t/41structures.t t/42scopes.t t/43probing.t t/50flags-autosemi.t t/60line.t t/70infix.t t/71infix-wrapper.t t/99pod.t t/build.xs t/flags.xs t/infix.xs t/line.xs t/pieces.xs t/probing.xs t/stages.xs t/structures.xs t/testcase.pm XSParseInfix.h XSParseKeyword.h XS-Parse-Keyword-0.21/META.json000444001750001750 302714131246632 14763 0ustar00leoleo000000000000{ "abstract" : "XS functions to assist in parsing keyword 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-Keyword", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "ExtUtils::CChecker" : "0.11", "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "perl" : "5.014" } }, "test" : { "requires" : { "Test::More" : "0.88" } } }, "provides" : { "XS::Parse::Infix" : { "file" : "lib/XS/Parse/Infix.pm", "version" : "0.21" }, "XS::Parse::Infix::Builder" : { "file" : "lib/XS/Parse/Infix/Builder.pm", "version" : "0.21" }, "XS::Parse::Keyword" : { "file" : "lib/XS/Parse/Keyword.pm", "version" : "0.21" }, "XS::Parse::Keyword::Builder" : { "file" : "lib/XS/Parse/Keyword/Builder.pm", "version" : "0.21" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.21", "x_serialization_backend" : "JSON::PP version 4.05" } XS-Parse-Keyword-0.21/META.yml000444001750001750 172014131246632 14611 0ustar00leoleo000000000000--- abstract: 'XS functions to assist in parsing keyword syntax' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test::More: '0.88' configure_requires: ExtUtils::CChecker: '0.11' 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-Keyword provides: XS::Parse::Infix: file: lib/XS/Parse/Infix.pm version: '0.21' XS::Parse::Infix::Builder: file: lib/XS/Parse/Infix/Builder.pm version: '0.21' XS::Parse::Keyword: file: lib/XS/Parse/Keyword.pm version: '0.21' XS::Parse::Keyword::Builder: file: lib/XS/Parse/Keyword/Builder.pm version: '0.21' requires: perl: '5.014' resources: license: http://dev.perl.org/licenses/ version: '0.21' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' XS-Parse-Keyword-0.21/README000444001750001750 4673714131246632 14261 0ustar00leoleo000000000000NAME XS::Parse::Keyword - XS functions to assist in parsing keyword syntax DESCRIPTION This module provides some XS functions to assist in writing syntax modules that provide new perl-visible 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_keyword void boot_xs_parse_keyword(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_keyword(0.14); register_xs_parse_keyword void register_xs_parse_keyword(const char *keyword, const struct XSParseKeywordHooks *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::Keyword itself. PARSE HOOKS The XSParseKeywordHooks structure provides the following hook stages, which are invoked in the given order. flags The following flags are defined: XPK_FLAG_EXPR The parse or build function is expected to return KEYWORD_PLUGIN_EXPR. XPK_FLAG_STMT The parse or build function is expected to return KEYWORD_PLUGIN_STMT. These two flags are largely for the benefit of giving static information at registration time to assist static parsing or other related tasks to know what kind of grammatical element this keyword will produce. XPK_FLAG_AUTOSEMI The syntax forms a complete statement, which should be followed by a statement separator semicolon (;). This semicolon is optional at the end of a block. The semicolon, if present, will be consumed automatically. 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_keyword". 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. The check Stage void (*check)(pTHX_ void *hookdata); Invoked once the keyword has been permitted. If present, this hook function can check the surrounding lexical context, state, or other information and throw an exception if it is unhappy that the keyword should apply in this position. The parse Stage This stage is invoked once the keyword has been checked, and actually parses the incoming text into an optree. It is implemented by calling the first of the following function pointers which is not NULL. The invoked function may optionally build an optree to represent the parsed syntax, and place it into the variable addressed by out. If it does not, then a simple OP_NULL will be constructed in its place. lex_read_space() is called both before and after this stage is invoked, so in many simple cases the hook function itself does not need to bother with it. int (*parse)(pTHX_ OP **out, void *hookdata); If present, this should consume text from the parser buffer by invoking lex_* or parse_* functions and eventually return a KEYWORD_PLUGIN_* result value. This is the most generic and powerful of the options, but requires the most amount of implementation work. int (*build)(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata); If parse is not present, this is called instead after parsing a sequence of arguments, of types given by the pieces field; which should be a zero- terminated array of piece types. This alternative is somewhat less generic and powerful than providing parse yourself, but involves much less parsing work and is shorter and easier to implement. int (*build1)(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata); If neither parse nor build are present, this is called as a simpler variant of build when only a single argument is required. It takes its type from the piece1 field instead. PIECES AND PIECE TYPES When using the build or build1 alternatives for the parse phase, the actual syntax is parsed automatically by this module, according to the specification given by the pieces or piece1 field. The result of that parsing step is placed into the args or arg0 parameter to the invoked function, using a struct type consisting of the following fields: typedef struct union { OP *op; CV *cv; SV *sv; int i; struct { SV *name; SV *value; } attr; PADOFFSET padix; struct XSParseInfixInfo *infix; }; int line; } XSParseKeywordPiece; Which field of the anonymous union is set depends on the type of the piece. The line field contains the line number of the source file where parsing of that piece began. Some piece types are "atomic", whose definition is self-contained. Others are structural, defined in terms of inner pieces. Together these form an entire tree-shaped definition of the syntax that the keyword expects to find. Atomic types generally provide exactly one argument into the list of args (with the exception of literal matches, which do not provide anything). Structural types may provide an initial argument themselves, followed by a list of the values of each sub-piece they contained inside them. Thus, while the data structure defining the syntax shape is a tree, the argument values it parses into is passed as a flat array to the build function. Some structural types need to be able to determine whether or not syntax relating some optional part of them is present in the incoming source text. In this case, the pieces relating to those optional parts must support "probing". This ability is also noted below. The type of each piece should be one of the following macro values. XPK_BLOCK atomic, can probe, emits op. XPK_BLOCK A brace-delimited block of code is expected, passed as an optree in the op field. This will be parsed as a block within the current function scope. This can be probed by checking for the presence of an open-brace ({) character. Be careful defining grammars with this because an open-brace is also a valid character to start a term expression, for example. Given a choice between XPK_BLOCK and XPK_TERMEXPR, either of them could try to consume such code as { 123, 456 } XPK_BLOCK_VOIDCTX, XPK_BLOCK_SCALARCTX, XPK_BLOCK_LISTCTX Variants of XPK_BLOCK which wrap a void, scalar or list-context scope around the block. XPK_PREFIXED_BLOCK structural, emits op. XPK_PREFIXED_BLOCK(pieces ...) Some pieces are expected, followed by a brace-delimited block of code, which is passed as an optree in the op field. The prefix pieces are parsed first, and their results are passed before the block itself. The entire sequence, including the prefix items, is contained within a pair of block_start() / block_end() calls. This permits the prefix pieces to introduce new items into the lexical scope of the block - for example by the use of XPK_LEXVAR_MY. A call to intro_my() is automatically made at the end of the prefix pieces, before the block itself is parsed, ensuring any new lexical variables are now visible. In addition, the following extra piece types are recognised here: XPK_SETUP void setup(pTHX_ void *hookdata); XPK_SETUP(&setup) atomic, emits nothing. This piece type runs a function given by pointer. Typically this function may be used to introduce new lexical state into the parser, or in some other way have some side-effect on the parsing context of the block to be parsed. XPK_PREFIXED_BLOCK_ENTERLEAVE A variant of XPK_PREFIXED_BLOCK which additionally wraps the entire parsing operation, including the block_start(), block_end() and any calls to XPK_SETUP functions, within a ENTER/LEAVE pair. This should not make a difference to the standard parser pieces provided here, but may be useful behaviour for the code in the setup function, especially if it wishes to modify parser state and use the savestack to ensure it is restored again when parsing has finished. XPK_ANONSUB atomic, emits op. A brace-delimited block of code is expected, and assembled into the body of a new anonymous subroutine. This will be passed as a protosub CV in the cv field. XPK_TERMEXPR atomic, emits op. XPK_TERMEXPR A term expression is expected, parsed using parse_termexpr(), and passed as an optree in the op field. XPK_TERMEXPR_VOIDCTX, XPK_TERMEXPR_SCALARCTX Variants of XPK_TERMEXPR which puts the expression in void or scalar context. XPK_LISTEXPR atomic, emits op. XPK_LISTEXPR A list expression is expected, parsed using parse_listexpr(), and passed as an optree in the op field. XPK_LISTEXPR_LISTCTX Variant of XPK_LISTEXPR which puts the expression in list context. XPK_IDENT, XPK_IDENT_OPT atomic, can probe, emits sv. A bareword identifier name is expected, and passed as an SV containing a PV in the sv field. An identifier is not permitted to contain a double colon (::). The _OPT-suffixed version is optional; if no identifier is found then sv is set to NULL. XPK_PACKAGENAME, XPK_PACKAGENAME_OPT atomic, can probe, emits sv. A bareword package name is expected, and passed as an SV containing a PV in the sv field. A package name is similar to an identifier, except it permits double colons in the middle. The _OPT-suffixed version is optional; if no package name is found then sv is set to NULL. XPK_LEXVARNAME atomic, emits sv. XPK_LEXVARNAME(kind) A lexical variable name is expected, and passed as an SV containing a PV in the sv field. The kind argument specifies what kinds of variable are permitted, and should be a bitmask of one or more bits from XPK_LEXVAR_SCALAR, XPK_LEXVAR_ARRAY and XPK_LEXVAR_HASH. A convenient shortcut XPK_LEXVAR_ANY permits all three. XPK_ATTRIBUTES atomic, emits i followed by more args. A list of :-prefixed attributes is expected, in the same format as sub or variable attributes. An optional leading : indicates the presence of attributes, then one or more of them are parsed. Attributes may be optionally separated by additional :s, but this is not required. Each attribute is expected to be an identifier name, followed by an optional value wrapped in parentheses. Whitespace is NOT permitted between the name and value, as per standard Perl parsing rules. :attrname :attrname(value) The i field indicates how many attributes were found. That number of additional arguments are then passed, each containing two SVs in the attr.name and attr.value fields. This number may be zero. It is not an error for there to be no attributes present, or for the optional colon to be missing. In this case i will be set to zero. XPK_VSTRING, XPK_VSTRING_OPT atomic, can probe, emits sv. A version string is expected, of the form v1.234 including the leading v character. It is passed as a version SV object in the sv field. The _OPT-suffixed version is optional; if no version string is found then sv is set to NULL. XPK_LEXVAR_MY atomic, emits padix. XPK_LEXVAR_MY(kind) A lexical variable name is expected, added to the current pad as if specified in a my expression, and passed as the pad index in the padix field. The kind argument specifies what kinds of variable are permitted, as per XPK_LEXVARNAME. XPK_COMMA, XPK_COLON, XPK_EQUALS atomic, can probe, emits nothing. A literal character (,, : or =) is expected. No argument value is passed. XPK_INFIX_* atomic, can probe, emits infix. An infix operator as recognised by XS::Parse::Infix. The returned pointer points to a structure allocated by XS::Parse::Infix describing the operator. Various versions of the macro are provided, each using a different selection filter to choose certain available infix operators: XPK_INFIX_RELATION # any relational operator XPK_INFIX_EQUALITY # an equality operator like `==` or `eq` XPK_INFIX_MATCH_NOSMART # any sort of "match"-like operator, except smartmatch XPK_INFIX_MATCH_SMART # XPK_INFIX_MATCH_NOSMART plus smartmatch XPK_LITERAL atomic, can probe, emits nothing. XPK_LITERAL("literal") A literal string match is expected. No argument value is passed. This form should generally be avoided if at all possible, because it is very easy to abuse to make syntaxes which confuse humans and code tools alike. Generally it is best reserved just for the first component of a XPK_OPTIONAL or XPK_REPEATED sequence, to provide a "secondary keyword" that such a repeated item can look out for. This was previously called XPK_STRING, and is provided as a synonym for back-compatibility but new code should use this new name instead. XPK_SEQUENCE structural, might support probe, emits nothing. XPK_SEQUENCE(pieces ...) A structural type which contains a number of pieces. This is normally equivalent to simply placing the pieces in sequence inside their own container, but it is useful inside XPK_CHOICE or XPK_TAGGEDCHOICE. An XPK_SEQUENCE supports probe if its first contained piece does; i.e. is transparent to probing. XPK_OPTIONAL structural, emits i. XPK_OPTIONAL(pieces ...) A structural type which may expects to find its contained pieces, or is happy not to. This will pass an argument whose i field contains either 1 or 0, depending whether the contents were found. The first piece type within must support probe. XPK_REPEATED structural, emits i. XPK_REPEATED(pieces ...) A structural type which expects to find zero or more repeats of its contained pieces. This will pass an argument whose i field contains the count of the number of repeats it found. The first piece type within must support probe. XPK_CHOICE structural, can probe, emits i. XPK_CHOICE(options ...) A structural type which expects to find one of a number of alternative options. An ordered list of types is provided, all of which must support probe. This will pass an argument whose i field gives the index of the first choice that was accepted. The first option takes the value 0. As each of the options is interpreted as an alternative, not a sequence, you should use XPK_SEQUENCE if a sequence of multiple items should be considered as a single alternative. It is not an error if no choice matches. At that point, the i field will be set to -1. If you require a failure message in this case, set the final choice to be of type XPK_FAILURE. This will cause an error message to be printed instead. XPK_FAILURE("message string") XPK_TAGGEDCHOICE structural, can probe, emits i. XPK_TAGGEDCHOICE(choice, tag, ...) A structural type similar to XPK_CHOICE, except that each choice type is followed by an element of type XPK_TAG which gives an integer. It is that integer value, rather than the positional index of the choice within the list, which is passed in the i field. XPK_TAG(value) As each of the options is interpreted as an alternative, not a sequence, you should use XPK_SEQUENCE if a sequence of multiple items should be considered as a single alternative. XPK_COMMALIST structural, might support probe, emits i. XPK_COMMALIST(pieces ...) A structural type which expects to find one or more repeats of its contained pieces, separated by literal comma (,) characters. This is somewhat similar to XPK_REPEATED, except that it needs at least one copy, needs commas between its items, but does not require that the first contained piece support probe (the comma itself is sufficient to indicate a repeat). An XPK_COMMALIST supports probe if its first contained piece does; i.e. is transparent to probing. XPK_PARENSCOPE structural, can probe, emits nothing. XPK_PARENSCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in parentheses as ( ... ). This will pass no extra arguments. XPK_BRACKETSCOPE structural, can probe, emits nothing. XPK_BRACKETSCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in square brackets as [ ... ]. This will pass no extra arguments. XPK_BRACESCOPE structural, can probe, emits nothing. XPK_BRACESCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in braces as { ... }. This will pass no extra arguments. Note that this is not necessary to use with XPK_BLOCK or XPK_ANONSUB; those will already consume a set of braces. This is intended for special constrained syntax that should not just accept an arbitrary block. XPK_CHEVRONSCOPE structural, can probe, emits nothing. XPK_CHEVRONSCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in angle brackets as < ... >. This will pass no extra arguments. Remember that expressions like a > b are valid term expressions, so the contents of this scope shouldn't allow arbitrary expressions or the closing bracket will be ambiguous. XPK_PARENSCOPE_OPT, XPK_BRACKETSCOPE_OPT, XPK_BRACESCOPE_OPT, XPK_CHEVRONSCOPE_OPT structural, can probe, emits i. XPK_PARENSCOPE_OPT(pieces ...) XPK_BRACKETSCOPE_OPT(pieces ...) XPK_BRACESCOPE_OPT(pieces ...) XPK_CHEVERONSCOPE_OPT(pieces ...) Each of the four XPK_...SCOPE macros above has an optional variant, whose name is suffixed by _OPT. These pass an argument whose i field is either true or false, indicating whether the scope was found, followed by the values from the scope itself. This is a convenient shortcut to nesting the scope within a XPK_OPTIONAL macro. AUTHOR Paul Evans XS-Parse-Keyword-0.21/XSParseInfix.h000444001750001750 1075114131246632 16060 0ustar00leoleo000000000000#ifndef __XS_PARSE_INFIX_H__ #define __XS_PARSE_INFIX_H__ #define XSPARSEINFIX_ABI_VERSION 1 /* Infix operator classifications */ /* No built-in operators use the _MISC categories, but they are provided for * custom infix operators to use so they are still found by selections */ enum XSParseInfixClassification { XPI_CLS_NONE = 0, XPI_CLS_PREDICATE, /* any boolean-returning operator */ XPI_CLS_RELATION, /* ... any predicate that is typewise symmetric */ XPI_CLS_EQUALITY, /* ... any relation that is true for (x == x) and false otherwise */ XPI_CLS_SMARTMATCH, /* ... the predicate smartmatch (~~) */ XPI_CLS_MATCHRE, /* ... the predicate regexp match (=~) */ XPI_CLS_ISA, /* ... the predicate instance of (isa) */ XPI_CLS_MATCH_MISC, /* ... any other match-like predicate */ XPI_CLS_ORDERING, /* cmp or <=> */ }; enum XSParseInfixSelection { XPI_SELECT_ANY, XPI_SELECT_PREDICATE, /* any predicate */ XPI_SELECT_RELATION, /* any relation */ XPI_SELECT_EQUALITY, /* any equality */ XPI_SELECT_ORDERING, /* any ordering */ XPI_SELECT_MATCH_NOSMART, /* any equality or other match operator, including smartmatch */ XPI_SELECT_MATCH_SMART, /* any equality or other match operator, not including smartmatch */ }; /* lhs_flags, rhs_flags */ enum { XPI_OPERAND_TERM = 0, /* the "default" termexpr with no context */ /* other space reserved for other scalar types */ XPI_OPERAND_TERM_LIST = 6, /* term in list context */ XPI_OPERAND_LIST = 7, /* list in list context */ /* Other bitflags */ XPI_OPERAND_ONLY_LOOK = (1<<3), }; struct XSParseInfixHooks { U16 flags; U8 lhs_flags, rhs_flags; enum XSParseInfixClassification cls; const char *wrapper_func_name; /* These two hooks are ANDed together; both must pass, if present */ const char *permit_hintkey; bool (*permit) (pTHX_ void *hookdata); /* These hooks are alternatives; the first one defined is used */ OP *(*new_op)(pTHX_ U32 flags, OP *lhs, OP *rhs, void *hookdata); OP *(*ppaddr)(pTHX); /* A pp func used directly in newBINOP_custom() */ }; struct XSParseInfixInfo { const char *opname; OPCODE opcode; const struct XSParseInfixHooks *hooks; void *hookdata; }; static OP *(*xs_parse_infix_new_op_func)(pTHX_ const struct XSParseInfixInfo *info, U32 flags, OP *lhs, OP *rhs); #define xs_parse_infix_new_op(info, flags, lhs, rhs) S_xs_parse_infix_new_op(aTHX_ info, flags, lhs, rhs) static OP *S_xs_parse_infix_new_op(pTHX_ const struct XSParseInfixInfo *info, U32 flags, OP *lhs, OP *rhs) { if(!xs_parse_infix_new_op_func) croak("Must call boot_xs_parse_infix() first"); return (*xs_parse_infix_new_op_func)(aTHX_ info, flags, lhs, rhs); } static void (*register_xs_parse_infix_func)(pTHX_ const char *kw, const struct XSParseInfixHooks *hooks, void *hookdata); #define register_xs_parse_infix(opname, hooks, hookdata) S_register_xs_parse_infix(aTHX_ opname, hooks, hookdata) static void S_register_xs_parse_infix(pTHX_ const char *opname, const struct XSParseInfixHooks *hooks, void *hookdata) { if(!register_xs_parse_infix_func) croak("Must call boot_xs_parse_infix() first"); return (*register_xs_parse_infix_func)(aTHX_ opname, hooks, hookdata); } #define boot_xs_parse_infix(ver) S_boot_xs_parse_infix(aTHX_ ver) static void S_boot_xs_parse_infix(pTHX_ double ver) { SV **svp; SV *versv = ver ? newSVnv(ver) : NULL; /* XS::Parse::Infix is implemented in XS::Parse::Keyword's .so file */ load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("XS::Parse::Keyword"), versv, NULL); svp = hv_fetchs(PL_modglobal, "XS::Parse::Infix/ABIVERSION_MIN", 0); if(!svp) croak("XS::Parse::Infix ABI minimum version missing"); int abi_ver = SvIV(*svp); if(abi_ver > XSPARSEINFIX_ABI_VERSION) croak("XS::Parse::Infix ABI version mismatch - library supports >= %d, compiled for %d", abi_ver, XSPARSEINFIX_ABI_VERSION); svp = hv_fetchs(PL_modglobal, "XS::Parse::Infix/ABIVERSION_MAX", 0); abi_ver = SvIV(*svp); if(abi_ver < XSPARSEINFIX_ABI_VERSION) croak("XS::Parse::Infix ABI version mismatch - library supports <= %d, compiled for %d", abi_ver, XSPARSEINFIX_ABI_VERSION); xs_parse_infix_new_op_func = INT2PTR(OP *(*)(pTHX_ const struct XSParseInfixInfo *, U32, OP *, OP *), SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/new_op()@0", 0))); register_xs_parse_infix_func = INT2PTR(void (*)(pTHX_ const char *, const struct XSParseInfixHooks *, void *), SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/register()@1", 0))); } #endif XS-Parse-Keyword-0.21/XSParseKeyword.h000444001750001750 2441314131246632 16427 0ustar00leoleo000000000000#ifndef __XS_PARSE_KEYWORD_H__ #define __XS_PARSE_KEYWORD_H__ #define XSPARSEKEYWORD_ABI_VERSION 2 struct XSParseKeywordPieceType; struct XSParseKeywordPieceType { int type; union { char c; /* LITERALCHAR */ const char *str; /* LITERALSTR */ const struct XSParseKeywordPieceType *pieces; /* SCOPEs */ void (*callback)(pTHX_ void *hookdata); /* SETUP */ } u; }; enum { XPK_FLAG_EXPR = (1<<0), XPK_FLAG_STMT = (1<<1), XPK_FLAG_AUTOSEMI = (1<<2), }; enum { /* skip zero */ /* emits */ XS_PARSE_KEYWORD_LITERALCHAR = 1, /* nothing */ XS_PARSE_KEYWORD_LITERALSTR, /* nothing */ XS_PARSE_KEYWORD_FAILURE = 0x0f, /* nothing */ XS_PARSE_KEYWORD_BLOCK = 0x10, /* op */ XS_PARSE_KEYWORD_ANONSUB, /* cv */ /* TODO: XS_PARSE_KEYWORD_ARITHEXPR = 0x12 */ XS_PARSE_KEYWORD_TERMEXPR = 0x13, /* op */ XS_PARSE_KEYWORD_LISTEXPR, /* op */ /* TODO: XS_PARSE_KEYWORD_FULLEXPR = 0x15 */ XS_PARSE_KEYWORD_IDENT = 0x16, /* sv */ XS_PARSE_KEYWORD_PACKAGENAME, /* sv */ XS_PARSE_KEYWORD_LEXVARNAME, /* sv */ XS_PARSE_KEYWORD_LEXVAR, /* padix */ XS_PARSE_KEYWORD_ATTRS, /* i / {attr.name + attr.val} */ XS_PARSE_KEYWORD_VSTRING, /* sv */ XS_PARSE_KEYWORD_INFIX = 0x40, /* infix */ XS_PARSE_KEYWORD_SETUP = 0x70, /* invokes callback, emits nothing */ XS_PARSE_KEYWORD_SEQUENCE = 0x80, /* contained */ XS_PARSE_KEYWORD_REPEATED, /* i, contained */ XS_PARSE_KEYWORD_CHOICE, /* i, contained */ XS_PARSE_KEYWORD_TAGGEDCHOICE, /* i, contained */ XS_PARSE_KEYWORD_SEPARATEDLIST, /* i, contained */ XS_PARSE_KEYWORD_PARENSCOPE = 0xb0, /* contained */ XS_PARSE_KEYWORD_BRACKETSCOPE, /* contained */ XS_PARSE_KEYWORD_BRACESCOPE, /* contained */ XS_PARSE_KEYWORD_CHEVRONSCOPE, /* contained */ }; enum { XPK_LEXVAR_SCALAR = (1<<0), XPK_LEXVAR_ARRAY = (1<<1), XPK_LEXVAR_HASH = (1<<2), XPK_LEXVAR_ANY = XPK_LEXVAR_SCALAR|XPK_LEXVAR_ARRAY|XPK_LEXVAR_HASH, }; enum { XPK_TYPEFLAG_OPT = (1<<16), XPK_TYPEFLAG_SPECIAL = (1<<17), /* on XPK_BLOCK: scoped on XPK_LEXVAR: my */ /* These three are shifted versions of perl's G_VOID, G_SCALAR, G_LIST */ XPK_TYPEFLAG_G_VOID = (1<<18), XPK_TYPEFLAG_G_SCALAR = (2<<18), XPK_TYPEFLAG_G_LIST = (3<<18), XPK_TYPEFLAG_ENTERLEAVE = (1<<20), /* wrap ENTER/LEAVE pair around the item */ }; #define XPK_BLOCK_flags(flags) {.type = XS_PARSE_KEYWORD_BLOCK|(flags), .u.pieces = NULL} #define XPK_BLOCK XPK_BLOCK_flags(0) #define XPK_BLOCK_VOIDCTX XPK_BLOCK_flags(XPK_TYPEFLAG_SPECIAL|XPK_TYPEFLAG_G_VOID) #define XPK_BLOCK_SCALARCTX XPK_BLOCK_flags(XPK_TYPEFLAG_SPECIAL|XPK_TYPEFLAG_G_SCALAR) #define XPK_BLOCK_LISTCTX XPK_BLOCK_flags(XPK_TYPEFLAG_SPECIAL|XPK_TYPEFLAG_G_LIST) #define XPK_PREFIXED_BLOCK_flags(flags,...) \ {.type = XS_PARSE_KEYWORD_BLOCK|flags, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_PREFIXED_BLOCK(...) XPK_PREFIXED_BLOCK_flags(0, __VA_ARGS__) #define XPK_PREFIXED_BLOCK_ENTERLEAVE(...) XPK_PREFIXED_BLOCK_flags(XPK_TYPEFLAG_ENTERLEAVE, __VA_ARGS__) #define XPK_SETUP(setup) {.type = XS_PARSE_KEYWORD_SETUP, .u.callback = setup} #define XPK_ANONSUB {.type = XS_PARSE_KEYWORD_ANONSUB} #define XPK_TERMEXPR_flags(flags) {.type = XS_PARSE_KEYWORD_TERMEXPR|(flags)} #define XPK_TERMEXPR XPK_TERMEXPR_flags(0) #define XPK_TERMEXPR_VOIDCTX XPK_TERMEXPR_flags(XPK_TYPEFLAG_G_VOID) #define XPK_TERMEXPR_SCALARCTX XPK_TERMEXPR_flags(XPK_TYPEFLAG_G_SCALAR) #define XPK_LISTEXPR_flags(flags) {.type = XS_PARSE_KEYWORD_LISTEXPR|(flags)} #define XPK_LISTEXPR XPK_LISTEXPR_flags(0) #define XPK_LISTEXPR_LISTCTX XPK_LISTEXPR_flags(XPK_TYPEFLAG_G_LIST) #define XPK_IDENT {.type = XS_PARSE_KEYWORD_IDENT } #define XPK_IDENT_OPT {.type = XS_PARSE_KEYWORD_IDENT |XPK_TYPEFLAG_OPT} #define XPK_PACKAGENAME {.type = XS_PARSE_KEYWORD_PACKAGENAME } #define XPK_PACKAGENAME_OPT {.type = XS_PARSE_KEYWORD_PACKAGENAME|XPK_TYPEFLAG_OPT} #define XPK_LEXVARNAME(kind) {.type = XS_PARSE_KEYWORD_LEXVARNAME, .u.c = kind} #define XPK_LEXVAR_MY(kind) {.type = XS_PARSE_KEYWORD_LEXVAR|XPK_TYPEFLAG_SPECIAL, .u.c = kind} #define XPK_ATTRIBUTES {.type = XS_PARSE_KEYWORD_ATTRS} #define XPK_VSTRING {.type = XS_PARSE_KEYWORD_VSTRING} #define XPK_VSTRING_OPT {.type = XS_PARSE_KEYWORD_VSTRING|XPK_TYPEFLAG_OPT} #define XPK_COMMA {.type = XS_PARSE_KEYWORD_LITERALCHAR, .u.c = ','} #define XPK_COLON {.type = XS_PARSE_KEYWORD_LITERALCHAR, .u.c = ':'} #define XPK_EQUALS {.type = XS_PARSE_KEYWORD_LITERALCHAR, .u.c = '='} #define XPK_LITERAL(s) {.type = XS_PARSE_KEYWORD_LITERALSTR, .u.str = (const char *)s} #define XPK_STRING(s) XPK_LITERAL(s) #define XPK_INFIX(select) {.type = XS_PARSE_KEYWORD_INFIX, .u.c = select} #define XPK_INFIX_RELATION XPK_INFIX(XPI_SELECT_RELATION) #define XPK_INFIX_EQUALITY XPK_INFIX(XPI_SELECT_EQUALITY) #define XPK_INFIX_MATCH_NOSMART XPK_INFIX(XPI_SELECT_MATCH_NOSMART) #define XPK_INFIX_MATCH_SMART XPK_INFIX(XPI_SELECT_MATCH_SMART) #define XPK_SEQUENCE(...) \ {.type = XS_PARSE_KEYWORD_SEQUENCE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} /* First piece of these must be something probe-able */ #define XPK_OPTIONAL(...) \ {.type = XS_PARSE_KEYWORD_SEQUENCE|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_REPEATED(...) \ {.type = XS_PARSE_KEYWORD_REPEATED, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} /* Every piece must be probeable */ #define XPK_CHOICE(...) \ {.type = XS_PARSE_KEYWORD_CHOICE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} /* Every piece must be probeable, and followed by XPK_TAG */ #define XPK_TAGGEDCHOICE(...) \ {.type = XS_PARSE_KEYWORD_TAGGEDCHOICE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0}, {0} }} #define XPK_TAG(val) \ {.type = val} #define XPK_COMMALIST(...) \ {.type = XS_PARSE_KEYWORD_SEPARATEDLIST, .u.pieces = (const struct XSParseKeywordPieceType []){ \ {.type = XS_PARSE_KEYWORD_LITERALCHAR, .u.c = ','}, __VA_ARGS__, {0}}} #define XPK_FAILURE(s) {.type = XS_PARSE_KEYWORD_FAILURE, .u.str = (const char *)s} #define XPK_PARENSCOPE(...) \ {.type = XS_PARSE_KEYWORD_PARENSCOPE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_PARENSCOPE_OPT(...) \ {.type = XS_PARSE_KEYWORD_PARENSCOPE|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_BRACKETSCOPE(...) \ {.type = XS_PARSE_KEYWORD_BRACKETSCOPE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_BRACKETSCOPE_OPT(...) \ {.type = XS_PARSE_KEYWORD_BRACKETSCOPE|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_BRACESCOPE(...) \ {.type = XS_PARSE_KEYWORD_BRACESCOPE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_BRACESCOPE_OPT(...) \ {.type = XS_PARSE_KEYWORD_BRACESCOPE|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_CHEVRONSCOPE(...) \ {.type = XS_PARSE_KEYWORD_CHEVRONSCOPE, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_CHEVRONSCOPE_OPT(...) \ {.type = XS_PARSE_KEYWORD_CHEVRONSCOPE|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} /* This type defined in XSParseInfix.h */ typedef struct XSParseInfixInfo XSParseInfixInfo; typedef struct { union { OP *op; CV *cv; SV *sv; int i; struct { SV *name; SV *value; } attr; PADOFFSET padix; XSParseInfixInfo *infix; }; int line; } XSParseKeywordPiece; struct XSParseKeywordHooks { U32 flags; /* used by build1 */ struct XSParseKeywordPieceType piece1; /* alternatively, used by build */ const struct XSParseKeywordPieceType *pieces; /* These two hooks are ANDed together; both must pass, if present */ const char *permit_hintkey; bool (*permit) (pTHX_ void *hookdata); void (*check)(pTHX_ void *hookdata); /* These are alternatives; the first one defined is used */ int (*parse)(pTHX_ OP **opp, void *hookdata); int (*build)(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata); int (*build1)(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata); }; static void (*register_xs_parse_keyword_func)(pTHX_ const char *kwname, const struct XSParseKeywordHooks *hooks, void *hookdata); #define register_xs_parse_keyword(kwname, hooks, hookdata) S_register_xs_parse_keyword(aTHX_ kwname, hooks, hookdata) static void S_register_xs_parse_keyword(pTHX_ const char *kwname, const struct XSParseKeywordHooks *hooks, void *hookdata) { if(!register_xs_parse_keyword_func) croak("Must call boot_xs_parse_keyword() first"); (*register_xs_parse_keyword_func)(aTHX_ kwname, hooks, hookdata); } #define boot_xs_parse_keyword(ver) S_boot_xs_parse_keyword(aTHX_ ver) static void S_boot_xs_parse_keyword(pTHX_ double ver) { SV **svp; SV *versv = ver ? newSVnv(ver) : NULL; load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("XS::Parse::Keyword"), versv, NULL); svp = hv_fetchs(PL_modglobal, "XS::Parse::Keyword/ABIVERSION_MIN", 0); if(!svp) croak("XS::Parse::Keyword ABI minimum version missing"); int abi_ver = SvIV(*svp); if(abi_ver > XSPARSEKEYWORD_ABI_VERSION) croak("XS::Parse::Keyword ABI version mismatch - library supports >= %d, compiled for %d", abi_ver, XSPARSEKEYWORD_ABI_VERSION); svp = hv_fetchs(PL_modglobal, "XS::Parse::Keyword/ABIVERSION_MAX", 0); abi_ver = SvIV(*svp); if(abi_ver < XSPARSEKEYWORD_ABI_VERSION) croak("XS::Parse::Keyword ABI version mismatch - library supports <= %d, compiled for %d", abi_ver, XSPARSEKEYWORD_ABI_VERSION); register_xs_parse_keyword_func = INT2PTR(void (*)(pTHX_ const char *, const struct XSParseKeywordHooks *, void *), SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Keyword/register()@2", 0))); } #endif XS-Parse-Keyword-0.21/hax000755001750001750 014131246633 13764 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/hax/force_list_keeping_pushmark.c.inc000444001750001750 133114131246633 22600 0ustar00leoleo000000000000/* vi: set ft=c : */ #include "op_sibling_splice.c.inc" /* force_list_keeping_pushmark nulls out the OP_LIST itself but preserves * the OP_PUSHMARK inside it. This is essential or else op_contextualize() * will null out both of them and we lose the mark */ /* copypasta from core's op.c */ #define force_list_keeping_pushmark(o) S_force_list_keeping_pushmark(aTHX_ o) static OP *S_force_list_keeping_pushmark(pTHX_ OP *o) { if(!o || o->op_type != OP_LIST) { OP *rest = NULL; if(o) { rest = OpSIBLING(o); OpLASTSIB_set(o, NULL); } o = newLISTOP(OP_LIST, 0, o, NULL); if(rest) op_sibling_splice(o, cLISTOPo->op_last, 0, rest); } op_null(o); return op_contextualize(o, G_LIST); } XS-Parse-Keyword-0.21/hax/lexer-additions.c.inc000444001750001750 1525314131246633 20156 0ustar00leoleo000000000000/* 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); } XS-Parse-Keyword-0.21/hax/make_argcheck_aux.c.inc000444001750001750 132314131246633 20455 0ustar00leoleo000000000000/* 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 XS-Parse-Keyword-0.21/hax/make_argcheck_ops.c.inc000444001750001750 553714131246633 20474 0ustar00leoleo000000000000/* vi: set ft=c : */ #define make_croak_op(message) S_make_croak_op(aTHX_ message) static OP *S_make_croak_op(pTHX_ SV *message) { #if HAVE_PERL_VERSION(5, 22, 0) sv_catpvs(message, " at %s line %d.\n"); /* die sprintf($message, (caller)[1,2]) */ return op_convert_list(OP_DIE, 0, op_convert_list(OP_SPRINTF, 0, op_append_list(OP_LIST, newSVOP(OP_CONST, 0, message), newSLICEOP(0, op_append_list(OP_LIST, newSVOP(OP_CONST, 0, newSViv(1)), newSVOP(OP_CONST, 0, newSViv(2))), newOP(OP_CALLER, 0))))); #else /* For some reason I can't work out, the above tree isn't correct. Attempts * to correct it still make OP_SPRINTF crash with "Out of memory!". For now * lets just avoid the sprintf */ sv_catpvs(message, "\n"); return newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, message)); #endif } #if HAVE_PERL_VERSION(5, 26, 0) # define HAVE_OP_ARGCHECK # include "make_argcheck_aux.c.inc" #endif #define make_argcheck_ops(required, optional, slurpy, subname) S_make_argcheck_ops(aTHX_ required, optional, slurpy, subname) static OP *S_make_argcheck_ops(pTHX_ int required, int optional, char slurpy, SV *subname) { int params = required + optional; #ifdef HAVE_OP_ARGCHECK UNOP_AUX_item *aux = make_argcheck_aux(params, optional, slurpy); return op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), op_prepend_elem(OP_LINESEQ, newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux), NULL)); #else /* Older perls lack the convenience of OP_ARGCHECK so we'll have to build an * optree ourselves. For now we only support required + optional, no slurpy * * This code heavily inspired by Perl_parse_subsignature() in toke.c from perl 5.24 */ OP *ret = NULL; if(required > 0) { SV *message = newSVpvf("Too few arguments for subroutine '%" SVf "'", subname); /* @_ >= required or die ... */ OP *checkop = newSTATEOP(0, NULL, newLOGOP(OP_OR, 0, newBINOP(OP_GE, 0, /* scalar @_ */ op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR), newSVOP(OP_CONST, 0, newSViv(required))), make_croak_op(message))); ret = op_append_list(OP_LINESEQ, ret, checkop); } if(!slurpy) { SV *message = newSVpvf("Too many arguments for subroutine '%" SVf "'", subname); /* @_ <= (required+optional) or die ... */ OP *checkop = newSTATEOP(0, NULL, newLOGOP(OP_OR, 0, newBINOP(OP_LE, 0, /* scalar @_ */ op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR), newSVOP(OP_CONST, 0, newSViv(params))), make_croak_op(message))); ret = op_append_list(OP_LINESEQ, ret, checkop); } /* TODO: If slurpy is % then maybe complain about odd number of leftovers */ return ret; #endif } XS-Parse-Keyword-0.21/hax/newOP_CUSTOM.c.inc000444001750001750 612414131246633 17162 0ustar00leoleo000000000000/* vi: set ft=c : */ /* Before perl 5.22 under -DDEBUGGING, various new*OP() functions throw assert * failures on OP_CUSTOM. * https://rt.cpan.org/Ticket/Display.html?id=128562 */ #define newOP_CUSTOM(func, flags) S_newOP_CUSTOM(aTHX_ func, flags) #define newUNOP_CUSTOM(func, flags, first) S_newUNOP_CUSTOM(aTHX_ func, flags, first) #define newSVOP_CUSTOM(func, flags, sv) S_newSVOP_CUSTOM(aTHX_ func, flags, sv) #define newBINOP_CUSTOM(func, flags, first, last) S_newBINOP_CUSTOM(aTHX_ func, flags, first, last) #define newLOGOP_CUSTOM(func, flags, first, other) S_newLOGOP_CUSTOM(aTHX_ func, flags, first, other) static OP *S_newOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags) { OP *op = newOP(OP_CUSTOM, flags); op->op_ppaddr = func; return op; } static OP *S_newUNOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first) { UNOP *unop; #if HAVE_PERL_VERSION(5,22,0) unop = (UNOP *)newUNOP(OP_CUSTOM, flags, first); #else NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)OP_CUSTOM; unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); #endif unop->op_ppaddr = func; return (OP *)unop; } static OP *S_newSVOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, SV *sv) { SVOP *svop; #if HAVE_PERL_VERSION(5,22,0) svop = (SVOP *)newSVOP(OP_CUSTOM, flags, sv); #else NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)OP_CUSTOM; svop->op_sv = sv; svop->op_next = (OP *)svop; svop->op_flags = 0; svop->op_private = 0; #endif svop->op_ppaddr = func; return (OP *)svop; } static OP *S_newBINOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last) { BINOP *binop; #if HAVE_PERL_VERSION(5,22,0) binop = (BINOP *)newBINOP(OP_CUSTOM, flags, first, last); #else NewOp(1101, binop, 1, BINOP); binop->op_type = (OPCODE)OP_CUSTOM; binop->op_first = first; first->op_sibling = last; binop->op_last = last; binop->op_flags = (U8)(flags | OPf_KIDS); binop->op_private = (U8)(2 | (flags >> 8)); #endif binop->op_ppaddr = func; return (OP *)binop; } static OP *S_newLOGOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *other) { OP *o; #if HAVE_PERL_VERSION(5,22,0) o = newLOGOP(OP_CUSTOM, flags, first, other); #else /* Parts of this code copypasted from perl 5.20.0's op.c S_new_logop() */ LOGOP *logop; first = op_contextualize(first, G_SCALAR); NewOp(1101, logop, 1, LOGOP); logop->op_type = (OPCODE)OP_CUSTOM; logop->op_ppaddr = NULL; /* Because caller only overrides it anyway */ logop->op_first = first; logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_other = LINKLIST(other); /* logop->op_private has nothing interesting for OP_CUSTOM */ /* Link in postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP *)logop; first->op_sibling = other; /* No CHECKOP for OP_CUSTOM */ o = newUNOP(OP_NULL, 0, (OP *)logop); other->op_next = o; #endif /* the returned op is actually an UNOP that's either NULL or NOT; the real * logop is the op_next of it */ cUNOPx(o)->op_first->op_ppaddr = func; return o; } XS-Parse-Keyword-0.21/hax/op_sibling_splice.c.inc000444001750001750 167714131246633 20534 0ustar00leoleo000000000000/* vi: set ft=c : */ #ifndef op_sibling_splice # define op_sibling_splice(parent, start, del_count, insert) S_op_sibling_splice(aTHX_ parent, start, del_count, insert) static OP *S_op_sibling_splice(pTHX_ OP *parent, OP *start, int del_count, OP *insert) { OP *deleted = NULL; if(!insert && !del_count) return NULL; OP **prevp; if(start) prevp = &(start->op_sibling); else prevp = &(cLISTOPx(parent)->op_first); OP *after = *prevp; if(del_count) { croak("Back-compat op_sibling_splice with del_count != 0 not yet implemented"); /* THIS IS AS YET UNTESTED deleted = *prevp; OP *o = deleted; while(del_count > 1) o = o->op_sibling, del_count--; after = o->op_sibling; o->op_sibling = NULL; */ } if(insert) { *prevp = insert; OP *o = insert; while(o->op_sibling) o = o->op_sibling; o->op_sibling = after; } else *prevp = after; return deleted; } #endif XS-Parse-Keyword-0.21/hax/perl-backcompat.c.inc000444001750001750 730314131246633 20104 0ustar00leoleo000000000000/* vi: set ft=c : */ #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #ifndef NOT_REACHED # define NOT_REACHED assert(0) #endif #ifndef SvTRUE_NN # define SvTRUE_NN(sv) SvTRUE(sv) #endif #ifndef G_LIST # define G_LIST G_ARRAY #endif #if !HAVE_PERL_VERSION(5, 18, 0) typedef AV PADNAMELIST; # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) # define PadlistNAMES(pl) (*PadlistARRAY(pl)) typedef SV PADNAME; # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) # define PadnameLEN(pn) SvCUR(pn) # define PadnameOUTER(pn) (SvFAKE(pn) && !SvPAD_STATE(pn)) # define PadnamelistARRAY(pnl) AvARRAY(pnl) # define PadnamelistMAX(pnl) AvFILLp(pnl) # define PadARRAY(p) AvARRAY(p) # define PadMAX(pad) AvFILLp(pad) #endif #ifndef av_top_index # define av_top_index(av) AvFILL(av) #endif #ifndef block_end # define block_end(a,b) Perl_block_end(aTHX_ a,b) #endif #ifndef block_start # define block_start(a) Perl_block_start(aTHX_ a) #endif #ifndef cv_clone # define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif #ifndef intro_my # define intro_my() Perl_intro_my(aTHX) #endif #ifndef pad_alloc # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) #endif #ifndef CX_CUR # define CX_CUR() (&cxstack[cxstack_ix]) #endif #if HAVE_PERL_VERSION(5, 24, 0) # define OLDSAVEIX(cx) (cx->blk_oldsaveix) #else # define OLDSAVEIX(cx) (PL_scopestack[cx->blk_oldscopesp-1]) #endif #ifndef OpSIBLING # define OpSIBLING(op) ((op)->op_sibling) #endif #ifndef OpMORESIB_set # define OpMORESIB_set(op,sib) ((op)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set /* older perls don't need to store this at all */ # define OpLASTSIB_set(op,parent) #endif #ifndef op_convert_list # define op_convert_list(type, flags, o) S_op_convert_list(aTHX_ type, flags, o) static OP *S_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) { /* A minimal recreation just for our purposes */ assert( /* A hardcoded list of the optypes we know this will work for */ type == OP_ENTERSUB || type == OP_JOIN || type == OP_PUSH || 0); o->op_type = type; o->op_flags |= flags; o->op_ppaddr = PL_ppaddr[type]; o = PL_check[type](aTHX_ o); /* op_std_init() */ if(PL_opargs[type] & OA_RETSCALAR) o = op_contextualize(o, G_SCALAR); if(PL_opargs[type] & OA_TARGET && !o->op_targ) o->op_targ = pad_alloc(type, SVs_PADTMP); return o; } #endif #ifndef newMETHOP_named # define newMETHOP_named(type, flags, name) newSVOP(type, flags, name) #endif #ifndef PARENT_PAD_INDEX_set # if HAVE_PERL_VERSION(5, 22, 0) # define PARENT_PAD_INDEX_set(pn,val) (PARENT_PAD_INDEX(pn) = val) # else /* stolen from perl-5.20.0's pad.c */ # define PARENT_PAD_INDEX_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END # endif #endif /* On Perl 5.14 this had a different name */ #ifndef pad_add_name_pvn #define pad_add_name_pvn(name, len, flags, typestash, ourstash) MY_pad_add_name(aTHX_ name, len, flags, typestash, ourstash) static PADOFFSET MY_pad_add_name(pTHX_ const char *name, STRLEN len, U32 flags, HV *typestash, HV *ourstash) { /* perl 5.14's Perl_pad_add_name requires a NUL-terminated name */ SV *namesv = sv_2mortal(newSVpvn(name, len)); return Perl_pad_add_name(aTHX_ SvPV_nolen(namesv), SvCUR(namesv), flags, typestash, ourstash); } #endif #if !HAVE_PERL_VERSION(5, 26, 0) # define isIDFIRST_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDFIRST_utf8(s)) # define isIDCONT_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDCONT_utf8(s)) #endif XS-Parse-Keyword-0.21/hax/wrap_keyword_plugin.c.inc000444001750001750 133114131246633 21126 0ustar00leoleo000000000000/* 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; } XS-Parse-Keyword-0.21/inc000755001750001750 014131246633 13755 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/inc/Module000755001750001750 014131246633 15202 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/inc/Module/Build000755001750001750 014131246633 16241 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/inc/Module/Build/with000755001750001750 014131246633 17214 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/inc/Module/Build/with/XSTests.pm000444001750001750 174614131246633 21274 0ustar00leoleo000000000000package 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; XS-Parse-Keyword-0.21/lib000755001750001750 014131246633 13752 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/lib/XS000755001750001750 014131246633 14304 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/lib/XS/Parse000755001750001750 014131246633 15356 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/lib/XS/Parse/Infix.pm000444001750001750 3400114131246633 17144 0ustar00leoleo000000000000# 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 package XS::Parse::Infix 0.21; use v5.14; use warnings; # No actual .xs file; the code is implemented in XS::Parse::Keyword require XS::Parse::Keyword; =head1 NAME C - XS functions to assist in parsing infix operators =head1 DESCRIPTION This module provides some XS functions to assist in writing syntax modules that provide new infix operators as perl syntax, primarily for authors of syntax plugins. It is unlikely to be of much use to anyone else; and highly unlikely to be of any use when writing perl code using these. Unless you are writing a syntax 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. In addition, the places this functionality can be used are relatively small. No current release of perl actually supports custom infix operators, though I have a branch where I am currently experimenting with such support: L In addition, the various C token types of L support querying on this module, so some syntax provided by other modules may be able to make use of these new infix operators. =cut =head1 CONSTANTS =head2 HAVE_PL_INFIX_PLUGIN if( XS::Parse::Infix::HAVE_PL_INFIX_PLUGIN ) { ... } This constant is true if built on a perl that supports the C extension mechanism, meaning that custom infix operators registered with this module will actually be recognised by the perl parser. No actual production or development releases of perl yet support this feature, but see above for details of a branch which does. =cut =head1 XS FUNCTIONS =head2 boot_xs_parse_infix void boot_xs_parse_infix(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_infix(0.14); =head2 xs_parse_infix_new_op OP *xs_parse_infix_new_op(const struct XSParseInfixInfo *info, U32 flags, OP *lhs, OP *rhs); This function constructs a new optree fragment to represent invoking the infix operator with the given operands. It should be used much the same as core perl's C function. The C structure pointer would be obtained from the C field of the result of invoking the various C token types from C. =head2 register_xs_parse_infix void register_xs_parse_infix(const char *opname, const struct XSParseInfixHooks *hooks, void *hookdata); This function installs a set of parsing hooks to be associated with the given operator name. This new operator will then be available via L by the various C token types, or to core perl's C if availble. These tokens will all yield an info structure, with the following fields: struct XSParseInfixInfo { const char *opname; OPCODE opcode; /* for built-in operators, or OP_CUSTOM for custom-registered ones */ struct XSParseInfixHooks *hooks; void *hookdata; }; If the operator name contains any non-ASCII characters they are presumed to be in UTF-8 encoding. This will matter for deparse purposes. =cut =head1 PARSE HOOKS The C structure provides the following fields which are used at various stages of parsing. struct XSParseInfixHooks { U16 flags; /* currently ignored */ U8 lhs_flags; U8 rhs_flags; enum XSParseInfixClassification cls; const char *wrapper_func_name; const char *permit_hintkey; bool (*permit)(pTHX_ void *hookdata); OP *(*new_op)(pTHX_ U32 flags, OP *lhs, OP *rhs, void *hookdata); OP *(*ppaddr)(pTHX); }; =head2 Flags The C field is currently ignored. It is defined simply to reserve the space in case used in a later version. It should be set to zero. The C field gives details on how to parse and handle the right-hand side of the operator syntax. It should be set to one of the following constants: =over 4 =item XPI_OPERAND_TERM (0) Default. The operand is a term expression. =item XPI_OPERAND_TERM_LIST The operand is a term expression. It will be foced into list context, preserving the C at the beginning. This means that the ppfunc for this infix operator will have to C to find that. =item XPI_OPERAND_LIST The operand is a list expression. It will be forced into list context, the same as above. =back In addition the following extra bitflags are defined: =over 4 =item XPI_OPERAND_ONLY_LOOK If set, the operator function promises that it will not mutate any of its passed values, nor allow leaking of direct alias pointers to them via return value or other locations. This flag is optional; omitting it when applicable will not change any observed behaviour. Setting it may enable certain optimisations to be performed. Currently, this flag simply enables an optimisation in the call-checker for infix operator wrapper functions that take list-shaped operands. This optimisation discards an C operation which would create a temporary anonymous array reference for its operand values, allowing a slight saving of memory use and CPU time. This optimisation is only safe to perform if the operator does not mutate or retain aliases of any of the arguments, as otherwise the caller might see unexpected modifications or value references to the values passed. =back The C field gives details on how to handle the left-hand side of the operator syntax. It takes similar values to C, except that it does not accept the C value. Parsing always happens on just a term expression, though it may be placed into list context (which therefore still permits things like parenthesized lists, or array variables). =head2 The Selection Stage The C field gives a "classification" of the operator, suggesting what sort of operation it provides. This is used as a filter by the various C selection macros. The classification should be one of the C constants found and described further in the main F file. =head2 The C Stage 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 The Op Generation Stage If the infix operator is going to be used, then one of the C or the C fields explain how to create a new optree fragment. If C is defined then it will be used, and is expected to return an optree fragment that consumes the LHS and RHS arguments to implement the semantics of the operator. If this is not present, then the C will be used instead to construct a new BINOP of the C type. =head2 The Wrapper Function Additionally, if the C field is set to a string, this gives the (fully-qualified) name for a function to be generated as part of registering the operator. This newly-generated function will act as a wrapper for the operator. For operators whose RHS is a scalar, the wrapper function is assumed to take two simple scalar arguments. The result of invoking the function on those arguments will be determined by using the operator code. $result = $lhs OP $rhs; $result = WRAPPERFUNC( $lhs, $rhs ); For operators whose RHS is a list, the wrapper function takes at least one argument, possibly more. The first argument is the scalar on the LHS, and the remaining arguments, however many there are, form the RHS: $result = $lhs OP @rhs; $result = WRAPPERFUNC( $lhs, @rhs ); For operators whose LHS and RHS is a list, the wrapper function takes two arguments which must be array references containing the lists. $result = @lhs OP @rhs; $result = WRAPPERFUNC( \@lhs, \@rhs ); This creates a convenience for accessing the operator from perls that do not support C. In the case of scalar infix operators, the wrapper function also includes a call-checker which attempts to inline the operator directly into the callsite. Thus, in simple cases where the function is called directly on exactly two scalar arguments (such as in the following), no C overhead will be incurred and the generated optree will be identical to that which would have been generated by using infix operator syntax directly: WRAPPERFUNC( $lhs, $rhs ); WRAPPERFUNC( $lhs, CONSTANT ); WRAPPERFUNC( $args[0], $args[1] ); WRAPPERFUNC( $lhs, scalar otherfunc() ); The checker is very pessimistic and will only rewrite callsites where it determines this can be done safely. It will not rewrite any of the following forms: WRAPPERFUNC( $onearg ); # not enough args WRAPPERFUNC( $x, $y, $z ); # too many args WRAPPERFUNC( @args[0,1] ); # not a scalar WRAPPERFUNC( $lhs, otherfunc() ); # not a scalar The wrapper function for infix operators which take lists on both sides also has a call-checker which will attempt to inline the operator in similar circumstances. In addition to the optimisations described above for scalar operators, this checker will also inline an array-reference operator and omit the resulting dereference behaviour. Thus, the two following lines emit the same optree, without an C or C: @lhs OP @rhs; WRAPPERFUNC( \@lhs, \@rhs ); B that technically, this optimisation isn't strictly transparent in the odd cornercase that one of the referenced arrays is also the backing store for a blessed object reference, and that object class has a C<@{}> overload. my @arr; package SomeClass { use overload '@{}' => sub { return ["values", "go", "here"]; }; } bless \@arr, "SomeClass"; # this will not actually invoke the overload operator WRAPPERFUNC( \@arr, [4, 5, 6] ); As this cornercase relates to taking duplicate references to the same blessed object's backing store variable, it should not matter to any real code; regular objects that are passed by reference into the wrapper function will run their overload methods as normal. The callchecker for list operands can optionally also discard an op of the C type, which is used by anonymous array-ref construction: ($u, $v, $w) OP ($x, $y, $z); WRAPPERFUNC( [$u, $v, $w], [$x, $y, $z] ); This optimisation is only performed if the operator declared it safe to do so, via the C flag. =cut =head1 DEPARSE This module operates with L in order to automatically provide deparse support for infix operators. Every infix operator that is implemented as a custom op (and thus has the C hook field set) will have deparse logic added. This will allow it to deparse to either the named wrapper function, or to the infix operator syntax if on a C-enabled perl and the appropriate lexical hint is enabled at the callsite. In order for this to work, it is important that your custom operator is I registered as a custom op using the C function. This registration will be performed by C itself at the time the infix operator is registered. =cut sub B::Deparse::_deparse_infix_wrapperfunc_scalarscalar { my ( $self, $wrapper_func_name, $op, $ctx ) = @_; my $lhs = $op->first; my $rhs = $op->last; $_ = $self->deparse( $_, 6 ) for $lhs, $rhs; return "$wrapper_func_name($lhs, $rhs)"; } sub B::Deparse::_deparse_infix_wrapperfunc_listlist { my ( $self, $wrapper_func_name, $op, $ctx ) = @_; my $lhs = $op->first; my $rhs = $op->last; foreach my $var ( \$lhs, \$rhs ) { my $argop = $$var; my $kid; if( $argop->name eq "null" and $argop->first->name eq "pushmark" and ($kid = $argop->first->sibling) and B::Deparse::null($kid->sibling) ) { my $add_refgen; # A list of a single item if( $kid->name eq "rv2av" and $kid->first->name ne "gv" ) { $argop = $kid->first; } elsif( $kid->name eq "padav" or $kid->name eq "rv2av" ) { $add_refgen++; } else { print STDERR "Maybe UNWRAP list ${\ $kid->name }\n"; } $$var = $self->deparse( $argop, 6 ); $$var = "\\$$var" if $add_refgen; } else { # Pretend the entire list was anonlist my @args; $argop = $argop->first->sibling; # skip pushmark while( not B::Deparse::null($argop) ) { push @args, $self->deparse( $argop, 6 ); $argop = $argop->sibling; } $$var = "[" . join( ", ", @args ) . "]"; } } return "$wrapper_func_name($lhs, $rhs)"; } sub B::Deparse::_deparse_infix_named { my ( $self, $opname, $op, $ctx ) = @_; my $lhs = $op->first; my $rhs = $op->last; return join " ", $self->deparse_binop_left( $op, $lhs, 14 ), $opname, $self->deparse_binop_right( $op, $rhs, 14 ); } =head1 TODO =over 4 =item * Have the entersub checker for list/list operators unwrap arrayref or anon-array argument forms (C or C). =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; XS-Parse-Keyword-0.21/lib/XS/Parse/Keyword.pm000444001750001750 4632514131246633 17527 0ustar00leoleo000000000000# 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 package XS::Parse::Keyword 0.21; use v5.14; use warnings; require XSLoader; XSLoader::load( __PACKAGE__, our $VERSION ); =head1 NAME C - XS functions to assist in parsing keyword syntax =head1 DESCRIPTION This module provides some XS functions to assist in writing syntax modules that provide new perl-visible 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. =cut =head1 XS FUNCTIONS =head2 boot_xs_parse_keyword void boot_xs_parse_keyword(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_keyword(0.14); =head2 register_xs_parse_keyword void register_xs_parse_keyword(const char *keyword, const struct XSParseKeywordHooks *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. =cut =head1 PARSE HOOKS The C structure provides the following hook stages, which are invoked in the given order. =head2 flags The following flags are defined: =over 4 =item C The parse or build function is expected to return C. =item C The parse or build function is expected to return C. These two flags are largely for the benefit of giving static information at registration time to assist static parsing or other related tasks to know what kind of grammatical element this keyword will produce. =item C The syntax forms a complete statement, which should be followed by a statement separator semicolon (C<;>). This semicolon is optional at the end of a block. The semicolon, if present, will be consumed automatically. =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 The C Stage void (*check)(pTHX_ void *hookdata); Invoked once the keyword has been permitted. If present, this hook function can check the surrounding lexical context, state, or other information and throw an exception if it is unhappy that the keyword should apply in this position. =head2 The C Stage This stage is invoked once the keyword has been checked, and actually parses the incoming text into an optree. It is implemented by calling the B of the following function pointers which is not NULL. The invoked function may optionally build an optree to represent the parsed syntax, and place it into the variable addressed by C. If it does not, then a simple C will be constructed in its place. C is called both before and after this stage is invoked, so in many simple cases the hook function itself does not need to bother with it. int (*parse)(pTHX_ OP **out, void *hookdata); If present, this should consume text from the parser buffer by invoking C or C functions and eventually return a C result value. This is the most generic and powerful of the options, but requires the most amount of implementation work. int (*build)(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata); If C is not present, this is called instead after parsing a sequence of arguments, of types given by the I field; which should be a zero- terminated array of piece types. This alternative is somewhat less generic and powerful than providing C yourself, but involves much less parsing work and is shorter and easier to implement. int (*build1)(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata); If neither C nor C are present, this is called as a simpler variant of C when only a single argument is required. It takes its type from the C field instead. =cut =head1 PIECES AND PIECE TYPES When using the C or C alternatives for the C phase, the actual syntax is parsed automatically by this module, according to the specification given by the I or I field. The result of that parsing step is placed into the I or I parameter to the invoked function, using a C type consisting of the following fields: typedef struct union { OP *op; CV *cv; SV *sv; int i; struct { SV *name; SV *value; } attr; PADOFFSET padix; struct XSParseInfixInfo *infix; }; int line; } XSParseKeywordPiece; Which field of the anonymous union is set depends on the type of the piece. The I field contains the line number of the source file where parsing of that piece began. Some piece types are "atomic", whose definition is self-contained. Others are structural, defined in terms of inner pieces. Together these form an entire tree-shaped definition of the syntax that the keyword expects to find. Atomic types generally provide exactly one argument into the list of I (with the exception of literal matches, which do not provide anything). Structural types may provide an initial argument themselves, followed by a list of the values of each sub-piece they contained inside them. Thus, while the data structure defining the syntax shape is a tree, the argument values it parses into is passed as a flat array to the C function. Some structural types need to be able to determine whether or not syntax relating some optional part of them is present in the incoming source text. In this case, the pieces relating to those optional parts must support "probing". This ability is also noted below. The type of each piece should be one of the following macro values. =head2 XPK_BLOCK I XPK_BLOCK A brace-delimited block of code is expected, passed as an optree in the I field. This will be parsed as a block within the current function scope. This can be probed by checking for the presence of an open-brace (C<{>) character. Be careful defining grammars with this because an open-brace is also a valid character to start a term expression, for example. Given a choice between C and C, either of them could try to consume such code as { 123, 456 } =head2 XPK_BLOCK_VOIDCTX, XPK_BLOCK_SCALARCTX, XPK_BLOCK_LISTCTX Variants of C which wrap a void, scalar or list-context scope around the block. =head2 XPK_PREFIXED_BLOCK I XPK_PREFIXED_BLOCK(pieces ...) Some pieces are expected, followed by a brace-delimited block of code, which is passed as an optree in the I field. The prefix pieces are parsed first, and their results are passed before the block itself. The entire sequence, including the prefix items, is contained within a pair of C / C calls. This permits the prefix pieces to introduce new items into the lexical scope of the block - for example by the use of C. A call to C is automatically made at the end of the prefix pieces, before the block itself is parsed, ensuring any new lexical variables are now visible. In addition, the following extra piece types are recognised here: =over 4 =item XPK_SETUP void setup(pTHX_ void *hookdata); XPK_SETUP(&setup) I This piece type runs a function given by pointer. Typically this function may be used to introduce new lexical state into the parser, or in some other way have some side-effect on the parsing context of the block to be parsed. =back =head2 XPK_PREFIXED_BLOCK_ENTERLEAVE A variant of C which additionally wraps the entire parsing operation, including the C, C and any calls to C functions, within a C/C pair. This should not make a difference to the standard parser pieces provided here, but may be useful behaviour for the code in the setup function, especially if it wishes to modify parser state and use the savestack to ensure it is restored again when parsing has finished. =head2 XPK_ANONSUB I A brace-delimited block of code is expected, and assembled into the body of a new anonymous subroutine. This will be passed as a protosub CV in the I field. =head2 XPK_TERMEXPR I XPK_TERMEXPR A term expression is expected, parsed using C, and passed as an optree in the I field. =head2 XPK_TERMEXPR_VOIDCTX, XPK_TERMEXPR_SCALARCTX Variants of C which puts the expression in void or scalar context. =head2 XPK_LISTEXPR I XPK_LISTEXPR A list expression is expected, parsed using C, and passed as an optree in the I field. =head2 XPK_LISTEXPR_LISTCTX Variant of C which puts the expression in list context. =head2 XPK_IDENT, XPK_IDENT_OPT I A bareword identifier name is expected, and passed as an SV containing a PV in the I field. An identifier is not permitted to contain a double colon (C<::>). The C<_OPT>-suffixed version is optional; if no identifier is found then I is set to C. =head2 XPK_PACKAGENAME, XPK_PACKAGENAME_OPT I A bareword package name is expected, and passed as an SV containing a PV in the I field. A package name is similar to an identifier, except it permits double colons in the middle. The C<_OPT>-suffixed version is optional; if no package name is found then I is set to C. =head2 XPK_LEXVARNAME I XPK_LEXVARNAME(kind) A lexical variable name is expected, and passed as an SV containing a PV in the I field. The C argument specifies what kinds of variable are permitted, and should be a bitmask of one or more bits from C, C and C. A convenient shortcut C permits all three. =head2 XPK_ATTRIBUTES I A list of C<:>-prefixed attributes is expected, in the same format as sub or variable attributes. An optional leading C<:> indicates the presence of attributes, then one or more of them are parsed. Attributes may be optionally separated by additional C<:>s, but this is not required. Each attribute is expected to be an identifier name, followed by an optional value wrapped in parentheses. Whitespace is B permitted between the name and value, as per standard Perl parsing rules. :attrname :attrname(value) The I field indicates how many attributes were found. That number of additional arguments are then passed, each containing two SVs in the I and I fields. This number may be zero. It is not an error for there to be no attributes present, or for the optional colon to be missing. In this case I will be set to zero. =head2 XPK_VSTRING, XPK_VSTRING_OPT I A version string is expected, of the form C including the leading C character. It is passed as a L SV object in the I field. The C<_OPT>-suffixed version is optional; if no version string is found then I is set to C. =head2 XPK_LEXVAR_MY I XPK_LEXVAR_MY(kind) A lexical variable name is expected, added to the current pad as if specified in a C expression, and passed as the pad index in the I field. The C argument specifies what kinds of variable are permitted, as per C. =head2 XPK_COMMA, XPK_COLON, XPK_EQUALS I A literal character (C<,>, C<:> or C<=>) is expected. No argument value is passed. =head2 XPK_INFIX_* I An infix operator as recognised by L. The returned pointer points to a structure allocated by C describing the operator. Various versions of the macro are provided, each using a different selection filter to choose certain available infix operators: XPK_INFIX_RELATION # any relational operator XPK_INFIX_EQUALITY # an equality operator like `==` or `eq` XPK_INFIX_MATCH_NOSMART # any sort of "match"-like operator, except smartmatch XPK_INFIX_MATCH_SMART # XPK_INFIX_MATCH_NOSMART plus smartmatch =head2 XPK_LITERAL I XPK_LITERAL("literal") A literal string match is expected. No argument value is passed. This form should generally be avoided if at all possible, because it is very easy to abuse to make syntaxes which confuse humans and code tools alike. Generally it is best reserved just for the first component of a C or C sequence, to provide a "secondary keyword" that such a repeated item can look out for. This was previously called C, and is provided as a synonym for back-compatibility but new code should use this new name instead. =head2 XPK_SEQUENCE I XPK_SEQUENCE(pieces ...) A structural type which contains a number of pieces. This is normally equivalent to simply placing the pieces in sequence inside their own container, but it is useful inside C or C. An C supports probe if its first contained piece does; i.e. is transparent to probing. =head2 XPK_OPTIONAL I XPK_OPTIONAL(pieces ...) A structural type which may expects to find its contained pieces, or is happy not to. This will pass an argument whose I field contains either 1 or 0, depending whether the contents were found. The first piece type within must support probe. =head2 XPK_REPEATED I XPK_REPEATED(pieces ...) A structural type which expects to find zero or more repeats of its contained pieces. This will pass an argument whose I field contains the count of the number of repeats it found. The first piece type within must support probe. =head2 XPK_CHOICE I XPK_CHOICE(options ...) A structural type which expects to find one of a number of alternative options. An ordered list of types is provided, all of which must support probe. This will pass an argument whose I field gives the index of the first choice that was accepted. The first option takes the value 0. As each of the options is interpreted as an alternative, not a sequence, you should use C if a sequence of multiple items should be considered as a single alternative. It is not an error if no choice matches. At that point, the I field will be set to -1. If you require a failure message in this case, set the final choice to be of type C. This will cause an error message to be printed instead. XPK_FAILURE("message string") =head2 XPK_TAGGEDCHOICE I XPK_TAGGEDCHOICE(choice, tag, ...) A structural type similar to C, except that each choice type is followed by an element of type C which gives an integer. It is that integer value, rather than the positional index of the choice within the list, which is passed in the I field. XPK_TAG(value) As each of the options is interpreted as an alternative, not a sequence, you should use C if a sequence of multiple items should be considered as a single alternative. =head2 XPK_COMMALIST I XPK_COMMALIST(pieces ...) A structural type which expects to find one or more repeats of its contained pieces, separated by literal comma (C<,>) characters. This is somewhat similar to C, except that it needs at least one copy, needs commas between its items, but does not require that the first contained piece support probe (the comma itself is sufficient to indicate a repeat). An C supports probe if its first contained piece does; i.e. is transparent to probing. =head2 XPK_PARENSCOPE I XPK_PARENSCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in parentheses as C<( ... )>. This will pass no extra arguments. =head2 XPK_BRACKETSCOPE I XPK_BRACKETSCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in square brackets as C<[ ... ]>. This will pass no extra arguments. =head2 XPK_BRACESCOPE I XPK_BRACESCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in braces as C<{ ... }>. This will pass no extra arguments. Note that this is not necessary to use with C or C; those will already consume a set of braces. This is intended for special constrained syntax that should not just accept an arbitrary block. =head2 XPK_CHEVRONSCOPE I XPK_CHEVRONSCOPE(pieces ...) A structural type which expects to find a sequence of pieces, all contained in angle brackets as C<< < ... > >>. This will pass no extra arguments. Remember that expressions like C<< a > b >> are valid term expressions, so the contents of this scope shouldn't allow arbitrary expressions or the closing bracket will be ambiguous. =head2 XPK_PARENSCOPE_OPT, XPK_BRACKETSCOPE_OPT, XPK_BRACESCOPE_OPT, XPK_CHEVRONSCOPE_OPT I XPK_PARENSCOPE_OPT(pieces ...) XPK_BRACKETSCOPE_OPT(pieces ...) XPK_BRACESCOPE_OPT(pieces ...) XPK_CHEVERONSCOPE_OPT(pieces ...) Each of the four C macros above has an optional variant, whose name is suffixed by C<_OPT>. These pass an argument whose I field is either true or false, indicating whether the scope was found, followed by the values from the scope itself. This is a convenient shortcut to nesting the scope within a C macro. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; XS-Parse-Keyword-0.21/lib/XS/Parse/Keyword.xs000444001750001750 456614131246633 17526 0ustar00leoleo000000000000/* 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 */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "XSParseKeyword.h" #include "XSParseInfix.h" #include "keyword.h" #include "infix.h" /* v0 hooks lacked wrapper_func_name */ struct XSParseInfixHooks_v0 { U32 flags; enum XSParseInfixClassification cls; const char *permit_hintkey; bool (*permit) (pTHX_ void *hookdata); OP *(*new_op)(pTHX_ U32 flags, OP *lhs, OP *rhs, void *hookdata); OP *(*ppaddr)(pTHX); }; static void XSParseInfix_register_v0(pTHX_ const char *opname, const struct XSParseInfixHooks_v0 *hooks_v0, void *hookdata) { struct XSParseInfixHooks *hooks; Newx(hooks, 1, struct XSParseInfixHooks); hooks->flags = hooks_v0->flags; hooks->cls = hooks_v0->cls; hooks->wrapper_func_name = NULL; hooks->permit_hintkey = hooks_v0->permit_hintkey; hooks->permit = hooks_v0->permit; hooks->new_op = hooks_v0->new_op; hooks->ppaddr = hooks_v0->ppaddr; XSParseInfix_register(aTHX_ opname, hooks, hookdata); } MODULE = XS::Parse::Keyword PACKAGE = XS::Parse::Keyword BOOT: /* legacy version0 support */ sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Keyword/ABIVERSION", 1), XSPARSEKEYWORD_ABI_VERSION); /* newer versions */ sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Keyword/ABIVERSION_MIN", 1), 1); sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Keyword/ABIVERSION_MAX", 1), XSPARSEKEYWORD_ABI_VERSION); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Keyword/register()@1", 1), PTR2UV(&XSParseKeyword_register_v1)); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Keyword/register()@2", 1), PTR2UV(&XSParseKeyword_register_v2)); XSParseKeyword_boot(aTHX); sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/ABIVERSION_MIN", 1), 0); sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/ABIVERSION_MAX", 1), XSPARSEINFIX_ABI_VERSION); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/new_op()@0", 1), PTR2UV(&XSParseInfix_new_op)); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/register()@0", 1), PTR2UV(&XSParseInfix_register_v0)); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/register()@1", 1), PTR2UV(&XSParseInfix_register)); XSParseInfix_boot(aTHX); XS-Parse-Keyword-0.21/lib/XS/Parse/Infix000755001750001750 014131246633 16433 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/lib/XS/Parse/Infix/Builder.pm000444001750001750 444714131246633 20525 0ustar00leoleo000000000000# 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 package XS::Parse::Infix::Builder 0.21; use v5.14; use warnings; =head1 NAME C - build-time support for C =head1 SYNOPSIS In F: use XS::Parse::Infix::Builder; my $build = Module::Build->new( ..., configure_requires => { ... 'XS::Parse::Infix::Builder' => 0, } ); XS::Parse::Infix::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::Infix::Builder_data; =head1 FUNCTIONS =cut =head2 write_XSParseInfix_h XS::Parse::Infix::Builder->write_XSParseInfix_h Writes the F file to the current working directory. To cause the compiler to actually find this file, see L. =cut sub write_XSParseInfix_h { shift; open my $out, ">", "XSParseInfix.h" or die "Cannot open XSParseInfix.h for writing - $!\n"; $out->print( XS::Parse::Infix::Builder_data->XSPARSEINFIX_H ); } =head2 extra_compiler_flags @flags = XS::Parse::Infix::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.", XS::Parse::Infix::Builder_data->BUILDER_CFLAGS; } =head2 extend_module_build XS::Parse::Infix::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_XSParseInfix_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; XS-Parse-Keyword-0.21/lib/XS/Parse/Infix/Builder_data.pm.PL000444001750001750 205214131246633 22016 0ustar00leoleo000000000000# 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 $/; my $build = Module::Build->resume; my @ccflags = @{ $build->notes( "builder_cflags" ) }; my $quoted_cflags = join ", ", map { perlstring $_ } @ccflags; $outh->print( scalar do { } =~ s/__BUILDER_CFLAGS__/$quoted_cflags/r ); $outh->print( scalar do { open my $in_h, "<", "XSParseInfix.h" or die "Cannot open XSParseInfix.h - $!"; <$in_h> } ); __DATA__ package XS::Parse::Infix::Builder_data 0.21; use v5.14; use warnings; # Additional CFLAGS arguments to pass during compilation use constant BUILDER_CFLAGS => __BUILDER_CFLAGS__; # The contents of the "XSParseInfix.h" file my $XSParseInfix_h = do { local $/; readline DATA; }; sub XSPARSEINFIX_H() { $XSParseInfix_h } 0x55AA; __DATA__ XS-Parse-Keyword-0.21/lib/XS/Parse/Keyword000755001750001750 014131246633 17002 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/lib/XS/Parse/Keyword/Builder.pm000444001750001750 452514131246633 21071 0ustar00leoleo000000000000# 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 package XS::Parse::Keyword::Builder 0.21; use v5.14; use warnings; =head1 NAME C - build-time support for C =head1 SYNOPSIS In F: use XS::Parse::Keyword::Builder; my $build = Module::Build->new( ..., configure_requires => { ... 'XS::Parse::Keyword::Builder' => 0, } ); XS::Parse::Keyword::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::Keyword::Builder_data; =head1 FUNCTIONS =cut =head2 write_XSParseKeyword_h XS::Parse::Keyword::Builder->write_XSParseKeyword_h Writes the F file to the current working directory. To cause the compiler to actually find this file, see L. =cut sub write_XSParseKeyword_h { shift; open my $out, ">", "XSParseKeyword.h" or die "Cannot open XSParseKeyword.h for writing - $!\n"; $out->print( XS::Parse::Keyword::Builder_data->XSPARSEKEYWORD_H ); } =head2 extra_compiler_flags @flags = XS::Parse::Keyword::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.", XS::Parse::Keyword::Builder_data->BUILDER_CFLAGS; } =head2 extend_module_build XS::Parse::Keyword::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_XSParseKeyword_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; XS-Parse-Keyword-0.21/lib/XS/Parse/Keyword/Builder_data.pm.PL000444001750001750 207014131246633 22365 0ustar00leoleo000000000000# 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 $/; my $build = Module::Build->resume; my @ccflags = @{ $build->notes( "builder_cflags" ) }; my $quoted_cflags = join ", ", map { perlstring $_ } @ccflags; $outh->print( scalar do { } =~ s/__BUILDER_CFLAGS__/$quoted_cflags/r ); $outh->print( scalar do { open my $in_h, "<", "XSParseKeyword.h" or die "Cannot open XSParseKeyword.h - $!"; <$in_h> } ); __DATA__ package XS::Parse::Keyword::Builder_data 0.21; use v5.14; use warnings; # Additional CFLAGS arguments to pass during compilation use constant BUILDER_CFLAGS => __BUILDER_CFLAGS__; # The contents of the "XSParseKeyword.h" file my $XSParseKeyword_h = do { local $/; readline DATA; }; sub XSPARSEKEYWORD_H() { $XSParseKeyword_h } 0x55AA; __DATA__ XS-Parse-Keyword-0.21/src000755001750001750 014131246633 13773 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/src/infix.c000444001750001750 4632214131246633 15440 0ustar00leoleo000000000000/* 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 "XSParseInfix.h" #include "infix.h" #include "perl-backcompat.c.inc" #include "force_list_keeping_pushmark.c.inc" #include "make_argcheck_ops.c.inc" #include "newOP_CUSTOM.c.inc" #include "op_sibling_splice.c.inc" #if HAVE_PERL_VERSION(5,32,0) # define HAVE_OP_ISA #endif #if HAVE_PERL_VERSION(5,22,0) /* assert() can be used as an expression */ # define HAVE_ASSERT_AS_EXPRESSION #endif /* These only became full API macros at perl v5.22, but they're available as * the full Perl_... name before that */ #ifndef block_start # define block_start(a) Perl_block_start(aTHX_ a) #endif #ifndef block_end # define block_end(a,b) Perl_block_end(aTHX_ a,b) #endif #ifndef XS_INTERNAL /* copypasta from perl-v5.16.0/XSUB.h */ # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # if defined(__SYMBIAN32__) # define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) # endif # ifndef XS_INTERNAL # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) # else # ifdef __cplusplus # define XS_INTERNAL(name) static XSPROTO(name) # else # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # endif # endif #endif struct HooksAndData { const struct XSParseInfixHooks *hooks; void *data; }; enum OperandShape { SHAPE_SCALARSCALAR, SHAPE_SCALARLIST, SHAPE_LISTLIST, }; static enum OperandShape operand_shape(const struct HooksAndData *hd) { U8 args_flags = (hd->hooks->lhs_flags & 0x07) << 4 | (hd->hooks->rhs_flags & 0x07); switch(args_flags) { /* scalar OP scalar */ case XPI_OPERAND_TERM: return SHAPE_SCALARSCALAR; /* scalar OP list */ case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: return SHAPE_SCALARLIST; /* list OP list */ case (XPI_OPERAND_TERM_LIST<<4) | XPI_OPERAND_TERM_LIST: case (XPI_OPERAND_TERM_LIST<<4) | XPI_OPERAND_LIST: return SHAPE_LISTLIST; default: croak("TODO: Unsure how to classify operand shape of args_flags=%02X\n", args_flags); break; } } struct Registration; struct Registration { #ifdef HAVE_PL_INFIX_PLUGIN struct Perl_custom_infix def; /* must be first */ #endif struct Registration *next; struct XSParseInfixInfo info; STRLEN oplen; enum XSParseInfixClassification cls; struct HooksAndData hd; STRLEN permit_hintkey_len; int opname_is_WIDE : 1; }; static struct Registration *registrations; static OP *new_op(pTHX_ const struct HooksAndData hd, U32 flags, OP *lhs, OP *rhs) { if(hd.hooks->new_op) return (*hd.hooks->new_op)(aTHX_ flags, lhs, rhs, hd.data); OP *ret = newBINOP_CUSTOM(hd.hooks->ppaddr, flags, lhs, rhs); /* TODO: opchecker? */ return ret; } static bool op_extract_onerefgen(OP *o, OP **kidp) { OP *first; switch(o->op_type) { case OP_SREFGEN: first = cUNOPo->op_first; if(first->op_type == OP_NULL && first->op_targ == OP_LIST && (*kidp = cLISTOPx(first)->op_first)) return TRUE; break; case OP_REFGEN: first = cUNOPo->op_first; if(first->op_type == OP_NULL && first->op_targ == OP_LIST && #ifdef HAVE_ASSERT_AS_EXPRESSION (assert(cLISTOPx(first)->op_first->op_type == OP_PUSHMARK), 1) && #endif (*kidp = OpSIBLING(cLISTOPx(first)->op_first)) && !OpSIBLING(*kidp)) return TRUE; op_dump(first); } return FALSE; } #define unwrap_list(o, may_unwrap_anonlist) S_unwrap_list(aTHX_ o, may_unwrap_anonlist) static OP *S_unwrap_list(pTHX_ OP *o, bool may_unwrap_anonlist) { OP *kid; /* Look out for some sort of \THING */ if(op_extract_onerefgen(o, &kid)) { if(kid->op_type == OP_PADAV) { /* \@padav can just yield the array directly */ cLISTOPx(cUNOPo->op_first)->op_first = NULL; op_free(o); kid->op_flags &= ~(OPf_MOD|OPf_REF); return force_list_keeping_pushmark(kid); } if(kid->op_type == OP_RV2AV) { /* we can just yield this op directly at this point. It might be \@pkgav * or something else, but whatever it is we might as well do it */ cLISTOPx(cUNOPo->op_first)->op_first = NULL; op_free(o); kid->op_flags &= ~(OPf_MOD|OPf_REF); return force_list_keeping_pushmark(kid); } } /* We might be permitted to unwrap a [THING] */ if(may_unwrap_anonlist && o->op_type == OP_ANONLIST) { /* Just turn it into a list and we're already done */ o->op_type = OP_LIST; return force_list_keeping_pushmark(o); } return force_list_keeping_pushmark(newUNOP(OP_RV2AV, 0, o)); } #ifdef HAVE_PL_INFIX_PLUGIN OP *parse(pTHX_ OP *lhs, struct Perl_custom_infix *def) { struct Registration *reg = (struct Registration *)def; switch(reg->hd.hooks->lhs_flags & 0x07) { case XPI_OPERAND_TERM: break; case XPI_OPERAND_TERM_LIST: lhs = force_list_keeping_pushmark(lhs); break; } /* TODO: maybe operator has a 'parse' hook? */ lex_read_space(0); OP *rhs = NULL; switch(reg->hd.hooks->rhs_flags & 0x07) { case XPI_OPERAND_TERM: rhs = parse_termexpr(0); break; case XPI_OPERAND_TERM_LIST: rhs = force_list_keeping_pushmark(parse_termexpr(0)); break; case XPI_OPERAND_LIST: rhs = force_list_keeping_pushmark(parse_listexpr(0)); break; default: croak("hooks->rhs_flags did not provide a valid RHS type"); } return new_op(aTHX_ reg->hd, 0, lhs, rhs); } static STRLEN (*next_infix_plugin)(pTHX_ char *, STRLEN, struct Perl_custom_infix **); static STRLEN my_infix_plugin(pTHX_ char *op, STRLEN oplen, struct Perl_custom_infix **def) { if(PL_parser && PL_parser->error_count) return (*next_infix_plugin)(aTHX_ op, oplen, def); HV *hints = GvHV(PL_hintgv); struct Registration *reg; for(reg = registrations; reg; reg = reg->next) { /* custom registrations have hooks, builtin ones do not */ if(!reg->hd.hooks) continue; if(reg->oplen != oplen || !strEQ(reg->info.opname, op)) continue; if(reg->hd.hooks->permit_hintkey && (!hints || !hv_fetch(hints, reg->hd.hooks->permit_hintkey, reg->permit_hintkey_len, 0))) continue; if(reg->hd.hooks->permit && !(*reg->hd.hooks->permit)(aTHX_ reg->hd.data)) continue; *def = ®->def; return oplen; } return (*next_infix_plugin)(aTHX_ op, oplen, def); } #endif /* What classifications are included in what selections? */ static const U32 infix_selections[] = { [XPI_SELECT_ANY] = 0xFFFFFFFF, [XPI_SELECT_PREDICATE] = (1<bufptr now points exactly at where we expect to find an operator name */ int selection = infix_selections[select]; HV *hints = GvHV(PL_hintgv); const char *buf = PL_parser->bufptr; const STRLEN buflen = PL_parser->bufend - PL_parser->bufptr; struct Registration *reg; for(reg = registrations; reg; reg = reg->next) { if(reg->oplen > buflen) continue; if(!strnEQ(buf, reg->info.opname, reg->oplen)) continue; if(!(selection & (1 << reg->cls))) continue; if(reg->hd.hooks && reg->hd.hooks->permit_hintkey && (!hints || !hv_fetch(hints, reg->hd.hooks->permit_hintkey, reg->permit_hintkey_len, 0))) continue; if(reg->hd.hooks && reg->hd.hooks->permit && !(*reg->hd.hooks->permit)(aTHX_ reg->hd.data)) continue; *infop = ®->info; lex_read_to(PL_parser->bufptr + reg->oplen); return TRUE; } return FALSE; } OP *XSParseInfix_new_op(pTHX_ const struct XSParseInfixInfo *info, U32 flags, OP *lhs, OP *rhs) { if(info->opcode == OP_CUSTOM) return new_op(aTHX_ (struct HooksAndData) { .hooks = info->hooks, .data = info->hookdata, }, flags, lhs, rhs); return newBINOP(info->opcode, flags, lhs, rhs); } static bool op_yields_oneval(OP *o) { if(OP_GIMME(o, 0) == G_SCALAR) return TRUE; if(PL_opargs[o->op_type] & OA_RETSCALAR) return TRUE; /* It might still yield a single value, we'll just have to check harder */ switch(o->op_type) { case OP_REFGEN: { OP *list = cUNOPo->op_first; OP *kid; assert(cLISTOPx(list)->op_first->op_type == OP_PUSHMARK); if((kid = OpSIBLING(cLISTOPx(list)->op_first)) && !OpSIBLING(kid) && (kid->op_flags & OPf_REF)) return TRUE; } } return FALSE; } static bool extract_wrapper2_args(pTHX_ OP *op, OP **leftp, OP **rightp) { assert(op->op_type == OP_ENTERSUB); /* Attempt to extract the LHS and RHS operands, if we can find them */ OP *kid = cUNOPx(op)->op_first; /* The first kid is usually an ex-list whose ->op_first begins the actual args list */ if(kid->op_type == OP_NULL && kid->op_targ == OP_LIST) kid = cUNOPx(kid)->op_first; assert(kid->op_type == OP_PUSHMARK); OP *pushmark = kid; OP *left = OpSIBLING(kid); if(!left) return FALSE; if(!op_yields_oneval(left)) return FALSE; OP *right = OpSIBLING(left); if(!right) return FALSE; if(!op_yields_oneval(right)) return FALSE; kid = OpSIBLING(right); if(!kid) return FALSE; if(OpSIBLING(kid)) return FALSE; /* Check that kid is now OP_NULL[ OP_GV ] */ if(kid->op_type != OP_NULL || kid->op_targ != OP_RV2CV) return FALSE; if(cUNOPx(kid)->op_first->op_type != OP_GV) return FALSE; /* Splice out these two args and throw away the old optree */ OpMORESIB_set(left, NULL); OpMORESIB_set(right, NULL); OpMORESIB_set(pushmark, kid); op_free(op); OpLASTSIB_set(left, NULL); OpLASTSIB_set(right, NULL); *leftp = left; *rightp = right; return TRUE; } static OP *ckcall_wrapper_func_scalarscalar(pTHX_ OP *op, GV *namegv, SV *ckobj) { struct HooksAndData *hd = NUM2PTR(struct HooksAndData *, SvUV(ckobj)); OP *left, *right; if(!extract_wrapper2_args(aTHX_ op, &left, &right)) return op; return new_op(aTHX_ *hd, 0, left, right); } static OP *ckcall_wrapper_func_listlist(pTHX_ OP *op, GV *namegv, SV *ckobj) { struct HooksAndData *hd = NUM2PTR(struct HooksAndData *, SvUV(ckobj)); OP *left, *right; if(!extract_wrapper2_args(aTHX_ op, &left, &right)) return op; return new_op(aTHX_ *hd, 0, unwrap_list(left, hd->hooks->lhs_flags & XPI_OPERAND_ONLY_LOOK), unwrap_list(right, hd->hooks->rhs_flags & XPI_OPERAND_ONLY_LOOK)); } #define newSLUGOP(idx) S_newSLUGOP(aTHX_ idx) static OP *S_newSLUGOP(pTHX_ int idx) { OP *op = newGVOP(OP_AELEMFAST, 0, PL_defgv); op->op_private = idx; return op; } static void make_wrapper_func(pTHX_ const struct HooksAndData *hd) { /* Prepare to make a new optree-based CV */ I32 floor_ix = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); SV *funcname = newSVpvn(hd->hooks->wrapper_func_name, strlen(hd->hooks->wrapper_func_name)); I32 save_ix = block_start(TRUE); OP *body = NULL; OP *(*ckcall)(pTHX_ OP *, GV *, SV *) = NULL; switch(operand_shape(hd)) { case SHAPE_SCALARSCALAR: body = op_append_list(OP_LINESEQ, body, make_argcheck_ops(2, 0, 0, funcname)); body = op_append_list(OP_LINESEQ, body, newSTATEOP(0, NULL, NULL)); /* Body of the function is just $_[0] OP $_[1] */ body = op_append_list(OP_LINESEQ, body, new_op(aTHX_ *hd, 0, newSLUGOP(0), newSLUGOP(1))); ckcall = &ckcall_wrapper_func_scalarscalar; break; case SHAPE_SCALARLIST: body = op_append_list(OP_LINESEQ, body, make_argcheck_ops(1, 0, '@', funcname)); body = op_append_list(OP_LINESEQ, body, newSTATEOP(0, NULL, NULL)); /* Body of the function is just shift OP @_ */ body = op_append_list(OP_LINESEQ, body, new_op(aTHX_ *hd, 0, newOP(OP_SHIFT, 0), force_list_keeping_pushmark(newUNOP(OP_RV2AV, OPf_WANT_LIST, newGVOP(OP_GV, 0, PL_defgv))))); /* no ckcall */ break; case SHAPE_LISTLIST: body = op_append_list(OP_LINESEQ, body, make_argcheck_ops(2, 0, 0, funcname)); body = op_append_list(OP_LINESEQ, body, newSTATEOP(0, NULL, NULL)); /* Body of the function is @{ $_[0] } OP @{ $_[1] } */ body = op_append_list(OP_LINESEQ, body, new_op(aTHX_ *hd, 0, force_list_keeping_pushmark(newUNOP(OP_RV2AV, 0, newSLUGOP(0))), force_list_keeping_pushmark(newUNOP(OP_RV2AV, 0, newSLUGOP(1))))); ckcall = &ckcall_wrapper_func_listlist; break; } SvREFCNT_inc(PL_compcv); body = block_end(save_ix, body); CV *cv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, funcname), NULL, NULL, body); if(ckcall) cv_set_call_checker(cv, ckcall, newSVuv(PTR2UV(hd))); } XS_INTERNAL(deparse_infix); XS_INTERNAL(deparse_infix) { dXSARGS; struct Registration *reg = XSANY.any_ptr; SV *deparseobj = ST(0); SV *ret; #ifdef HAVE_PL_INFIX_PLUGIN SV **hinthashsvp = hv_fetchs(MUTABLE_HV(SvRV(deparseobj)), "hinthash", 0); HV *hinthash = hinthashsvp ? MUTABLE_HV(SvRV(*hinthashsvp)) : NULL; if(hinthash && hv_fetch(hinthash, reg->hd.hooks->permit_hintkey, reg->permit_hintkey_len, 0)) { ENTER; SAVETMPS; EXTEND(SP, 4); PUSHMARK(SP); PUSHs(deparseobj); mPUSHs(newSVpvn_flags(reg->info.opname, reg->oplen, reg->opname_is_WIDE ? SVf_UTF8 : 0)); PUSHs(ST(1)); PUSHs(ST(2)); PUTBACK; call_method("_deparse_infix_named", G_SCALAR); SPAGAIN; ret = SvREFCNT_inc(POPs); FREETMPS; LEAVE; } else #endif { ENTER; SAVETMPS; EXTEND(SP, 4); PUSHMARK(SP); PUSHs(deparseobj); mPUSHp(reg->hd.hooks->wrapper_func_name, strlen(reg->hd.hooks->wrapper_func_name)); PUSHs(ST(1)); PUSHs(ST(2)); PUTBACK; switch(operand_shape(®->hd)) { case SHAPE_SCALARSCALAR: case SHAPE_SCALARLIST: /* not really */ call_method("_deparse_infix_wrapperfunc_scalarscalar", G_SCALAR); break; case SHAPE_LISTLIST: call_method("_deparse_infix_wrapperfunc_listlist", G_SCALAR); break; } SPAGAIN; ret = SvREFCNT_inc(POPs); FREETMPS; LEAVE; } ST(0) = sv_2mortal(ret); XSRETURN(1); } static void reg_builtin(pTHX_ const char *opname, enum XSParseInfixClassification cls, OPCODE opcode) { struct Registration *reg; Newx(reg, 1, struct Registration); reg->info.opname = savepv(opname); reg->info.opcode = opcode; reg->info.hooks = NULL; reg->oplen = strlen(opname); reg->cls = cls; reg->hd.hooks = NULL; reg->hd.data = NULL; reg->permit_hintkey_len = 0; { reg->next = registrations; registrations = reg; } } void XSParseInfix_register(pTHX_ const char *opname, const struct XSParseInfixHooks *hooks, void *hookdata) { switch(hooks->flags) { case 0: break; default: croak("Unrecognised XSParseInfixHooks.flags value 0x%X", hooks->flags); } switch(hooks->lhs_flags & ~(XPI_OPERAND_ONLY_LOOK)) { case XPI_OPERAND_TERM: case XPI_OPERAND_TERM_LIST: break; default: croak("Unrecognised XSParseInfixHooks.lhs_flags value 0x%X", hooks->lhs_flags); } switch(hooks->rhs_flags & ~(XPI_OPERAND_ONLY_LOOK)) { case XPI_OPERAND_TERM: case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: break; default: croak("Unrecognised XSParseInfixHooks.rhs_flags value 0x%X", hooks->rhs_flags); } struct Registration *reg; Newx(reg, 1, struct Registration); #ifdef HAVE_PL_INFIX_PLUGIN reg->def.parse = &parse; #endif reg->info.opname = savepv(opname); reg->info.opcode = OP_CUSTOM; reg->info.hooks = hooks; reg->info.hookdata = hookdata; reg->oplen = strlen(opname); reg->cls = hooks->cls; reg->hd.hooks = hooks; reg->hd.data = hookdata; reg->opname_is_WIDE = FALSE; int i; for(i = 0; i < reg->oplen; i++) { if(opname[i] & 0x80) { reg->opname_is_WIDE = TRUE; break; } } if(hooks->permit_hintkey) reg->permit_hintkey_len = strlen(hooks->permit_hintkey); else reg->permit_hintkey_len = 0; { reg->next = registrations; registrations = reg; } if(hooks->wrapper_func_name) { make_wrapper_func(aTHX_ ®->hd); } if(hooks->ppaddr) { XOP *xop; Newx(xop, 1, XOP); /* Use both the opname for human-readability, and the address of its * ppfunc for disambiguating in case of name clashes */ SV *namesv = newSVpvf("B::Deparse::pp_infix_%s_0x%p", opname, hooks->ppaddr); if(reg->opname_is_WIDE) SvUTF8_on(namesv); SAVEFREESV(namesv); XopENTRY_set(xop, xop_name, savepv(SvPVX(namesv) + sizeof("B::Deparse::pp"))); XopENTRY_set(xop, xop_desc, "custom infix operator"); XopENTRY_set(xop, xop_class, OA_BINOP); XopENTRY_set(xop, xop_peep, NULL); Perl_custom_op_register(aTHX_ hooks->ppaddr, xop); CV *cv = newXS(SvPVX(namesv), deparse_infix, __FILE__); CvXSUBANY(cv).any_ptr = reg; load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("XS::Parse::Infix"), NULL); } } void XSParseInfix_boot(pTHX) { /* stringy relations */ reg_builtin(aTHX_ "eq", XPI_CLS_EQUALITY, OP_SEQ); reg_builtin(aTHX_ "ne", XPI_CLS_RELATION, OP_SNE); reg_builtin(aTHX_ "lt", XPI_CLS_RELATION, OP_SLT); reg_builtin(aTHX_ "le", XPI_CLS_RELATION, OP_SLE); reg_builtin(aTHX_ "ge", XPI_CLS_RELATION, OP_SGE); reg_builtin(aTHX_ "gt", XPI_CLS_RELATION, OP_SGT); reg_builtin(aTHX_ "cmp", XPI_CLS_ORDERING, OP_SCMP); /* numerical relations */ reg_builtin(aTHX_ "==", XPI_CLS_EQUALITY, OP_EQ); reg_builtin(aTHX_ "!=", XPI_CLS_RELATION, OP_NE); reg_builtin(aTHX_ "<", XPI_CLS_RELATION, OP_LT); reg_builtin(aTHX_ "<=", XPI_CLS_RELATION, OP_LE); reg_builtin(aTHX_ ">=", XPI_CLS_RELATION, OP_GE); reg_builtin(aTHX_ ">", XPI_CLS_RELATION, OP_GT); reg_builtin(aTHX_ "<=>", XPI_CLS_ORDERING, OP_NCMP); /* other predicates */ reg_builtin(aTHX_ "~~", XPI_CLS_SMARTMATCH, OP_SMARTMATCH); reg_builtin(aTHX_ "=~", XPI_CLS_MATCHRE, OP_MATCH); /* TODO: !~ */ #ifdef HAVE_OP_ISA reg_builtin(aTHX_ "isa", XPI_CLS_ISA, OP_ISA); #endif /* TODO: * Other numerics * + - * / % ** * << >> * * Bitwise * & | ^ * Stringwise * &. |. ^. * * Boolean * && || // */ HV *stash = gv_stashpvs("XS::Parse::Infix", TRUE); newCONSTSUB(stash, "HAVE_PL_INFIX_PLUGIN", boolSV( #ifdef HAVE_PL_INFIX_PLUGIN TRUE #else FALSE #endif )); #ifdef HAVE_PL_INFIX_PLUGIN OP_CHECK_MUTEX_LOCK; if(!next_infix_plugin) { next_infix_plugin = PL_infix_plugin; PL_infix_plugin = &my_infix_plugin; } OP_CHECK_MUTEX_UNLOCK; #endif } XS-Parse-Keyword-0.21/src/infix.h000444001750001750 51714131246633 15401 0ustar00leoleo000000000000bool XSParseInfix_parse(pTHX_ enum XSParseInfixSelection select, struct XSParseInfixInfo **infop); OP *XSParseInfix_new_op(pTHX_ const struct XSParseInfixInfo *info, U32 flags, OP *lhs, OP *rhs); void XSParseInfix_register(pTHX_ const char *opname, const struct XSParseInfixHooks *hooks, void *hookdata); void XSParseInfix_boot(pTHX); XS-Parse-Keyword-0.21/src/keyword.c000444001750001750 5344514131246633 16013 0ustar00leoleo000000000000/* 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 */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "XSParseKeyword.h" #include "XSParseInfix.h" #include "keyword.h" #include "infix.h" #include "perl-backcompat.c.inc" #ifndef wrap_keyword_plugin # include "wrap_keyword_plugin.c.inc" #endif #include "lexer-additions.c.inc" /* yycroak() is a long function and hard to emulate or copy-paste for our * purposes; we'll reïmplement a smaller version of it * * ours will croak instead of warn */ #define LEX_IGNORE_UTF8_HINTS 0x00000002 #define PL_linestr (PL_parser->linestr) #ifdef USE_UTF8_SCRIPTS # define UTF cBOOL(!IN_BYTES) #elif HAVE_PERL_VERSION(5, 16, 0) # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8))) #else # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) #endif #if HAVE_PERL_VERSION(5, 20, 0) # define HAVE_UTF8f #endif #define yycroak(s) S_yycroak(aTHX_ s) static void S_yycroak(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) #ifdef HAVE_UTF8f sv_catpvf(message, ", near \"%" UTF8f "\"", UTF8fARG(UTF, contlen, context)); #else sv_catpvf(message, ", near \"%" SVf "\"", SVfARG(newSVpvn_flags(context, contlen, SVs_TEMP | (UTF ? SVf_UTF8 : 0)))); #endif sv_catpvf(message, "\n"); PL_parser->error_count++; croak_sv(message); } #define yycroakf(fmt, ...) yycroak(Perl_form(aTHX_ fmt, __VA_ARGS__)) #define lex_expect_unichar(c) MY_lex_expect_unichar(aTHX_ c) void MY_lex_expect_unichar(pTHX_ int c) { if(lex_peek_unichar(0) != c) /* TODO: A slightly different message if c == '\'' */ yycroakf("Expected '%c'", c); lex_read_unichar(0); } #define CHECK_PARSEFAIL \ if(PL_parser->error_count) \ croak("parse failed--compilation aborted") /* TODO: Only ASCII */ #define lex_probe_str(s) MY_lex_probe_str(aTHX_ s) STRLEN MY_lex_probe_str(pTHX_ const char *s) { STRLEN i; for(i = 0; s[i]; i++) { if(s[i] != PL_parser->bufptr[i]) return 0; } return i; } #define lex_expect_str(s) MY_lex_expect_str(aTHX_ s) void MY_lex_expect_str(pTHX_ const char *s) { STRLEN len = lex_probe_str(s); if(!len) yycroakf("Expected \"%s\"", s); lex_read_to(PL_parser->bufptr + len); } struct Registration; struct Registration { struct Registration *next; const char *kwname; STRLEN kwlen; int apiver; const struct XSParseKeywordHooks *hooks; void *hookdata; STRLEN permit_hintkey_len; }; /* version 1's struct did not have the line on it */ typedef struct { union { OP *op; CV *cv; SV *sv; int i; struct { SV *name; SV *value; } attr; PADOFFSET padix; }; } XSParseKeywordPiece_v1; static bool probe_piece(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *piece, void *hookdata); static void parse_piece(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *piece, void *hookdata); static void parse_pieces(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *pieces, void *hookdata); static bool probe_piece(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *piece, void *hookdata) { int argi = *argidx; if(argi >= (SvLEN(argsv) / sizeof(XSParseKeywordPiece))) SvGROW(argsv, SvLEN(argsv) * 2); #define THISARG ((XSParseKeywordPiece *)SvPVX(argsv))[argi] THISARG.line = #if HAVE_PERL_VERSION(5, 20, 0) /* on perl 5.20 onwards, CopLINE(PL_curcop) is only set at runtime; during * parse the parser stores the line number directly */ (PL_parser->preambling != NOLINE) ? PL_parser->preambling : #endif CopLINE(PL_curcop); U32 type = piece->type & 0xFFFF; switch(type) { case XS_PARSE_KEYWORD_LITERALCHAR: if(lex_peek_unichar(0) != piece->u.c) return FALSE; lex_read_unichar(0); lex_read_space(0); return TRUE; case XS_PARSE_KEYWORD_LITERALSTR: { STRLEN len = lex_probe_str(piece->u.str); if(!len) return FALSE; lex_read_to(PL_parser->bufptr + len); lex_read_space(0); return TRUE; } case XS_PARSE_KEYWORD_FAILURE: yycroak(piece->u.str); NOT_REACHED; case XS_PARSE_KEYWORD_BLOCK: if(lex_peek_unichar(0) != '{') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_IDENT: THISARG.sv = lex_scan_ident(); if(!THISARG.sv) return FALSE; (*argidx)++; return TRUE; case XS_PARSE_KEYWORD_PACKAGENAME: THISARG.sv = lex_scan_packagename(); if(!THISARG.sv) return FALSE; (*argidx)++; return TRUE; case XS_PARSE_KEYWORD_VSTRING: THISARG.sv = lex_scan_version(PARSE_OPTIONAL); if(!THISARG.sv) return FALSE; (*argidx)++; return TRUE; case XS_PARSE_KEYWORD_INFIX: { if(!XSParseInfix_parse(aTHX_ piece->u.c, &THISARG.infix)) return FALSE; (*argidx)++; return TRUE; } case XS_PARSE_KEYWORD_SETUP: croak("ARGH probe_piece() should never see XS_PARSE_KEYWORD_SETUP!"); case XS_PARSE_KEYWORD_SEQUENCE: { const struct XSParseKeywordPieceType *pieces = piece->u.pieces; if(!probe_piece(aTHX_ argsv, argidx, pieces++, hookdata)) return FALSE; parse_pieces(aTHX_ argsv, argidx, pieces, hookdata); return TRUE; } case XS_PARSE_KEYWORD_CHOICE: { const struct XSParseKeywordPieceType *choices = piece->u.pieces; THISARG.i = 0; (*argidx)++; /* tentative */ while(choices->type) { if(probe_piece(aTHX_ argsv, argidx, choices + 0, hookdata)) { return TRUE; } choices++; THISARG.i++; } (*argidx)--; return FALSE; } case XS_PARSE_KEYWORD_TAGGEDCHOICE: { const struct XSParseKeywordPieceType *choices = piece->u.pieces; (*argidx)++; /* tentative */ while(choices->type) { if(probe_piece(aTHX_ argsv, argidx, choices + 0, hookdata)) { THISARG.i = choices[1].type; return TRUE; } choices += 2; } (*argidx)--; return FALSE; } case XS_PARSE_KEYWORD_SEPARATEDLIST: { const struct XSParseKeywordPieceType *pieces = piece->u.pieces; (*argidx)++; /* tentative */ if(!probe_piece(aTHX_ argsv, argidx, pieces + 1, hookdata)) { (*argidx)--; return FALSE; } /* we're now committed */ THISARG.i = 1; if(pieces[2].type) parse_pieces(aTHX_ argsv, argidx, pieces + 2, hookdata); if(!probe_piece(aTHX_ argsv, argidx, pieces + 0, hookdata)) return TRUE; while(1) { parse_pieces(aTHX_ argsv, argidx, pieces + 1, hookdata); THISARG.i++; if(!probe_piece(aTHX_ argsv, argidx, pieces + 0, hookdata)) break; } return TRUE; } case XS_PARSE_KEYWORD_PARENSCOPE: if(lex_peek_unichar(0) != '(') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_BRACKETSCOPE: if(lex_peek_unichar(0) != '[') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_BRACESCOPE: if(lex_peek_unichar(0) != '{') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_CHEVRONSCOPE: if(lex_peek_unichar(0) != '<') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; } croak("TODO: probe_piece on type=%d\n", type); } static void parse_piece(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *piece, void *hookdata) { int argi = *argidx; if(argi >= (SvLEN(argsv) / sizeof(XSParseKeywordPiece))) SvGROW(argsv, SvLEN(argsv) * 2); #define THISARG ((XSParseKeywordPiece *)SvPVX(argsv))[argi] THISARG.line = #if HAVE_PERL_VERSION(5, 20, 0) /* on perl 5.20 onwards, CopLINE(PL_curcop) is only set at runtime; during * parse the parser stores the line number directly */ (PL_parser->preambling != NOLINE) ? PL_parser->preambling : #endif CopLINE(PL_curcop); bool is_optional = !!(piece->type & XPK_TYPEFLAG_OPT); bool is_special = !!(piece->type & XPK_TYPEFLAG_SPECIAL); U8 want = 0; switch(piece->type & (3 << 18)) { case XPK_TYPEFLAG_G_VOID: want = G_VOID; break; case XPK_TYPEFLAG_G_SCALAR: want = G_SCALAR; break; case XPK_TYPEFLAG_G_LIST: want = G_LIST; break; } bool is_enterleave = !!(piece->type & XPK_TYPEFLAG_ENTERLEAVE); U32 type = piece->type & 0xFFFF; switch(type) { case 0: return; case XS_PARSE_KEYWORD_LITERALCHAR: lex_expect_unichar(piece->u.c); return; case XS_PARSE_KEYWORD_LITERALSTR: lex_expect_str(piece->u.str); return; case XS_PARSE_KEYWORD_FAILURE: yycroak(piece->u.str); NOT_REACHED; case XS_PARSE_KEYWORD_BLOCK: { if(is_enterleave) ENTER; I32 save_ix = block_start(1); if(piece->u.pieces) { /* The prefix pieces */ const struct XSParseKeywordPieceType *pieces = piece->u.pieces; while(pieces->type) { if(pieces->type == XS_PARSE_KEYWORD_SETUP) (pieces->u.callback)(aTHX_ hookdata); else { parse_piece(aTHX_ argsv, argidx, pieces, hookdata); lex_read_space(0); } pieces++; } if(*argidx > argi) { argi = *argidx; if(argi >= (SvLEN(argsv) / sizeof(XSParseKeywordPiece))) SvGROW(argsv, SvLEN(argsv) * 2); intro_my(); /* in case any of the pieces was XPK_LEXVAR_MY */ } } /* TODO: Can we name the syntax keyword here to make a better message? */ if(lex_peek_unichar(0) != '{') yycroak("Expected a block"); OP *body = parse_block(0); CHECK_PARSEFAIL; THISARG.op = block_end(save_ix, body); if(is_special) THISARG.op = op_scope(THISARG.op); if(want) THISARG.op = op_contextualize(THISARG.op, want); (*argidx)++; if(is_enterleave) LEAVE; return; } case XS_PARSE_KEYWORD_ANONSUB: { I32 floor_ix = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); I32 save_ix = block_start(0); OP *body = parse_block(0); CHECK_PARSEFAIL; SvREFCNT_inc(PL_compcv); body = block_end(save_ix, body); THISARG.cv = newATTRSUB(floor_ix, NULL, NULL, NULL, body); (*argidx)++; return; } case XS_PARSE_KEYWORD_TERMEXPR: /* TODO: This auto-parens behaviour ought to be tuneable, depend on how * many args, open at i=0 and close at i=MAX, etc... */ if(lex_peek_unichar(0) == '(') { /* consume a fullexpr and stop at the close paren */ lex_read_unichar(0); THISARG.op = parse_fullexpr(0); CHECK_PARSEFAIL; lex_read_space(0); lex_expect_unichar(')'); } else { THISARG.op = parse_termexpr(0); CHECK_PARSEFAIL; } if(want) THISARG.op = op_contextualize(THISARG.op, want); (*argidx)++; return; case XS_PARSE_KEYWORD_LISTEXPR: THISARG.op = parse_listexpr(0); CHECK_PARSEFAIL; if(want) THISARG.op = op_contextualize(THISARG.op, want); (*argidx)++; return; case XS_PARSE_KEYWORD_IDENT: THISARG.sv = lex_scan_ident(); if(!THISARG.sv && !is_optional) yycroak("Expected an identifier"); (*argidx)++; return; case XS_PARSE_KEYWORD_PACKAGENAME: THISARG.sv = lex_scan_packagename(); if(!THISARG.sv && !is_optional) yycroak("Expected a package name"); (*argidx)++; return; case XS_PARSE_KEYWORD_LEXVARNAME: case XS_PARSE_KEYWORD_LEXVAR: { /* name vs. padix begin with similar structure */ SV *varname = lex_scan_lexvar(); switch(SvPVX(varname)[0]) { case '$': if(!(piece->u.c & XPK_LEXVAR_SCALAR)) yycroak("Lexical scalars are not permitted"); break; case '@': if(!(piece->u.c & XPK_LEXVAR_ARRAY)) yycroak("Lexical arrays are not permitted"); break; case '%': if(!(piece->u.c & XPK_LEXVAR_HASH)) yycroak("Lexical hashes are not permitted"); break; } if(type == XS_PARSE_KEYWORD_LEXVARNAME) { THISARG.sv = varname; (*argidx)++; return; } SAVEFREESV(varname); /* Forbid $_ / @_ / %_ */ if(SvCUR(varname) == 2 && SvPVX(varname)[1] == '_') yycroakf("Can't use global %s in \"my\"", SvPVX(varname)); if(is_special) THISARG.padix = pad_add_name_pvn(SvPVX(varname), SvCUR(varname), 0, NULL, NULL); else yycroak("TODO: XS_PARSE_KEYWORD_LEXVAR without LEXVAR_MY"); (*argidx)++; return; } case XS_PARSE_KEYWORD_ATTRS: { THISARG.i = 0; (*argidx)++; if(lex_peek_unichar(0) == ':') { lex_read_unichar(0); lex_read_space(0); SV *attrname = newSV(0), *attrval = newSV(0); SAVEFREESV(attrname); SAVEFREESV(attrval); while(lex_scan_attrval_into(attrname, attrval)) { lex_read_space(0); if(*argidx >= (SvLEN(argsv) / sizeof(XSParseKeywordPiece))) SvGROW(argsv, SvLEN(argsv) * 2); XSParseKeywordPiece *arg = &((XSParseKeywordPiece *)SvPVX(argsv))[*argidx]; arg->attr.name = newSVsv(attrname); arg->attr.value = newSVsv(attrval); THISARG.i++; (*argidx)++; /* Accept additional colons to prefix additional attrs, but do not require them */ if(lex_peek_unichar(0) == ':') { lex_read_unichar(0); lex_read_space(0); } } } return; } case XS_PARSE_KEYWORD_VSTRING: THISARG.sv = lex_scan_version(is_optional ? PARSE_OPTIONAL : 0); (*argidx)++; return; case XS_PARSE_KEYWORD_INFIX: { if(!XSParseInfix_parse(aTHX_ piece->u.c, &THISARG.infix)) yycroak("Expected an infix operator"); (*argidx)++; return; } case XS_PARSE_KEYWORD_SETUP: croak("ARGH parse_piece() should never see XS_PARSE_KEYWORD_SETUP!"); case XS_PARSE_KEYWORD_SEQUENCE: { const struct XSParseKeywordPieceType *pieces = piece->u.pieces; if(is_optional) { THISARG.i = 0; (*argidx)++; if(!probe_piece(aTHX_ argsv, argidx, pieces, hookdata)) return; THISARG.i++; pieces++; } parse_pieces(aTHX_ argsv, argidx, pieces, hookdata); return; } case XS_PARSE_KEYWORD_REPEATED: THISARG.i = 0; (*argidx)++; while(probe_piece(aTHX_ argsv, argidx, piece->u.pieces + 0, hookdata)) { THISARG.i++; parse_pieces(aTHX_ argsv, argidx, piece->u.pieces + 1, hookdata); } return; case XS_PARSE_KEYWORD_CHOICE: case XS_PARSE_KEYWORD_TAGGEDCHOICE: if(!probe_piece(aTHX_ argsv, argidx, piece, hookdata)) { THISARG.i = -1; (*argidx)++; } return; case XS_PARSE_KEYWORD_SEPARATEDLIST: THISARG.i = 0; (*argidx)++; while(1) { parse_pieces(aTHX_ argsv, argidx, piece->u.pieces + 1, hookdata); THISARG.i++; if(!probe_piece(aTHX_ argsv, argidx, piece->u.pieces + 0, hookdata)) break; } return; case XS_PARSE_KEYWORD_PARENSCOPE: if(is_optional) { THISARG.i = 0; (*argidx)++; if(lex_peek_unichar(0) != '(') return; THISARG.i++; } lex_expect_unichar('('); lex_read_space(0); parse_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); lex_expect_unichar(')'); return; case XS_PARSE_KEYWORD_BRACKETSCOPE: if(is_optional) { THISARG.i = 0; (*argidx)++; if(lex_peek_unichar(0) != '[') return; THISARG.i++; } lex_expect_unichar('['); lex_read_space(0); parse_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); lex_expect_unichar(']'); return; case XS_PARSE_KEYWORD_BRACESCOPE: if(is_optional) { THISARG.i = 0; (*argidx)++; if(lex_peek_unichar(0) != '{') return; THISARG.i++; } lex_expect_unichar('{'); lex_read_space(0); parse_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); lex_expect_unichar('}'); return; case XS_PARSE_KEYWORD_CHEVRONSCOPE: if(is_optional) { THISARG.i = 0; (*argidx)++; if(lex_peek_unichar(0) != '<') return; THISARG.i++; } lex_expect_unichar('<'); lex_read_space(0); parse_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); lex_expect_unichar('>'); return; } croak("TODO: parse_piece on type=%d\n", type); } static void parse_pieces(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *pieces, void *hookdata) { size_t idx; for(idx = 0; pieces[idx].type; idx++) { parse_piece(aTHX_ argsv, argidx, pieces + idx, hookdata); lex_read_space(0); } } static int parse(pTHX_ OP **op, struct Registration *reg) { const struct XSParseKeywordHooks *hooks = reg->hooks; if(hooks->parse) return (*hooks->parse)(aTHX_ op, reg->hookdata); /* parse in pieces */ /* use the PV buffer of this SV as a growable array of args */ size_t maxargs = 4; SV *argsv = newSV(maxargs * sizeof(XSParseKeywordPiece)); SAVEFREESV(argsv); size_t argidx = 0; if(hooks->build) parse_pieces(aTHX_ argsv, &argidx, hooks->pieces, reg->hookdata); else parse_piece(aTHX_ argsv, &argidx, &hooks->piece1, reg->hookdata); if(hooks->flags & XPK_FLAG_AUTOSEMI) { lex_read_space(0); int c = lex_peek_unichar(0); if(c == ';') lex_read_unichar(0); else if(!c || c == '}') ; /* all is good */ else yycroak("Expected: ';' or end of block"); } XSParseKeywordPiece *args = (XSParseKeywordPiece *)SvPVX(argsv); int ret; if(hooks->build) { /* build function takes an array of pointers to piece structs, so we can * add new fields to the end of them without breaking back-compat. */ SV *ptrssv = newSV(argidx * sizeof(XSParseKeywordPiece *)); XSParseKeywordPiece **argptrs = (XSParseKeywordPiece **)SvPVX(ptrssv); SAVEFREESV(ptrssv); int i; for(i = 0; i < argidx; i++) argptrs[i] = &args[i]; ret = (*hooks->build)(aTHX_ op, argptrs, argidx, reg->hookdata); } else if(reg->apiver < 2) { /* version 1 ->build1 used to take a struct directly, not a pointer thereto */ int (*v1_build1)(pTHX_ OP **out, XSParseKeywordPiece_v1 arg0, void *hookdata) = (int (*)())hooks->build1; XSParseKeywordPiece_v1 arg0_v1; Copy(args + 0, &arg0_v1, 1, XSParseKeywordPiece_v1); ret = (*v1_build1)(aTHX_ op, arg0_v1, reg->hookdata); } else ret = (*hooks->build1)(aTHX_ op, args + 0, reg->hookdata); switch(hooks->flags & (XPK_FLAG_EXPR|XPK_FLAG_STMT)) { case XPK_FLAG_EXPR: if(ret && (ret != KEYWORD_PLUGIN_EXPR)) yycroakf("Expected parse function for '%s' keyword to return KEYWORD_PLUGIN_EXPR but it did not", reg->kwname); case XPK_FLAG_STMT: if(ret && (ret != KEYWORD_PLUGIN_STMT)) yycroakf("Expected parse function for '%s' keyword to return KEYWORD_PLUGIN_STMT but it did not", reg->kwname); } return ret; } static struct Registration *registrations; static void reg(pTHX_ const char *kwname, int apiver, const struct XSParseKeywordHooks *hooks, void *hookdata) { if(!hooks->build1 && !hooks->build && !hooks->parse) croak("struct XSParseKeywordHooks requires either a .build1, a .build, or .parse stage"); struct Registration *reg; Newx(reg, 1, struct Registration); reg->kwname = savepv(kwname); reg->kwlen = strlen(kwname); reg->apiver = apiver; reg->hooks = hooks; reg->hookdata = hookdata; if(hooks->permit_hintkey) reg->permit_hintkey_len = strlen(hooks->permit_hintkey); { reg->next = registrations; registrations = reg; } } void XSParseKeyword_register_v1(pTHX_ const char *kwname, const struct XSParseKeywordHooks *hooks, void *hookdata) { reg(aTHX_ kwname, 1, hooks, hookdata); } void XSParseKeyword_register_v2(pTHX_ const char *kwname, const struct XSParseKeywordHooks *hooks, void *hookdata) { reg(aTHX_ kwname, 2, hooks, hookdata); } static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); static int my_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op) { if(PL_parser && PL_parser->error_count) return (*next_keyword_plugin)(aTHX_ kw, kwlen, op); HV *hints = GvHV(PL_hintgv); struct Registration *reg; for(reg = registrations; reg; reg = reg->next) { if(reg->kwlen != kwlen || !strEQ(reg->kwname, 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; if(reg->hooks->check) (*reg->hooks->check)(aTHX_ reg->hookdata); *op = NULL; lex_read_space(0); int ret = parse(aTHX_ op, reg); lex_read_space(0); if(ret && !*op) *op = newOP(OP_NULL, 0); return ret; } return (*next_keyword_plugin)(aTHX_ kw, kwlen, op); } void XSParseKeyword_boot(pTHX) { wrap_keyword_plugin(&my_keyword_plugin, &next_keyword_plugin); } XS-Parse-Keyword-0.21/src/keyword.h000444001750001750 41014131246633 15740 0ustar00leoleo000000000000void XSParseKeyword_register_v1(pTHX_ const char *kwname, const struct XSParseKeywordHooks *hooks, void *hookdata); void XSParseKeyword_register_v2(pTHX_ const char *kwname, const struct XSParseKeywordHooks *hooks, void *hookdata); void XSParseKeyword_boot(pTHX); XS-Parse-Keyword-0.21/t000755001750001750 014131246633 13447 5ustar00leoleo000000000000XS-Parse-Keyword-0.21/t/00use.t000444001750001750 15314131246633 14704 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use_ok( "XS::Parse::Keyword" ); done_testing; XS-Parse-Keyword-0.21/t/10stages-permit.t000444001750001750 133414131246633 16717 0ustar00leoleo000000000000#!/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' ); } # denied by func { BEGIN { $^H{"t::stages/permitkey"} = 1; } my $ret = stages { two => "two" }; is_deeply( $ret, { two => "two" }, 'keyword permitted by key but denied by func' ); } # permitted { BEGIN { $^H{"t::stages/permitkey"} = 1; } BEGIN { $^H{"t::stages/permitfunc"} = 1; } my $ret = stages { three => "three" }; is( $ret, "STAGE", 'keyword permitted by .permit func' ); } done_testing; XS-Parse-Keyword-0.21/t/11stages-check.t000444001750001750 71014131246633 16452 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::stages"; BEGIN { $^H{"t::stages/permitkey"} = 1; } BEGIN { $^H{"t::stages/permitfunc"} = 1; } our $VAR; { BEGIN { $^H{"t::stages/check-capture"} = 1; } BEGIN { $VAR = "before" } no warnings 'void'; stages { BEGIN { $VAR = "inside" } }; is( $t::stages::captured, "before", 'captured value of $VAR before block' ); } done_testing; XS-Parse-Keyword-0.21/t/30pieces-literal.t000444001750001750 47014131246633 17017 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } { my $ret = piececolon : ; is( $ret, "colon", 'result of piececolon' ); } { my $ret = piecestr foo ; is( $ret, "foo", 'result of piecestr' ); } done_testing; XS-Parse-Keyword-0.21/t/31pieces-block.t000444001750001750 150514131246633 16476 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } { my $ret = pieceblock { "block value" }; is( $ret, "(block value)", 'result of pieceblock' ); } { my @ret; # scalar reverse will join() strings @ret = pieceblock_scalar { reverse "abc", "def" }; is_deeply( \@ret, [ "fedcba" ], 'pieceblock_scalar forces scalar context' ); @ret = pieceblock_list { reverse "abc", "def" }; is_deeply( \@ret, [ "def,abc" ], 'pieceblock_list forces list context' ); } { my $ret = pieceprefixedblock $scalar = 123, { $scalar + 456 }; is( $ret, 123+456, 'result of pieceprefixedblock' ); } { my $ret = pieceprefixedblock_VAR { "$VAR, world!" }; is( $ret, "(Hello, world!)", 'result of pieceprefixedblock_VAR' ); } done_testing; XS-Parse-Keyword-0.21/t/32pieces-anonsub.t000444001750001750 50714131246633 17033 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } { my $ret = pieceanonsub { "sub value" }; is( ref $ret, "CODE", 'result of pieceanonsub is CODE reference' ); is( $ret->(), "sub value", 'result of invoking' ); } done_testing; XS-Parse-Keyword-0.21/t/33pieces-listexpr.t000444001750001750 75014131246633 17241 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } my $ret; { $ret = piecelistexpr "a term"; is( $ret, "a term", 'a single term' ); } # listexpr vs concat { $ret = piecelistexpr "x" . "y"; is( $ret, "xy", 'listexpr consumes concat' ); } # listexpr vs comma { $ret = join "", "x", piecelistexpr "inside", "y"; is( $ret, "xinside,y", 'listexpr consumes comma' ); } done_testing; XS-Parse-Keyword-0.21/t/33pieces-termexpr.t000444001750001750 122214131246633 17250 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } my $ret; { $ret = piecetermexpr "a term"; is( $ret, "(a term)", 'a single term' ); } # termexpr vs concat { $ret = piecetermexpr "x" . "y"; is( $ret, "(xy)", 'termexpr consumes concat' ); } # termexpr vs comma { $ret = join "", "x", piecetermexpr "inside", "y"; is( $ret, "x(inside)y", 'termexpr stops before comma' ); } # termexpr in piece1 can act as entire parens { $ret = piecetermexpr( "x" ) . "y"; is( $ret, "(x)y", 'termexpr treats (PARENS) as entire expression' ); } done_testing; XS-Parse-Keyword-0.21/t/34pieces-ident.t000444001750001750 152714131246633 16516 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } { my $ret = pieceident foobar; is( $ret, "foobar", 'result of pieceident' ); ok( !defined eval 'pieceident', 'pieceident complains of missing ident' ); like( $@, qr/^Expected an identifier at /, 'message from missing ident' ); } { my $ret = pieceident_opt present; is( $ret, "present", 'result of pieceident_opt with ident' ); $ret = pieceident_opt; ok( !defined $ret, 'result of pieceident_opt without' ); } { my $ret = piecepkg Bar::Foo; is( $ret, "Bar::Foo", 'result of piecepkg' ); ok( !defined eval 'piecepkg', 'piecepkg complains of missing packagename' ); like( $@, qr/^Expected a package name at /, 'message from missing packagename' ); } done_testing; XS-Parse-Keyword-0.21/t/35pieces-lexvar.t000444001750001750 111314131246633 16704 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } # names { my $ret; $ret = piecelexvarname $scalar; is( $ret, "\$scalar", 'result of piecelexvarname' ); $ret = piecelexvarname @array; is( $ret, "\@array", 'result of piecelexvarname' ); $ret = piecelexvarname %hash; is( $ret, "\%hash", 'result of piecelexvarname' ); } # pad indexes { my $ret; $ret = piecelexvarmy $scalar; cmp_ok( $ret, '>', 0, 'result of piecelexvarmy' ); $scalar = 123; } done_testing; XS-Parse-Keyword-0.21/t/36pieces-attrs.t000444001750001750 107114131246633 16544 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } { my $ret; $ret = pieceattrs; is( $ret, "", 'result of pieceattrs with none' ); $ret = pieceattrs :foo :bar; is( $ret, ":foo():bar()", 'result of pieceattrs with two plain' ); $ret = pieceattrs :one(1) :two(2); is( $ret, ":one(1):two(2)", 'result of pieceattrs with two + args' ); $ret = pieceattrs : a b c; is( $ret, ":a():b():c()", 'result of pieceattrs with three no colons' ); } done_testing; XS-Parse-Keyword-0.21/t/37pieces-vstring.t000444001750001750 73014131246633 17065 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } { my $ret = piecevstring v1.23; isa_ok( $ret, "version" ); is( $ret, "v1.23", 'result of piecevstring' ); } { my $ret = piecevstring_opt v4.56; is( $ret, "v4.56", 'result of piecevstring_opt with version' ); $ret = piecevstring_opt; ok( !defined $ret, 'result of piecevstring_opt without' ); } done_testing; XS-Parse-Keyword-0.21/t/38pieces-infix.t000444001750001750 107614131246633 16533 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } # names { my $ret; $ret = pieceinfix ==; is( $ret, "eq", 'result of piecelexvarname' ); $ret = pieceinfix gt; is( $ret, "sgt", 'result of piecelexvarname' ); $ret = pieceinfixeq eq; is( $ret, "seq", 'result of piecelexvarname' ); ok( !defined eval "pieceinfixeq >", 'pieceinfixeq does not accept >' ); like( $@, qr/^Expected an infix operator at /, 'message from pieceinfixeq' ); } done_testing; XS-Parse-Keyword-0.21/t/40build.t000444001750001750 42314131246633 15213 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::build"; BEGIN { $^H{"t::build/permit"} = 1; } { my $ret; $ret = build { "block here" } "value here"; is( $ret, "block here|value here", 'result of build' ); } done_testing; XS-Parse-Keyword-0.21/t/41structures.t000444001750001750 172514131246633 16366 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::structures"; BEGIN { $^H{"t::structures/permit"} = 1; } # sequence { is( structsequence part 123, 123, 'sequence' ); } # optional { is( structoptional part, 1, 'optional present' ); is( structoptional, 0, 'optional absent' ); } # repeated { is( structrepeat part part, 2, 'repeated twice' ); is( structrepeat part part part part, 4, 'repeated four times' ); } # choice { is( structchoice zero, 0, 'choice zero' ); is( structchoice two, 2, 'choice two' ); is( structchoice { 1234 }, 3, 'choice block' ); # RT136845 is( structchoice, -1, 'choice absent' ); } # tagged choice { is( structtagged one, 1, 'tagged choice one' ); is( structtagged three, 3, 'tagged choice three' ); } # comma list { is( (structcommalist item), 1, 'comma list with 1 item' ); is( (structcommalist item, item, item), 3, 'comma list with 3 items' ); } done_testing; XS-Parse-Keyword-0.21/t/42scopes.t000444001750001750 76314131246633 15421 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::structures"; BEGIN { $^H{"t::structures/permit"} = 1; } # paren scope { is( scopeparen ( "abc" ), "abc", 'parenthesis scope' ); } # bracket scope { is( scopebracket [ "def" ], "def", 'bracket scope' ); } # brace scope { is( scopebrace { "ghi" }, "ghi", 'brace scope' ); } # chevron scope { # takes a bareword identifier is( scopechevron < jkl >, "jkl", 'chevron scope' ); } done_testing; XS-Parse-Keyword-0.21/t/43probing.t000444001750001750 331414131246633 15601 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::probing"; BEGIN { $^H{"t::probing/permit"} = 1; } # colon { ok( !probecolon, 'colon absent' ); ok( probecolon :, 'colon present' ); } # literal { ok( !probeliteral, 'literal absent' ); ok( probeliteral literal, 'literal present' ); } # block { ok( !probeblock, 'block absent' ); ok( probeblock {}, 'block present' ); } # ident { ok( !probeident, 'ident absent' ); ok( probeident foo, 'ident present' ); } # packagename { ok( !probepackagename, 'packagename absent' ); ok( probepackagename Pkg::Name, 'packagename present' ); } # vstring { ok( !probevstring, 'vstring absent' ); ok( probevstring v1.2.3, 'vstring present' ); } # choice { ok( !probechoice, 'choice absent' ); ok( probechoice x, '1st choice present' ); ok( probechoice z, '2nd choice present' ); } # tagged choice { ok( !probetaggedchoice, 'tagged choice absent' ); ok( probetaggedchoice x, '1st tagged choice present' ); ok( probetaggedchoice z, '2nd tagged choice present' ); } # comma list { ok( !probecommalist, 'comma list absent' ); is( ( probecommalist a ), 1, 'comma list present x 1' ); is( ( probecommalist a, b ), 2, 'comma list present x 2' ); } # paren scope { ok( !probeparens, 'parens absent' ); ok( probeparens (123), 'parens present' ); } # bracket scope { ok( !probebrackets, 'brackets absent' ); ok( probebrackets [123], 'brackets present' ); } # brace scope { ok( !probebraces, 'braces absent' ); ok( probebraces {123}, 'braces present' ); } # chevron scope { ok( !probechevrons, 'chevrons absent' ); ok( probechevrons , 'chevrons present' ); } done_testing; XS-Parse-Keyword-0.21/t/50flags-autosemi.t000444001750001750 56514131246633 17044 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::flags"; BEGIN { $^H{"t::flags/permit"} = 1; } { my $ret = do { flagautosemi semi; }; is( $ret, "semi", 'result of flagautosemi followed by ";"' ); } { my $ret = do { flagautosemi final }; is( $ret, "final", 'result of flagautosemi followed by "}"' ); } done_testing; XS-Parse-Keyword-0.21/t/60line.t000444001750001750 35314131246633 15047 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use lib "t"; use testcase "t::line"; BEGIN { $^H{"t::line/permit"} = 1; } { my $ret = line here; is( $ret, __LINE__-1, 'line captures line number' ); } done_testing; XS-Parse-Keyword-0.21/t/70infix.t000444001750001750 330314131246633 15254 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; use Test::More; use B qw( svref_2object walkoptree ); use B::Deparse; my $deparser = B::Deparse->new(); use lib "t"; use testcase "t::infix"; BEGIN { plan skip_all => "No PL_infix_plugin" unless XS::Parse::Infix::HAVE_PL_INFIX_PLUGIN; } BEGIN { $^H{"t::infix/permit"} = 1; } { my $result = 10 add 20; is( $result, 30, 'add infix operator' ); $result = 15 ⊕ 20; is( $result, 27, 'xor infix operator' ); my $aref = ["|" intersperse qw( a b c )]; is_deeply( $aref, [qw( a | b | c )], 'intersperse infix operator' ); my @list = qw( x y z ); $aref = ["|" intersperse @list]; is_deeply( $aref, [qw( x | y | z )], 'intersperse infix operator on PADAV' ); is_deeply( [ (2, 4, 6) addpairs (1, 1, 1) ], [ 3, 5, 7 ], 'addpairs infix operator' ); } sub is_deparsed { my ( $sub, $exp, $name ) = @_; my $got = $deparser->coderef2text( $sub ); # Deparsed output is '{ ... }'-wrapped $got = ( $got =~ m/^{\n(.*)\n}$/s )[0]; # Deparsed output will have a lot of pragmata and so on; just grab the # final line $got = ( split m/\n/, $got )[-1]; $got =~ s/^\s+//; is( $got, $exp, $name ); } { is_deparsed sub { $_[0] add $_[1] }, '$_[0] add $_[1];', 'deparsed call to infix operator'; is_deparsed sub { $_[0] ⊕ $_[1] }, '$_[0] ⊕ $_[1];', 'deparsed operator yields UTF-8'; is_deparsed sub { "+" intersperse (1,2,3) }, q['+' intersperse (1, 2, 3);], 'deparsed call to infix operator with list RHS'; is_deparsed sub { (1,2,3) addpairs (4,5,6) }, '(1, 2, 3) addpairs (4, 5, 6);', 'deparsed call to infix list/list operator'; } done_testing; XS-Parse-Keyword-0.21/t/71infix-wrapper.t000444001750001750 1442114131246633 16756 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; use Test::More; use B qw( svref_2object walkoptree ); use B::Deparse; my $deparser = B::Deparse->new(); use lib "t"; use testcase "t::infix"; BEGIN { $^H{"t::infix/permit"} = 1; } # Newer perls generate OP_SREFGEN directly; older perls see only OP_REFGEN use constant REFGEN => $] >= 5.022 ? "srefgen" : "refgen"; { my $result = t::infix::addfunc( 10, 20 ); is( $result, 30, 'add wrapper func' ); my $aref = [ t::infix::interspersefunc( "Z", "a", "b" ) ]; is_deeply( $aref, [qw( a Z b )], 'intersperse wrapper func' ); is_deeply( [ t::infix::addpairsfunc( [ 1, 2 ], [ 3, 4 ] ) ], [ 4, 6 ], 'addpairs wrapper func' ); } sub count_ops { my ( $code ) = @_; my %opcounts; # B::walkoptree() is stupid # https://github.com/Perl/perl5/issues/19101 no warnings 'once'; local *B::OP::collect_opnames = sub { my ( $op ) = @_; $opcounts{ $op->name }++ unless $op->name eq "null"; }; walkoptree( svref_2object( $code )->ROOT, "collect_opnames" ); return %opcounts; } # callchecker for scalar/scalar ops { my %opcounts; %opcounts = count_ops sub { t::infix::addfunc( $_[0], $_[1] ) }; # If the callchecker ran correctly we should see one 'custom' op and no # 'entersub's ok( (scalar grep { m/^infix_add_0x/ } keys %opcounts), 'callchecker generated an OP_CUSTOM call' ); ok( !$opcounts{entersub}, 'callchecker removed an OP_ENTERSUB call' ); # Opchecker should ignore non-scalar args %opcounts = count_ops sub { t::infix::addfunc( @_, "more" ) }; ok( !$opcounts{custom}, 'No OP_CUSTOM call for DEFAV' ); %opcounts = count_ops sub { t::infix::addfunc( lhs(), rhs() ) }; ok( !$opcounts{custom}, 'No OP_CUSTOM call for list ENTERSUB' ); # Opchecker still permits scalar entersub calls %opcounts = count_ops sub { t::infix::addfunc( scalar lhs(), scalar rhs() ) }; ok( (scalar grep { m/^infix_add_0x/ } keys %opcounts), 'OP_CUSTOM call for scalar ENTERSUB' ); } # callchecker for list/list ops { my $code; my %opcounts; my $aref = [1,2,3]; %opcounts = count_ops $code = sub { t::infix::addpairsfunc( $aref, $aref ) }; ok( (scalar grep { m/^infix_addpairs_0x/ } keys %opcounts), 'callchecker generated an OP_CUSTOM call for list/list' ); ok( !$opcounts{entersub}, 'callchecker removed an OP_ENTERSUB call for list/list' ); is( $opcounts{rv2av}, 2, 'callchecker made two OP_RV2AV' ); is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list' ); my @padav = (1,2,3); %opcounts = count_ops $code = sub { t::infix::addpairsfunc( \@padav, \@padav ) }; ok( !$opcounts{srefgen}, 'callchecker made no OP_SREFGEN for \@padav' ); is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list on \@padav' ); our @pkgav = (1,2,3); %opcounts = count_ops $code = sub { t::infix::addpairsfunc( \@pkgav, \@pkgav ) }; ok( !$opcounts{srefgen}, 'callchecker made no OP_SREFGEN for \@pkgav' ); is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list on \@pkgav' ); # stress-test it %opcounts = count_ops $code = sub { t::infix::addpairsfunc( \@{ \@{ \@padav } }, \@{ \@{ \@padav } } ) }; # Preserve the two sets of inner ones but remove the outer ones is( $opcounts{+REFGEN}, 4, 'callchecker removed one layer of OP_SREFGEN for stress-test' ); is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list on stress-test' ); package OneTwoThree { use overload '@{}' => sub { return [1, 2, 3] }; } $code = sub { t::infix::addpairsfunc( bless( {}, "OneTwoThree" ), \@padav ) }; is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list on blessed object' ); # anonlist remains on LHS %opcounts = count_ops $code = sub { t::infix::addpairsfunc( [1,2,3], \@padav ) }; ok( $opcounts{anonlist}, 'callchecker left OP_ANONLIST on LHS' ); is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list on anonlist' ); # anonlist is unwrapped on RHS %opcounts = count_ops $code = sub { t::infix::addpairsfunc( \@padav, [1,2,3] ) }; ok( !$opcounts{anonlist}, 'callchecker removed OP_ANONLIST on RHS' ); is_deeply( [ $code->() ], [ 2, 4, 6 ], 'result of callcheckered code for list/list on anonlist' ); } # wrapper func by coderef { my $wrapper = \&t::infix::addfunc; is( $wrapper->( 30, 40 ), 70, 'add wrapper func by CODE reference' ); } # argument checking { ok( !eval { t::infix::addfunc( 10, 20, 30 ) }, 'Wrapper func fails for too many args' ); like( $@, qr/^Too many arguments for subroutine 't::infix::addfunc'/, 'Failure message for too many args' ); ok( !eval { t::infix::addfunc( 60 ) }, 'Wrapper func fails for too few args' ); like( $@, qr/^Too few arguments for subroutine 't::infix::addfunc'/, 'Failure message for too few args' ); } sub is_deparsed { my ( $sub, $exp, $name ) = @_; my $got = $deparser->coderef2text( $sub ); # Deparsed output is '{ ... }'-wrapped $got = ( $got =~ m/^{\n(.*)\n}$/s )[0]; # Deparsed output will have a lot of pragmata and so on; just grab the # final line $got = ( split m/\n/, $got )[-1]; $got =~ s/^\s+//; is( $got, $exp, $name ); } { # We need to ensure the wrapper function doesn't deparse to the actual # infix operator syntax in order to test this one BEGIN { delete $^H{"t::infix/permit"} } is_deparsed sub { t::infix::addfunc( $_[0], $_[1] ) }, 't::infix::addfunc($_[0], $_[1]);', 'deparsed call to wrapper func'; my @padav; our @pkgav; is_deparsed sub { t::infix::addpairsfunc( $_[0], $_[1] ) }, 't::infix::addpairsfunc($_[0], $_[1]);', 'deparsed call to list/list wrapper func on slugs'; is_deparsed sub { t::infix::addpairsfunc( \@padav, \@padav ) }, 't::infix::addpairsfunc(\@padav, \@padav);', 'deparsed call to list/list wrapper func on padav'; is_deparsed sub { t::infix::addpairsfunc( \@pkgav, \@pkgav ) }, 't::infix::addpairsfunc(\@pkgav, \@pkgav);', 'deparsed call to list/list wrapper func on pkgav'; is_deparsed sub { t::infix::addpairsfunc( [1,2], [3,4] ) }, 't::infix::addpairsfunc([1, 2], [3, 4]);', 'deparsed call to list/list wrapper func on anonlist'; } done_testing; XS-Parse-Keyword-0.21/t/99pod.t000444001750001750 25614131246633 14720 0ustar00leoleo000000000000#!/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(); XS-Parse-Keyword-0.21/t/build.xs000444001750001750 163714131246633 15266 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" static int build(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { /* concat the exprs together */ *out = newBINOP(OP_CONCAT, 0, newBINOP(OP_CONCAT, 0, args[0]->op, newSVOP(OP_CONST, 0, newSVpvs("|"))), args[1]->op); return KEYWORD_PLUGIN_EXPR; } static const struct XSParseKeywordHooks hooks_build = { .permit_hintkey = "t::build/permit", .pieces = (const struct XSParseKeywordPieceType []){ XPK_BLOCK, XPK_TERMEXPR, {0} }, .build = &build, }; MODULE = t::build PACKAGE = t::build BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("build", &hooks_build, NULL); XS-Parse-Keyword-0.21/t/flags.xs000444001750001750 146514131246633 15262 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" static const char hintkey[] = "t::flags/permit"; static int build_ident(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { *out = newSVOP(OP_CONST, 0, arg0->sv); return KEYWORD_PLUGIN_STMT; } static const struct XSParseKeywordHooks hooks_autosemi = { .flags = XPK_FLAG_STMT|XPK_FLAG_AUTOSEMI, .permit_hintkey = hintkey, .piece1 = XPK_IDENT, .build1 = &build_ident, }; MODULE = t::flags PACKAGE = t::flags BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("flagautosemi", &hooks_autosemi, NULL); XS-Parse-Keyword-0.21/t/infix.xs000444001750001750 530014131246633 15273 0ustar00leoleo000000000000/* 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 "XSParseInfix.h" #include "perl-backcompat.c.inc" static const char hintkey[] = "t::infix/permit"; XOP xop_add; OP *pp_add(pTHX) { dSP; SV *right = POPs; SV *left = POPs; mPUSHi(SvIV(left) + SvIV(right)); RETURN; } static const struct XSParseInfixHooks hooks_add = { .permit_hintkey = hintkey, .cls = 0, .wrapper_func_name = "t::infix::addfunc", .ppaddr = &pp_add, }; OP *pp_xor(pTHX) { dSP; SV *right = POPs; SV *left = POPs; mPUSHi(SvIV(left) ^ SvIV(right)); RETURN; } static const struct XSParseInfixHooks hooks_xor = { .permit_hintkey = hintkey, .cls = 0, .ppaddr = &pp_xor, }; OP *pp_intersperse(pTHX) { /* This isn't a very efficient implementation but we're not going for * efficiency here in this unit test */ dSP; I32 markidx = POPMARK; I32 items = SP - PL_stack_base - markidx; SP -= items; SV *sep = *SP; AV *list = av_make(items, SP+1); SAVEFREESV((SV *)list); SP--; if(!items) RETURN; EXTEND(SP, 2*items - 1); PUSHs(*av_fetch(list, 0, TRUE)); I32 i; for(i = 1; i < items; i++) { PUSHs(sv_mortalcopy(sep)); PUSHs(*av_fetch(list, i, TRUE)); } RETURN; } static const struct XSParseInfixHooks hooks_intersperse = { .rhs_flags = XPI_OPERAND_LIST, .permit_hintkey = hintkey, .cls = 0, .wrapper_func_name = "t::infix::interspersefunc", .ppaddr = &pp_intersperse, }; OP *pp_addpairs(pTHX) { dSP; U32 rhs_mark = POPMARK; U32 lhs_mark = POPMARK; U32 rhs_count = SP - (PL_stack_base + rhs_mark); U32 lhs_count = rhs_mark - lhs_mark; SP = PL_stack_base + lhs_mark; SV **lhs = PL_stack_base + lhs_mark + 1; SV **rhs = PL_stack_base + rhs_mark + 1; PUSHMARK(SP); while(lhs_count || rhs_count) { IV val = SvIV(*lhs) + SvIV(*rhs); mPUSHi(val); lhs++; lhs_count--; rhs++; rhs_count--; } RETURN; } static const struct XSParseInfixHooks hooks_addpairs = { .lhs_flags = XPI_OPERAND_TERM_LIST, .rhs_flags = XPI_OPERAND_TERM_LIST|XPI_OPERAND_ONLY_LOOK, /* only on RHS so we can test the logic */ .permit_hintkey = hintkey, .cls = 0, .wrapper_func_name = "t::infix::addpairsfunc", .ppaddr = &pp_addpairs, }; MODULE = t::infix PACKAGE = t::infix BOOT: boot_xs_parse_infix(0); register_xs_parse_infix("add", &hooks_add, NULL); register_xs_parse_infix("⊕", &hooks_xor, NULL); register_xs_parse_infix("intersperse", &hooks_intersperse, NULL); register_xs_parse_infix("addpairs", &hooks_addpairs, NULL); XS-Parse-Keyword-0.21/t/line.xs000444001750001750 144514131246633 15113 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" static int build_line(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { *out = newSVOP(OP_CONST, 0, newSViv(args[0]->line)); return KEYWORD_PLUGIN_EXPR; } static const struct XSParseKeywordHooks hooks_line = { .permit_hintkey = "t::line/permit", .pieces = (const struct XSParseKeywordPieceType []){ XPK_IDENT, {0} }, .build = &build_line, }; MODULE = t::line PACKAGE = t::line BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("line", &hooks_line, NULL); XS-Parse-Keyword-0.21/t/pieces.xs000444001750001750 2044414131246633 15454 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" #include "XSParseInfix.h" #include "perl-backcompat.c.inc" static const char hintkey[] = "t::pieces/permit"; static int build_expr(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { /* wrap the result in "("...")" parens so we can unit-test how it parsed */ *out = newBINOP(OP_CONCAT, 0, newBINOP(OP_CONCAT, 0, newSVOP(OP_CONST, 0, newSVpvs("(")), op_scope(arg0->op)), newSVOP(OP_CONST, 0, newSVpvs(")"))); return KEYWORD_PLUGIN_EXPR; } static int build_prefixedblock(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { PADOFFSET padix = args[0]->padix; OP *value = args[1]->op; OP *body = args[2]->op; OP *padsvop = newOP(OP_PADSV, OPf_MOD|(OPpLVAL_INTRO<<8)); padsvop->op_targ = padix; *out = op_prepend_elem(OP_LINESEQ, newBINOP(OP_SASSIGN, 0, value, padsvop), body); return KEYWORD_PLUGIN_EXPR; } static int build_anonsub(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { *out = newSVOP(OP_CONST, 0, newRV_noinc((SV *)cv_clone(arg0->cv))); return KEYWORD_PLUGIN_EXPR; } static int build_list(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { OP *list = arg0->op; /* TODO: Consider always doing this? */ if(list->op_type != OP_LIST) list = newLISTOP(OP_LIST, 0, list, NULL); /* unshift $sep */ #if HAVE_PERL_VERSION(5, 22, 0) op_sibling_splice(list, cUNOPx(list)->op_first, 0, newSVOP(OP_CONST, 0, newSVpvs(","))); #else { OP *o = newSVOP(OP_CONST, 0, newSVpvs(",")); o->op_sibling = cUNOPx(list)->op_first->op_sibling; cUNOPx(list)->op_first->op_sibling = o; } #endif *out = op_convert_list(OP_JOIN, 0, list); return KEYWORD_PLUGIN_EXPR; } static int build_constsv(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { *out = newSVOP(OP_CONST, 0, arg0->sv); return KEYWORD_PLUGIN_EXPR; } static int build_constsv_or_undef(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { if(arg0->sv) *out = newSVOP(OP_CONST, 0, arg0->sv); else *out = newOP(OP_UNDEF, OPf_WANT_SCALAR); return KEYWORD_PLUGIN_EXPR; } static int build_constpadix(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { *out = newSVOP(OP_CONST, 0, newSVuv(arg0->padix)); return KEYWORD_PLUGIN_EXPR; } static int build_literal(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { /* ignore arg0 */ *out = newSVOP(OP_CONST, 0, (SV *)hookdata); return KEYWORD_PLUGIN_EXPR; } static int build_attrs(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int nattrs = args[0]->i; SV *retsv = newSV(0); sv_setpvs(retsv, ""); int argi; for(argi = 0; argi < nattrs; argi++) sv_catpvf(retsv, ":%s(%s)", SvPV_nolen(args[argi+1]->attr.name), SvPOK(args[argi+1]->attr.value) ? SvPV_nolen(args[argi+1]->attr.value) : ""); *out = newSVOP(OP_CONST, 0, retsv); return KEYWORD_PLUGIN_EXPR; } static int build_infix_opname(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { const char *opname = PL_op_name[arg0->infix->opcode]; *out = newSVOP(OP_CONST, 0, newSVpvn(opname, strlen(opname))); return KEYWORD_PLUGIN_EXPR; } static void setup_block_VAR(pTHX_ void *hookdata) { char *varname = hookdata; PADOFFSET padix = pad_add_name_pvn(varname, strlen(varname), 0, NULL, NULL); intro_my(); sv_setpvs(PAD_SVl(padix), "Hello"); } static const struct XSParseKeywordHooks hooks_block = { .permit_hintkey = hintkey, .piece1 = XPK_BLOCK, .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_block_scalar = { .permit_hintkey = hintkey, .piece1 = XPK_BLOCK_SCALARCTX, .build1 = &build_list, }; static const struct XSParseKeywordHooks hooks_block_list = { .permit_hintkey = hintkey, .piece1 = XPK_BLOCK_LISTCTX, .build1 = &build_list, }; static const struct XSParseKeywordHooks hooks_prefixedblock = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_PREFIXED_BLOCK( XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR), XPK_EQUALS, XPK_TERMEXPR_SCALARCTX, XPK_COMMA ), {0} }, .build = &build_prefixedblock, }; static const struct XSParseKeywordHooks hooks_prefixedblock_VAR = { .permit_hintkey = hintkey, .piece1 = XPK_PREFIXED_BLOCK( XPK_SETUP(&setup_block_VAR) ), .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_anonsub = { .permit_hintkey = hintkey, .piece1 = XPK_ANONSUB, .build1 = &build_anonsub, }; static const struct XSParseKeywordHooks hooks_termexpr = { .permit_hintkey = hintkey, .piece1 = XPK_TERMEXPR, .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_listexpr = { .permit_hintkey = hintkey, .piece1 = XPK_LISTEXPR, .build1 = &build_list, }; static const struct XSParseKeywordHooks hooks_ident = { .permit_hintkey = hintkey, .piece1 = XPK_IDENT, .build1 = &build_constsv, }; static const struct XSParseKeywordHooks hooks_ident_opt = { .permit_hintkey = hintkey, .piece1 = XPK_IDENT_OPT, .build1 = &build_constsv_or_undef, }; static const struct XSParseKeywordHooks hooks_packagename = { .permit_hintkey = hintkey, .piece1 = XPK_PACKAGENAME, .build1 = &build_constsv, }; static const struct XSParseKeywordHooks hooks_lexvar_name = { .permit_hintkey = hintkey, .piece1 = XPK_LEXVARNAME(XPK_LEXVAR_ANY), .build1 = &build_constsv, }; static const struct XSParseKeywordHooks hooks_lexvar_my = { .permit_hintkey = hintkey, .piece1 = XPK_LEXVAR_MY(XPK_LEXVAR_ANY), .build1 = &build_constpadix, }; static const struct XSParseKeywordHooks hooks_attrs = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_ATTRIBUTES, {0}, }, .build = &build_attrs, }; static const struct XSParseKeywordHooks hooks_vstring = { .permit_hintkey = hintkey, .piece1 = XPK_VSTRING, .build1 = &build_constsv, }; static const struct XSParseKeywordHooks hooks_vstring_opt = { .permit_hintkey = hintkey, .piece1 = XPK_VSTRING_OPT, .build1 = &build_constsv_or_undef, }; static const struct XSParseKeywordHooks hooks_infix_relation = { .permit_hintkey = hintkey, .piece1 = XPK_INFIX_RELATION, .build1 = &build_infix_opname, }; static const struct XSParseKeywordHooks hooks_infix_equality = { .permit_hintkey = hintkey, .piece1 = XPK_INFIX_EQUALITY, .build1 = &build_infix_opname, }; static const struct XSParseKeywordHooks hooks_colon = { .permit_hintkey = hintkey, .piece1 = XPK_COLON, .build1 = &build_literal, }; static const struct XSParseKeywordHooks hooks_str = { .permit_hintkey = hintkey, .piece1 = XPK_LITERAL("foo"), .build1 = &build_literal, }; MODULE = t::pieces PACKAGE = t::pieces BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("pieceblock", &hooks_block, NULL); register_xs_parse_keyword("pieceblock_scalar", &hooks_block_scalar, NULL); register_xs_parse_keyword("pieceblock_list", &hooks_block_list, NULL); register_xs_parse_keyword("pieceprefixedblock", &hooks_prefixedblock, NULL); register_xs_parse_keyword("pieceprefixedblock_VAR", &hooks_prefixedblock_VAR, "$VAR"); register_xs_parse_keyword("pieceanonsub", &hooks_anonsub, NULL); register_xs_parse_keyword("piecetermexpr", &hooks_termexpr, NULL); register_xs_parse_keyword("piecelistexpr", &hooks_listexpr, NULL); register_xs_parse_keyword("pieceident", &hooks_ident, NULL); register_xs_parse_keyword("pieceident_opt", &hooks_ident_opt, NULL); register_xs_parse_keyword("piecepkg", &hooks_packagename, NULL); register_xs_parse_keyword("piecelexvarname", &hooks_lexvar_name, NULL); register_xs_parse_keyword("piecelexvarmy", &hooks_lexvar_my, NULL); register_xs_parse_keyword("pieceattrs", &hooks_attrs, NULL); register_xs_parse_keyword("piecevstring", &hooks_vstring, NULL); register_xs_parse_keyword("piecevstring_opt", &hooks_vstring_opt, NULL); register_xs_parse_keyword("pieceinfix", &hooks_infix_relation, NULL); register_xs_parse_keyword("pieceinfixeq", &hooks_infix_equality, NULL); register_xs_parse_keyword("piececolon", &hooks_colon, newSVpvs("colon")); register_xs_parse_keyword("piecestr", &hooks_str, newSVpvs("foo")); XS-Parse-Keyword-0.21/t/probing.xs000444001750001750 1137714131246633 15651 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" #include "perl-backcompat.c.inc" static const char hintkey[] = "t::probing/permit"; static int build_constbool(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { *out = newSVOP(OP_CONST, 0, boolSV(args[0]->i)); return KEYWORD_PLUGIN_EXPR; } static int build_repeatcount(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { *out = newSVOP(OP_CONST, 0, newSViv(args[0]->i ? args[1]->i : 0)); return KEYWORD_PLUGIN_EXPR; } static const struct XSParseKeywordHooks hooks_colon = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_COLON ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_literal = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_LITERAL("literal") ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_block = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_BLOCK ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_ident = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_IDENT ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_packagename = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_PACKAGENAME ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_vstring = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_VSTRING ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_choice = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_CHOICE( XPK_LITERAL("x"), XPK_LITERAL("z") ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_taggedchoice = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_TAGGEDCHOICE( XPK_LITERAL("x"), XPK_TAG('x'), XPK_LITERAL("z"), XPK_TAG('z') ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_commalist = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []) { XPK_OPTIONAL( XPK_COMMALIST( XPK_IDENT ) ), {0}, }, .build = &build_repeatcount, }; static const struct XSParseKeywordHooks hooks_parens = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_PARENSCOPE( XPK_TERMEXPR ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_brackets = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_BRACKETSCOPE( XPK_TERMEXPR ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_braces = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_BRACESCOPE( XPK_TERMEXPR ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_chevrons = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_CHEVRONSCOPE( XPK_IDENT ) ), {0} }, .build = &build_constbool, }; MODULE = t::probing PACKAGE = t::probing BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("probecolon", &hooks_colon, NULL); register_xs_parse_keyword("probeliteral", &hooks_literal, NULL); register_xs_parse_keyword("probeblock", &hooks_block, NULL); register_xs_parse_keyword("probeident", &hooks_ident, NULL); register_xs_parse_keyword("probepackagename", &hooks_packagename, NULL); register_xs_parse_keyword("probevstring", &hooks_vstring, NULL); register_xs_parse_keyword("probechoice", &hooks_choice, NULL); register_xs_parse_keyword("probetaggedchoice", &hooks_taggedchoice, NULL); register_xs_parse_keyword("probecommalist", &hooks_commalist, NULL); register_xs_parse_keyword("probeparens", &hooks_parens, NULL); register_xs_parse_keyword("probebrackets", &hooks_brackets, NULL); register_xs_parse_keyword("probebraces", &hooks_braces, NULL); register_xs_parse_keyword("probechevrons", &hooks_chevrons, NULL); XS-Parse-Keyword-0.21/t/stages.xs000444001750001750 225414131246633 15451 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" static bool permit_stages(pTHX_ void *hookdata) { HV *hints = GvHV(PL_hintgv); if(hv_fetchs(hints, "t::stages/permitfunc", 0)) return TRUE; return FALSE; } static void check_stages(pTHX_ void *hookdata) { if(hv_fetchs(GvHV(PL_hintgv), "t::stages/check-capture", 0)) { sv_setsv(get_sv("t::stages::captured", GV_ADD), get_sv("main::VAR", 0)); } } static int parse_stages(pTHX_ OP **out, void *hookdata) { /* Parse and ignore a block */ OP *block = parse_block(0); op_free(block); *out = newSVOP(OP_CONST, 0, newSVpvs("STAGE")); return KEYWORD_PLUGIN_EXPR; } static const struct XSParseKeywordHooks hooks_stages = { .permit_hintkey = "t::stages/permitkey", .permit = &permit_stages, .check = &check_stages, .parse = &parse_stages, }; MODULE = t::stages PACKAGE = t::stages BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("stages", &hooks_stages, NULL); XS-Parse-Keyword-0.21/t/structures.xs000444001750001750 1032414131246633 16423 0ustar00leoleo000000000000/* 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 "XSParseKeyword.h" static const char hintkey[] = "t::structures/permit"; static int build_op(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { *out = args[0]->op; return KEYWORD_PLUGIN_EXPR; } static int build_constiv(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { /* npieces should always be 1 because XPK_LITERAL() does not yield args */ *out = newSVOP(OP_CONST, 0, newSViv(args[0]->i)); return KEYWORD_PLUGIN_EXPR; } static int build_constsv(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { *out = newSVOP(OP_CONST, 0, args[0]->sv); return KEYWORD_PLUGIN_EXPR; } static const struct XSParseKeywordHooks hooks_sequence = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_SEQUENCE( XPK_LITERAL("part"), XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_optional = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_LITERAL("part") ), {0} }, .build = &build_constiv, }; static const struct XSParseKeywordHooks hooks_repeated = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_REPEATED( XPK_LITERAL("part") ), {0} }, .build = &build_constiv, }; static const struct XSParseKeywordHooks hooks_choice = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []) { XPK_CHOICE( XPK_LITERAL("zero"), XPK_LITERAL("one"), XPK_LITERAL("two"), XPK_BLOCK ), {0} }, .build = &build_constiv, }; static const struct XSParseKeywordHooks hooks_tagged = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_TAGGEDCHOICE( XPK_LITERAL("one"), XPK_TAG(1), XPK_LITERAL("two"), XPK_TAG(2), XPK_LITERAL("three"), XPK_TAG(3) ), {0} }, .build = &build_constiv, }; static const struct XSParseKeywordHooks hooks_commalist = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_COMMALIST( XPK_LITERAL("item") ), {0} }, .build = &build_constiv, }; static const struct XSParseKeywordHooks hooks_scope_paren = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_PARENSCOPE( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_scope_bracket = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_BRACKETSCOPE( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_scope_brace = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_BRACESCOPE( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_scope_chevron = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ /* A TERMEXPR inside chevrons is ambiguous, because of the < 2 > 1 > problem */ XPK_CHEVRONSCOPE( XPK_IDENT ), {0} }, .build = &build_constsv, }; MODULE = t::structures PACKAGE = t::structures BOOT: boot_xs_parse_keyword(0); register_xs_parse_keyword("structsequence", &hooks_sequence, NULL); register_xs_parse_keyword("structoptional", &hooks_optional, NULL); register_xs_parse_keyword("structrepeat", &hooks_repeated, NULL); register_xs_parse_keyword("structchoice", &hooks_choice, NULL); register_xs_parse_keyword("structtagged", &hooks_tagged, NULL); register_xs_parse_keyword("structcommalist", &hooks_commalist, NULL); register_xs_parse_keyword("scopeparen", &hooks_scope_paren, NULL); register_xs_parse_keyword("scopebracket", &hooks_scope_bracket, NULL); register_xs_parse_keyword("scopebrace", &hooks_scope_brace, NULL); register_xs_parse_keyword("scopechevron", &hooks_scope_chevron, NULL); XS-Parse-Keyword-0.21/t/testcase.pm000444001750001750 33214131246633 15733 0ustar00leoleo000000000000package testcase; use strict; use warnings; use lib "t/blib", "t/blib/arch"; use XS::Parse::Keyword; sub import { shift; require XSLoader; XSLoader::load( $_[0], $XS::Parse::Keyword::VERSION ); } 0x55AA;