XS-Parse-Keyword-0.44000755001750001750 014646455562 13227 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/.editorconfig000444001750001750 5314646455562 15777 0ustar00leoleo000000000000root = true [*.{pm,pl,t}] indent_size = 3 XS-Parse-Keyword-0.44/Build.PL000444001750001750 376714646455562 14675 0ustar00leoleo000000000000use v5; use strict; use warnings; use lib 'inc'; use ExtUtils::CChecker 0.11; use Module::Build::with::XSTests; my @extra_compiler_flags = qw( -Ishare/include -Ihax ); # Perl 5.36 made -std=c99 standard; before then we'll have to request it specially push @extra_compiler_flags, qw( -std=c99 ) if $^V lt v5.36.0; push @extra_compiler_flags, qw( -DDEBUGGING=-g ) if $^X =~ m|/debugperl|; 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"; my $build = Module::Build::with::XSTests->new( module_name => 'XS::Parse::Keyword', requires => { 'perl' => $MIN_PERL, }, build_requires => { # We have multiple t/*.xs files, which requires a new enough version of # ExtUtils::ParseXS to cope with. # Unsure the exact version required. perl 5.14 normally ships with version # 2.2210 but that fails. perl 5.16's version 3.16 works fine. 'ExtUtils::ParseXS' => '3.16', }, test_requires => { 'Test2::V0' => 0, }, configure_requires => { 'ExtUtils::CChecker' => '0.11', 'Module::Build' => '0.4004', # test_requires }, share_dir => { dist => [ 'share' ], }, license => 'perl', create_license => 1, create_readme => 1, extra_compiler_flags => \@extra_compiler_flags, c_source => [ "src/" ], ); $cc->extend_module_build( $build ); $build->notes( builder_cflags => $cc->extra_compiler_flags ); $build->create_build_script; XS-Parse-Keyword-0.44/Changes000444001750001750 2771214646455562 14710 0ustar00leoleo000000000000Revision history for XS-Parse-Keyword 0.44 2024-07-19 [BUGFIXES] * `boot_xs_parse_infix()` has to load `XS/Parse/Infix.pm`, the perl module * Fix opname check for lexical operator alises, to match Perl's actual identifier rules * Fix deparse logic for fully-qualified infix operator names * Fix `lex_scan_packagename()` to not get confused by attribute syntax 0.43 2024-07-03 [CHANGES] * Use `File::ShareDir` for storing .h include files, rather than storing the contents in the `__DATA__` section of the build helpers * Support a new naming model for infix operators that supports lexical-aliases and renaming at import time 0.42 2024-04-30 [BUGFIXES] * Don't crash on zero-argument calls to list-associative wrapper functions (thanks aquanight) (RT153244) 0.41 2024-04-25 [BUGFIXES] * Remmeber to EXTEND the stack in list-associative operator wrapper functions (thanks aquanight) (RT153173) 0.40 2024-04-23 [CHANGES] * Support N-way list-associative operators, implemented as LISTOPs * Delete the no-longer-used API constants XPI_OPERAND_{ARITH,TERM,CUSTOM} from XSParseInfix.h [BUGFIXES] * Avoid a subsequent `use VERSION` in unit tests to keep perl 5.39.8 happy 0.39 2023-12-04 [CHANGES] * Added optional variants of XPK_ARITHEXPR, XPK_TERMEXPR, XPK_LISTEXPR and the context-forcing versions 0.38 2023-08-09 [BUGFIXES] * Fix warn() non-static format string (RT149346) * Don't bother with Build.PL probing for PL_infix_plugin; just use perl version number 0.37 2023-08-08 [CHANGES] * Added `XPK_WARNING()` and several conditional variants 0.36 2023-07-20 [BUGFIXES] * Remember to also call `op_scope()` after `block_end()` if the XPK_FLAG_BLOCKSCOPE flag is set 0.35 2023-07-19 [CHANGES] * Added XPK_INTRO_MY, to call `intro_my()` * Added XPK_FLAG_BLOCKSCOPE to wrap a block_start()+block_end() around a syntax construction * Renamed XPK_PARENSCOPE to XPK_PARENS, etc.. * Adjusted documentation of XS::Parse::Infix for release of Perl v5.38 0.34 2023-06-14 [CHANGES] * Swap all unit tests from Test::More to Test2::V0 [BUGFIXES] * Remember to set `-std=c99` compiler flag on Perls before v5.36 * Skip whitespace between pieces of SEQUENCE or SEPARATEDLIST 0.33 2023-02-18 [CHANGES] * Added XPK_LEXVAR, a non `my`-alike variant * Added XPK_*_pieces() macros allowing caller to dynamically generate sub-arrays of pieces [BUGFIXES] * Remember to consume whitespace between XPK_REPEATED elements 0.32 2023-01-12 [BUGFIXES] * Ensure that XPK_TERMEXPR acting as a fullexpr is OK with empty parens (RT145618) 0.31 2022-12-25 [CHANGES] * PL_infix_plugin now exists in 5.37.7 * Support the new infix operator precedence levels added by perl v5.37.7 * Various updates to hax/ support files 0.30 2022-12-03 [CHANGES] * Added XPK_STAGED_ANONSUB; inspired a bit by XS::Parse::Sublike for customising the parsing of anonmethod 0.29 2022-12-01 [CHANGES] * Added XPK_PREFIXED_TERMEXPR_ENTERLEAVE [BUGFIXES] * Don't try to call `SvPVX()` on a `newSV(0)` because -DDEBUGGING perls get upset (RT145278) * Remember to `break` out of switch block cases when testing for `KEYWORD_PLUGIN_*` return values 0.28 2022-11-25 [CHANGES] * Include a XSParseInfixClassification field in the XSParseInfixInfo structure * Do not permit mixed identifier/non characters in the names of registered infix operators * No longer supports XSParseInfix ABI version 0 [BUGFIXES] * When parsing an infix operator name, make sure not to be confused by additional identifier characters immediately after it 0.27 2022-10-31 [CHANGES] * Updates to XS::Parse::Infix for latest `infix-plugin` perl5 branch + parsedata field is now an SV **, not an ANY * * Expose parse_infix() as a real ABI function, allowing infix operators to be hyper-operators and parse other operator names 0.26 2022-10-24 [CHANGES] * Updates to XS::Parse::Infix for latest `infix-plugin` perl5 branch + Requires classification to set the operator precedence + No longer need XPI_OPERAND_ARITH or XPI_OPERAND_TERM; most of .lhs_flags and .rhs_flags are redundant now + No longer support XPI_OPERAND_CUSTOM + Optional `parse` phase for parametric/hyper-operators * Bump XS::Parse::Infix ABI version to 2 * Declare XPI ABI v0 as deprecated, soon to be removed 0.25 2022-07-25 [CHANGES] * Permit infix operators to consume fewer than all the available symbols; allowing for RHS operands that begin with symbols without intervening whitespace * Improved unit-testing of infix operator parser precedence issues * Added `XPI_OPERAND_ARITH`; renumbered `XPI_OPERAND_TERM` to be non-zero. Currently zero is accepted for back-compat 0.24 2022-06-26 [CHANGES] * Skip attempting to create duplicate wrapper funcs, in case of multiple registrations of the same operator with different spellings [BUGFIXES] * Arrange extra_linker_flags correctly while building probe program for PL_infix_plugin 0.23 2022-05-18 [CHANGES] * Defined XPK_KEYWORD, a better version of XPK_LITERAL for keyword-like tokens * Defined XPK_ARITHEXPR, a higher-precedence version of XPK_TERMEXPR * Defined XPK_ARGSCOPE, a variant of XPK_PARENSCOPE where the parens themselves are optional * Undocument the old XPK_STRING token type [BUGFIXES] * Fixes for bugs that affect -DDEBUGGING-enabled perls + Remember to clear OPf_KIDS when stealing the op_first of a LISTOP (RT142770) + Don't call cv_clone() at compiletime when unit testing; generate an OP_ANONCODE instead (RT142771) 0.22 2022-02-21 [CHANGES] * Added XPK_AUTOSEMI piece type [BUGFIXES] * Don't segfault if lex_scan_lexvar() fails (RT140402) * Set required version of ExtUtils::ParseXS for multiple t/*.xs files 0.21 2021-10-12 [BUGFIXES] * Fix for perl 5.20 - cannot use assert() as an expression 0.20 (bad MANIFEST) 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.44/LICENSE000444001750001750 4653414646455562 14425 0ustar00leoleo000000000000This software is copyright (c) 2024 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) 2024 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 Perl Artistic License 1.0 --- This software is Copyright (c) 2024 by Paul Evans . This is free software, licensed under: The Perl 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End XS-Parse-Keyword-0.44/MANIFEST000444001750001750 233414646455562 14517 0ustar00leoleo000000000000.editorconfig Build.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/optree-additions.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 share/include/XSParseInfix.h share/include/XSParseKeyword.h 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-arithexpr.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/39pieces-warning.t t/40build.t t/41structures.t t/42containers.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 XS-Parse-Keyword-0.44/META.json000444001750001750 314414646455562 15007 0ustar00leoleo000000000000{ "abstract" : "XS functions to assist in parsing keyword syntax", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "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", "ExtUtils::ParseXS" : "3.16" } }, "configure" : { "requires" : { "ExtUtils::CChecker" : "0.11", "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "File::ShareDir" : "1.00", "perl" : "5.014" } }, "test" : { "requires" : { "Test2::V0" : "0" } } }, "provides" : { "XS::Parse::Infix" : { "file" : "lib/XS/Parse/Infix.pm", "version" : "0.44" }, "XS::Parse::Infix::Builder" : { "file" : "lib/XS/Parse/Infix/Builder.pm", "version" : "0.44" }, "XS::Parse::Keyword" : { "file" : "lib/XS/Parse/Keyword.pm", "version" : "0.44" }, "XS::Parse::Keyword::Builder" : { "file" : "lib/XS/Parse/Keyword/Builder.pm", "version" : "0.44" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.44", "x_serialization_backend" : "JSON::PP version 4.16" } XS-Parse-Keyword-0.44/META.yml000444001750001750 200114646455562 14626 0ustar00leoleo000000000000--- abstract: 'XS functions to assist in parsing keyword syntax' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' ExtUtils::ParseXS: '3.16' Test2::V0: '0' configure_requires: ExtUtils::CChecker: '0.11' Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, 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.44' XS::Parse::Infix::Builder: file: lib/XS/Parse/Infix/Builder.pm version: '0.44' XS::Parse::Keyword: file: lib/XS/Parse/Keyword.pm version: '0.44' XS::Parse::Keyword::Builder: file: lib/XS/Parse/Keyword/Builder.pm version: '0.44' requires: File::ShareDir: '1.00' perl: '5.014' resources: license: http://dev.perl.org/licenses/ version: '0.44' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' XS-Parse-Keyword-0.44/README000444001750001750 6323414646455562 14274 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. XPK_FLAG_BLOCKSCOPE The entire parse and build process will be wrapped in a pair of block_start() and block_end() calls. This ensures that, for example, any newly-introduced lexical variables do not escape from the scope of the syntax created by the keyword. 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. Many of the atomic piece types have a variant which is optional; if the given input does not look like the expected syntax for the piece type then an _OPT-suffixed version of the type will instead yield NULL in its result pointer. 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 cv. 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_STAGED_ANONSUB XPK_STAGED_ANONSUB(stages ...) structural, emits cv. A variant of XPK_ANONSUB which accepts additional function pointers to be invoked at various points during parsing and compilation. These can be used to interrupt the normal parsing in a manner similar to XS::Parse::Sublike, though currently somewhat less flexibly. The stages list may contain elements of the following types. Not every stage must be present, but any that are present must be in the following order. Multiple copies of each stage are permitted; they are invoked in the written order, with parser code happening inbetween. XPK_ANONSUB_PREPARE XPK_ANONSUB_PREPARE(&callback) atomic, emits nothing. Invokes the callback before start_subparse(). XPK_ANONSUB_START XPK_ANONSUB_START(&callback) atomic, emits nothing. Invokes the callback after block_start() but before parsing the actual block contents. XPK_ANONSUB_END OP *op_wrapper_callback(pTHX_ OP *o, void *hookdata); XPK_ANONSUB_END(&op_wrapper_callback) atomic, emits nothing. Invokes the callback after parsing the block contents but before calling block_end(). The callback may modify the optree if required and return a new one. XPK_ANONSUB_WRAP XPK_ANONSUB_WRAP(&op_wrapper_callback) atomic, emits nothing. Invokes the callback after block_end() but before passing the optree to newATTRSUB(). The callback may modify the optree if required and return a new one. XPK_ARITHEXPR. XPK_ARITHEXPR_OPT atomic, emits op. XPK_ARITHEXPR An arithmetic expression is expected, parsed using parse_arithexpr(), and passed as an optree in the op field. XPK_ARITHEXPR_VOIDCTX, XPK_ARITHEXPR_OPT XPK_ARITHEXPR_SCALARCTX, XPK_ARITHEXPR_SCALARCTX_OPT Variants of XPK_ARITHEXPR which puts the expression in void or scalar context. XPK_TERMEXPR, XPK_TERMEXPR_OPT 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_VOIDCTX XPK_TERMEXPR_SCALARCTX, XPK_TERMEXPR_SCALARCTX_OPT Variants of XPK_TERMEXPR which puts the expression in void or scalar context. XPK_PREFIXED_TERMEXPR_ENTERLEAVE XPK_PREFIXED_TERMEXPR_ENTERLEAVE(pieces ...) A variant of XPK_TERMEXPR which expects a sequence pieces first before it parses a term expression, similar to how XPK_PREFIXED_BLOCK_ENTERLEAVE works. The entire operation is wrapped in an ENTER/LEAVE pair. This is intended just for use of XPK_SETUP pieces as prefixes. Any other pieces which actually parse real input are likely to cause overly-complex, subtle, or outright ambiguous grammars, and should be avoided. XPK_LISTEXPR, XPK_LISTEXPR_OPT 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, XPK_LISTEXPR_LISTCTX_OPT 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 (::). 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. 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. XPK_LEXVAR atomic, emits padix. XPK_LEXVAR(kind) A lexical variable name is expected and looked up from the current pad. The resulting pad index is passed in the padix field. No error happens if the variable is not found; the value NOT_IN_PAD is passed instead. The kind argument specifies what kinds of variable are permitted, as per XPK_LEXVARNAME. 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_AUTOSEMI atomic, emits nothing. A literal semicolon (;) as a statement terminator is optionally expected. If the next token is a closing brace to indicate the end of a block, then a semicolon is not required. If anything else is encountered an error will be raised. This piece type is the same as specifying the XPK_FLAG_AUTOSEMI. It is useful to put at the end of a sequence that forms part of a choice of syntax, where some forms indicate a statement ending in a semicolon, whereas others may end in a full block that does not need one. 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. XPK_KEYWORD atomic, can probe, emits nothing. XPK_KEYWORD("keyword") A literal string match is expected. No argument value is passed. This is similar to XPK_LITERAL except that it additionally checks that the following character is not an identifier character. This ensures that the expected keyword-like behaviour is preserved. For example, given the input "keyword", the piece XPK_LITERAL("key") would match it, whereas XPK_KEYWORD("key") would not because of the subsequent "w" character. XPK_INTRO_MY atomic, emits nothing. Calls the core perl intro_my() function immediately. No input is consumed and no output value is generated. This is often useful after XPK_LEXVAR_MY. XPK_WARNING atomic, emits nothing. XPK_WARNING("message here") Emits a warning by calling the core perl warn() function on the given string literal. This is equivalent to simply calling warn() from the build function, except that it is emitted immediately at parse time, so line numbering will be more accurate. Also, by placing it as part of an optional or choice sequence, the warning will only be emitted conditionally if that part of the grammar structure is encountered. XPK_WARNING_... Several variants of XPK_WARNING exist that are conditional on particular warning categories being enabled. These are ones that are likely to be useful at parse time: XPK_WARNING_AMBIGUOUS XPK_WARNING_DEPRECATED XPK_WARNING_EXPERIMENTAL XPK_WARNING_PRECEDENCE XPK_WARNING_SYNTAX 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_PARENS structural, can probe, emits nothing. XPK_PARENS(pieces ...) A structural type which expects to find a sequence of pieces, all contained in parentheses as ( ... ). This will pass no extra arguments. XPK_ARGS structural, emits nothing. XPK_ARGS(pieces ...) A structural type similar to XPK_PARENS, except that the parentheses themselves are optional; much like Perl's parsing of calls to known functions. If parentheses are encountered in the input, they will be consumed by this piece and it will behave identically to XPK_PARENS. If there is no open parenthesis, this piece will behave like XPK_SEQUENCE and consume all the pieces inside it, without expecting a closing parenthesis. XPK_BRACKETS structural, can probe, emits nothing. XPK_BRACKETS(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_BRACES structural, can probe, emits nothing. XPK_BRACES(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_CHEVRONS structural, can probe, emits nothing. XPK_CHEVRONS(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_PARENS_OPT, XPK_BRACKETS_OPT, XPK_BRACES_OPT, XPK_CHEVRONS_OPT structural, can probe, emits i. XPK_PARENS_OPT(pieces ...) XPK_BRACKETS_OPT(pieces ...) XPK_BRACES_OPT(pieces ...) XPK_CHEVERONS_OPT(pieces ...) Each of the four contained structure 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. XPK_..._pieces XPK_SEQUENCE_pieces(ptr) XPK_OPTIONAL_pieces(ptr) ... For each of the XPK_... macros that takes a variable-length list of pieces, there is a variant whose name ends with ..._pieces, taking a single pointer argument directly. This must point at a const XSParseKeywordPieceType [] array whose final element is the zero element. Normally hand-written C code of a fixed grammar would be unlikely to use these forms, but they may be useful in dynamically-generated cases. AUTHOR Paul Evans XS-Parse-Keyword-0.44/hax000755001750001750 014646455562 14007 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/hax/force_list_keeping_pushmark.c.inc000444001750001750 133114646455562 22623 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.44/hax/lexer-additions.c.inc000444001750001750 1550614646455562 20202 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; /* Don't get confused by things that look like attrs */ if((flags & LEX_IDENT_PACKAGENAME) && (ident[0] == ':' && ident[1] != ':')) return FALSE; 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.44/hax/make_argcheck_aux.c.inc000444001750001750 132314646455562 20500 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.44/hax/make_argcheck_ops.c.inc000444001750001750 553714646455562 20517 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.44/hax/newOP_CUSTOM.c.inc000444001750001750 1027414646455562 17226 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 newLISTOP_CUSTOM(func, flags, first, last) S_newLISTOP_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_newLISTOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last) { LISTOP *listop; #if HAVE_PERL_VERSION(5,22,0) listop = (LISTOP *)newLISTOP(OP_CUSTOM, flags, first, last); #else NewOp(1101, listop, 1, LISTOP); listop->op_type = (OPCODE)OP_CUSTOM; listop->op_first = first; if(first) first->op_sibling = last; listop->op_last = last; listop->op_flags = (U8)(flags | OPf_KIDS); if(last) listop->op_private = (U8)(2 | (flags >> 8)); else if(first) listop->op_private = (U8)(1 | (flags >> 8)); else listop->op_private = (U8)(flags >> 8); #endif listop->op_ppaddr = func; return (OP *)listop; } 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 = (U8)(1 | (flags >> 8)); /* 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; } #if HAVE_PERL_VERSION(5, 22, 0) # define newUNOP_AUX_CUSTOM(func, flags, first, aux) S_newUNOP_AUX_CUSTOM(aTHX_ func, flags, first, aux) static OP *S_newUNOP_AUX_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, UNOP_AUX_item *aux) { UNOP_AUX *unop; unop = (UNOP_AUX *)newUNOP_AUX(OP_CUSTOM, flags, first, aux); unop->op_ppaddr = func; return (OP *)unop; } #endif XS-Parse-Keyword-0.44/hax/op_sibling_splice.c.inc000444001750001750 167714646455562 20557 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.44/hax/optree-additions.c.inc000444001750001750 516314646455562 20337 0ustar00leoleo000000000000/* vi: set ft=c : */ #define newAELEMOP(flags, first, key) S_newAELEMOP(aTHX_ flags, first, key) static OP *S_newAELEMOP(pTHX_ U32 flags, OP *first, I32 key) { #if HAVE_PERL_VERSION(5,16,0) if(key >= -128 && key < 128 && first->op_type == OP_PADAV) { OP *o = newOP(OP_AELEMFAST_LEX, flags); o->op_private = (I8)key; o->op_targ = first->op_targ; op_free(first); return o; } #endif return newBINOP(OP_AELEM, flags, first, newSVOP(OP_CONST, 0, newSViv(key))); } #if HAVE_PERL_VERSION(5, 22, 0) # define HAVE_UNOP_AUX #endif #ifndef HAVE_UNOP_AUX typedef struct UNOP_with_IV { UNOP baseop; IV iv; } UNOP_with_IV; #define newUNOP_with_IV(type, flags, first, iv) S_newUNOP_with_IV(aTHX_ type, flags, first, iv) static OP *S_newUNOP_with_IV(pTHX_ I32 type, I32 flags, OP *first, IV iv) { /* Cargoculted from perl's op.c:Perl_newUNOP() */ UNOP_with_IV *op = PerlMemShared_malloc(sizeof(UNOP_with_IV) * 1); NewOp(1101, op, 1, UNOP_with_IV); if(!first) first = newOP(OP_STUB, 0); UNOP *unop = (UNOP *)op; unop->op_type = (OPCODE)type; unop->op_first = first; unop->op_ppaddr = NULL; unop->op_flags = (U8)flags | OPf_KIDS; unop->op_private = (U8)(1 | (flags >> 8)); op->iv = iv; return (OP *)op; } #endif #define newMETHOD_REDIR_OP(rclass, methname, flags) S_newMETHOD_REDIR_OP(aTHX_ rclass, methname, flags) static OP *S_newMETHOD_REDIR_OP(pTHX_ SV *rclass, SV *methname, I32 flags) { #if HAVE_PERL_VERSION(5, 22, 0) OP *op = newMETHOP_named(OP_METHOD_REDIR, flags, methname); # ifdef USE_ITHREADS { /* cargoculted from S_op_relocate_sv() */ PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); PAD_SETSV(ix, rclass); cMETHOPx(op)->op_rclass_targ = ix; } # else cMETHOPx(op)->op_rclass_sv = rclass; # endif #else OP *op = newUNOP(OP_METHOD, flags, newSVOP(OP_CONST, 0, newSVpvf("%" SVf "::%" SVf, rclass, methname))); #endif return op; } /* If `@_` is called "snail", then elements of it can be called "slugs"; i.e. * snails without their container */ #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; } #ifndef newLISTOPn /* newLISTOPn was added in 5.39.3 */ # define newLISTOPn(type, flags, ...) S_newLISTOPn(aTHX_ type, flags, __VA_ARGS__) static OP *S_newLISTOPn(pTHX_ OPCODE type, U32 flags, ...) { va_list args; va_start(args, flags); OP *o = newLISTOP(OP_LIST, 0, NULL, NULL); OP *kid; while((kid = va_arg(args, OP *))) o = op_append_elem(OP_LIST, o, kid); va_end(args); return op_convert_list(type, flags, o); } #endif XS-Parse-Keyword-0.44/hax/perl-backcompat.c.inc000444001750001750 1466514646455562 20160 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 PadnameIsSTATE(pn) (!!SvPAD_STATE(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 #if !HAVE_PERL_VERSION(5, 22, 0) # define CvPADLIST_set(cv, padlist) (CvPADLIST(cv) = padlist) # define newPADNAMEpvn(p,n) S_newPADNAMEpvn(aTHX_ p,n) static PADNAME *S_newPADNAMEpvn(pTHX_ const char *pv, STRLEN n) { PADNAME *pn = newSVpvn(pv, n); /* PADNAMEs need to be at least SVt_PVNV in order to store the COP_SEQ_* * fields */ sv_upgrade(pn, SVt_PVNV); return pn; } # define PadnameREFCNT_dec(pn) SvREFCNT_dec(pn) #endif #ifndef av_count # define av_count(av) (AvFILL(av) + 1) #endif #ifndef av_fetch_simple # define av_fetch_simple(av, idx, lval) av_fetch(av, idx, lval) #endif #ifndef av_push_simple # define av_push_simple(av, sv) av_push(av, sv) #endif #ifndef av_store_simple # define av_store_simple(av, key, sv) av_store(av, key, sv) #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 cophh_exists_pvs # define cophh_exists_pvs(a,b,c) cBOOL(cophh_fetch_pvs(a,b,c)) #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 OpHAS_SIBLING # define OpHAS_SIBLING(op) (cBOOL(OpSIBLING(op))) #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) ((op)->op_sibling = NULL) #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) /* PERL_UNUSED_ARG() isn't usable to fix this on early perl versions */ # define isIDFIRST_utf8_safe(s, e) ((void)sizeof(e), isIDFIRST_utf8(s)) # define isIDCONT_utf8_safe(s, e) ((void)sizeof(e), isIDCONT_utf8(s)) #endif #ifndef CXp_EVALBLOCK /* before perl 5.34 this was called CXp_TRYBLOCK */ # define CXp_EVALBLOCK CXp_TRYBLOCK #endif #if !HAVE_PERL_VERSION(5, 26, 0) # define sv_set_undef(sv) sv_setsv(sv, &PL_sv_undef) #endif #ifndef newAVav # define newAVav(av) S_newAVav(aTHX_ av) static AV *S_newAVav(pTHX_ AV *av) { AV *ret = newAV(); U32 count = av_count(av); U32 i; for(i = 0; i < count; i++) av_push(ret, newSVsv(AvARRAY(av)[i])); return ret; } #endif #ifndef newAV_alloc_x # define newAV_alloc_x(n) S_newAV_alloc_x(aTHX_ n) static AV *S_newAV_alloc_x(pTHX_ SSize_t n) { AV *av = newAV(); av_extend(av, n-1); return av; } #endif #if !defined(sv_derived_from_hv) && HAVE_PERL_VERSION(5, 16, 0) # define sv_derived_from_hv(sv, hv) MY_sv_derived_from_hv(aTHX_ sv, hv) static bool MY_sv_derived_from_hv(pTHX_ SV *sv, HV *hv) { char *hvname = HvNAME(hv); if(!hvname) return FALSE; return sv_derived_from_pvn(sv, hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0); } #endif #ifndef xV_FROM_REF # ifdef PERL_USE_GCC_BRACE_GROUPS # define xV_FROM_REF(XV, ref) \ ({ SV *_ref = ref; assert(SvROK(_ref)); assert(SvTYPE(SvRV(_ref)) == SVt_PV ## XV); (XV *)(SvRV(_ref)); }) # else # define xV_FROM_REF(XV, ref) ((XV *)SvRV(ref)) # endif # define AV_FROM_REF(ref) xV_FROM_REF(AV, ref) # define CV_FROM_REF(ref) xV_FROM_REF(CV, ref) # define HV_FROM_REF(ref) xV_FROM_REF(HV, ref) #endif #ifndef newPADxVOP # define newPADxVOP(type, flags, padix) S_newPADxVOP(aTHX_ type, flags, padix) static OP *S_newPADxVOP(pTHX_ I32 type, I32 flags, PADOFFSET padix) { OP *op = newOP(type, flags); op->op_targ = padix; return op; } #endif XS-Parse-Keyword-0.44/hax/wrap_keyword_plugin.c.inc000444001750001750 133114646455562 21151 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.44/inc000755001750001750 014646455562 14000 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/inc/Module000755001750001750 014646455562 15225 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/inc/Module/Build000755001750001750 014646455562 16264 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/inc/Module/Build/with000755001750001750 014646455562 17237 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/inc/Module/Build/with/XSTests.pm000444001750001750 174514646455562 21316 0ustar00leoleo000000000000package Module::Build::with::XSTests; use v5.14; 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.44/lib000755001750001750 014646455562 13775 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/lib/XS000755001750001750 014646455562 14327 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/lib/XS/Parse000755001750001750 014646455562 15401 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/lib/XS/Parse/Infix.pm000444001750001750 5231114646455562 17173 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-2024 -- leonerd@leonerd.org.uk package XS::Parse::Infix 0.44; use v5.14; use warnings; # No actual .xs file; the code is implemented in XS::Parse::Keyword require XS::Parse::Keyword; use Carp; =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. Support for custom infix operators as added in Perl development release C, and is therefore present in Perl C. 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. =head2 Lexically-named vs. Globally-named Operators At version 0.43, the way this module operates has changed. Since this version, the preferred method of operation for infix operators is that the module that registers them creates them with a fully-qualified name (i.e. including the name of the package that implements them). Other code which wishes to import the operator can then provide a local name for it visible within a scope. This acts as an alias for the fully-qualified registered one. The imported name needs not be the same in various scopes - this allows imported operators to be renamed in specific scopes to avoid name clashes. Prior versions of this module only supported operators that have one global name that may or may not be enabled in lexical scopes. With this model, while the visiblity of an operator can be controlled per scope, if it is visible it must always have the same name and cannot be renamed to avoid a name clash. At some future version of this module the older method may be removed, once all of the existing CPAN modules have been updated to the new model. =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 releases of perl yet support this feature, but see above for details of development versions which do. =cut =head1 PERL FUNCTIONS =head2 apply_infix $pkg->apply_infix( $on, $args, @infix ); I Intended to be called by the C and C methods of a module that implements infix operators. This sets up the various keys required in the lexical hints hash to create a lexical alias for the requested operator(s). I<$on> should be a true value for C or a false value for C. I<$args> should be an array reference to the arguments array, which will be modified to splice out recognised values, leaving behind anything else unrecognised. I<@infix> should be a list of names of operators implemented by the importing package, named by I<$pkg>. After invoking this method, the caller should inspect for any remaining values in the arguments array, either to handle them in some other way, or just complain about them. package Some::Infix::Module; sub import { my $pkg = shift; $pkg->XS::Parse::Infix::apply_infix( 1, \@_, qw( operator names here ) ); die "Unrecognised symbols: @_" if @_; } When this module is Cd, named operators are aliased from the fully-qualified names. use Some::Infix::Module qw( operator ); my $z = $x operator $y; At this point, the name C becomes a lexical alias to C. Each imported operator name can optionally be followed by import options, given in a hash reference. Currently the only named option recognised is C<-as>, which allows the importing scope to provide a different name for the imported operator, perhaps to avoid name clashes, or for neatness. use Some::Infix::Module operator => { -as => "myname" }; my $z = $x myname $y; # invokes Some::Infix::Module::operator =cut # helper functions for infix operator modules sub apply_infix { my $pkg = shift; my ( $on, $args, @infix ) = @_; my %infix = map { $_ => 1 } @infix; for ( my $idx = 0; 1; $idx++ ) { $idx < @$args or last; my $name = $args->[$idx]; $infix{$name} or next; splice @$args, $idx, 1, (); my %opts; %opts = %{ splice @$args, $idx, 1, () } if "HASH" eq ref $args->[$idx]; my $localname = $name; $localname = delete $opts{-as} if exists $opts{-as}; croak "Unrecognised apply_infix options " . join( ", ", sort keys %opts ) if %opts; XS::Parse::Infix::check_opname( $localname ) or croak "Local name '$localname' for imported operator $name is invalid"; my $hintkey = "XS::Parse::Infix/$localname"; my $fqname = "${pkg}::${name}"; $on ? $^H{$hintkey} = $fqname : delete $^H{$hintkey}; redo; } } =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 parse_infix bool parse_infix(enum XSParseInfixSelection select, struct XSParseInfixInfo **infop); I This function attempts to parse syntax for an infix operator from the current parser position. If it is successful, it fills in the variable pointed to by I with a pointer to the actual information structure and returns C. If no suitable operator is found, returns C. =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, or by calling L directly. =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, L, or to core perl's C if available. 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; enum XSParseInfixClassification cls; /* since version 0.28 */ }; If the operator name contains any non-ASCII characters they are presumed to be in UTF-8 encoding. This will matter for deparse purposes. If I contains a double-colon (C<::>) sequence, it is presumed to be a fully-qualified operator name in the new interface style. If not, it is presumed to be an older globally-named one. =cut =head1 PARSE HOOKS The C structure provides the following fields which are used at various stages of parsing. struct XSParseInfixHooks { U16 flags; 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, SV **parsedata, void *hookdata); OP *(*ppaddr)(pTHX); /* optional */ void (*parse)(pTHX_ U32 flags, SV **parsedata, void *hookdata); }; =head2 Flags The C field gives details on how to handle the operator overall. It should be a bitmask of the following constants, or left as zero: =over 4 =item XPI_FLAG_LISTASSOC I If set, the operator supports n-way list-associative syntax; written in the form OPERAND op OPERAND op OPERAND op ... In this case, the custom operator will be a LISTOP rather than a BINOP, and every operand of the entire chain will be stored as a child op of it. The op function will need to know how many operands it is working on. There are two ways this may be indicated, depending on whether it was known at compile-time. If the number operands is known at compile-time, the C flag is not set, and the C field indicates the number of operand expressions that were present. If the number is not known (for example, the operator is being used as the body of a generated wrapper function), the C flag is set. The number of arguments will be passed as the UV of an extra SV which is pushed last to the stack. The op function should pop this first to find out. It is typical to begin a list-associative op function with code such as: int n = (PL_op->op_flags & OPf_STACKED) ? POPu : PL_op->op_private; If the operator is list-associative, then C and C must be equal. =back The C and C fields give details on how to handle the left- and right-hand side operands, respectively. It should be set to one of the following constants, or left as zero: =over 4 =item XPI_OPERAND_TERM_LIST The operand 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 same as above. =back Older versions used to provide constants named C and C but they related to an older version of the core perl branch. These names are now aliases for zero, and can be removed from new code. 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 =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 C Stage If the optional C hook function is present, it is called immediately after the parser has recognised the presence of the named operator itself but before it attempts to consume the right-hand side term. This hook function can attempt further parsing, in order to implement more complex syntax such as hyper-operators. When invoked, it is passed a pointer to an C-typed storage variable. It is free to use this variable it desires to store a result, which will then later be made available to the C function. =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 the optional C stage had been present earlier, the C pointer passed here will point to the same storage that C had previously had access to, so it can retrieve the results. If C is not present, then the C will be used instead to construct a new BINOP or LISTOP of the C type. If an earlier C stage had stored additional results into the C variable these will be lost here. =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. If a function of the given name already exists at registration time it will be left undisturbed and no new wrapper will be created. This permits the same infix operator to have multiple spellings of its name; for example to allow both a real Unicode and a fallback ASCII transliteration of the same operator. The first registration will create the wrapper function; the subsequent one will skip it because it would otherwise be identical. Note that when generating an optree for a wrapper function call, the C hook function will be invoked with a C pointer for the C-typed parse data storage, as there won't be an opporunity for the C hook to run in this case. =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 ) = @_; # Cope with list-associatives my $kid = $op->first; my @operands = ( $self->deparse_binop_left( $op, $kid, 14 ) ); $kid = $kid->sibling; while( !B::Deparse::null( $kid ) ) { push @operands, $self->deparse_binop_right( $op, $kid, 14 ); $kid = $kid->sibling; } return join " $opname ", @operands; } =head1 TODO =over 4 =item * Have the entersub checker for list/list operators unwrap arrayref or anon-array argument forms (C or C). =item * Further thoughts about how infix operators with C hooks will work with automatic deparse, and also how to integrate them with L's grammar piece. =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; XS-Parse-Keyword-0.44/lib/XS/Parse/Keyword.pm000444001750001750 6225414646455562 17551 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-2023 -- leonerd@leonerd.org.uk package XS::Parse::Keyword 0.44; 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. =item C The entire parse and build process will be wrapped in a pair of C and C calls. This ensures that, for example, any newly-introduced lexical variables do not escape from the scope of the syntax created by the keyword. =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. Many of the atomic piece types have a variant which is optional; if the given input does not look like the expected syntax for the piece type then an C<_OPT>-suffixed version of the type will instead yield C in its result pointer. 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_STAGED_ANONSUB XPK_STAGED_ANONSUB(stages ...) I A variant of C which accepts additional function pointers to be invoked at various points during parsing and compilation. These can be used to interrupt the normal parsing in a manner similar to L, though currently somewhat less flexibly. The I list may contain elements of the following types. Not every stage must be present, but any that are present must be in the following order. Multiple copies of each stage are permitted; they are invoked in the written order, with parser code happening inbetween. =over 4 =item XPK_ANONSUB_PREPARE XPK_ANONSUB_PREPARE(&callback) I Invokes the callback before C. =item XPK_ANONSUB_START XPK_ANONSUB_START(&callback) I Invokes the callback after C but before parsing the actual block contents. =item XPK_ANONSUB_END OP *op_wrapper_callback(pTHX_ OP *o, void *hookdata); XPK_ANONSUB_END(&op_wrapper_callback) I Invokes the callback after parsing the block contents but before calling C. The callback may modify the optree if required and return a new one. =item XPK_ANONSUB_WRAP XPK_ANONSUB_WRAP(&op_wrapper_callback) I Invokes the callback after C but before passing the optree to C. The callback may modify the optree if required and return a new one. =back =head2 XPK_ARITHEXPR. XPK_ARITHEXPR_OPT I XPK_ARITHEXPR An arithmetic expression is expected, parsed using C, and passed as an optree in the I field. =head2 XPK_ARITHEXPR_VOIDCTX, XPK_ARITHEXPR_OPT =head2 XPK_ARITHEXPR_SCALARCTX, XPK_ARITHEXPR_SCALARCTX_OPT Variants of C which puts the expression in void or scalar context. =head2 XPK_TERMEXPR, XPK_TERMEXPR_OPT 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_VOIDCTX =head2 XPK_TERMEXPR_SCALARCTX, XPK_TERMEXPR_SCALARCTX_OPT Variants of C which puts the expression in void or scalar context. =head2 XPK_PREFIXED_TERMEXPR_ENTERLEAVE XPK_PREFIXED_TERMEXPR_ENTERLEAVE(pieces ...) A variant of C which expects a sequence pieces first before it parses a term expression, similar to how C works. The entire operation is wrapped in an C/C pair. This is intended just for use of C pieces as prefixes. Any other pieces which actually parse real input are likely to cause overly-complex, subtle, or outright ambiguous grammars, and should be avoided. =head2 XPK_LISTEXPR, XPK_LISTEXPR_OPT I XPK_LISTEXPR A list expression is expected, parsed using C, and passed as an optree in the I field. =head2 XPK_LISTEXPR_LISTCTX, XPK_LISTEXPR_LISTCTX_OPT 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<::>). =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. =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. =head2 XPK_LEXVAR I XPK_LEXVAR(kind) A lexical variable name is expected and looked up from the current pad. The resulting pad index is passed in the I field. No error happens if the variable is not found; the value C is passed instead. The C argument specifies what kinds of variable are permitted, as per 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_AUTOSEMI I A literal semicolon (C<;>) as a statement terminator is optionally expected. If the next token is a closing brace to indicate the end of a block, then a semicolon is not required. If anything else is encountered an error will be raised. This piece type is the same as specifying the C. It is useful to put at the end of a sequence that forms part of a choice of syntax, where some forms indicate a statement ending in a semicolon, whereas others may end in a full block that does not need one. =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. =head2 XPK_KEYWORD I XPK_KEYWORD("keyword") A literal string match is expected. No argument value is passed. This is similar to C except that it additionally checks that the following character is not an identifier character. This ensures that the expected keyword-like behaviour is preserved. For example, given the input C<"keyword">, the piece C would match it, whereas C would not because of the subsequent C<"w"> character. =head2 XPK_INTRO_MY I Calls the core perl C function immediately. No input is consumed and no output value is generated. This is often useful after C. =head2 XPK_WARNING I XPK_WARNING("message here") Emits a warning by calling the core perl C function on the given string literal. This is equivalent to simply calling C from the build function, except that it is emitted immediately at parse time, so line numbering will be more accurate. Also, by placing it as part of an optional or choice sequence, the warning will only be emitted conditionally if that part of the grammar structure is encountered. =head2 XPK_WARNING_... Several variants of C exist that are conditional on particular warning categories being enabled. These are ones that are likely to be useful at parse time: XPK_WARNING_AMBIGUOUS XPK_WARNING_DEPRECATED XPK_WARNING_EXPERIMENTAL XPK_WARNING_PRECEDENCE XPK_WARNING_SYNTAX =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_PARENS I XPK_PARENS(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_ARGS I XPK_ARGS(pieces ...) A structural type similar to C, except that the parentheses themselves are optional; much like Perl's parsing of calls to known functions. If parentheses are encountered in the input, they will be consumed by this piece and it will behave identically to C. If there is no open parenthesis, this piece will behave like C and consume all the pieces inside it, without expecting a closing parenthesis. =head2 XPK_BRACKETS I XPK_BRACKETS(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_BRACES I XPK_BRACES(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_CHEVRONS I XPK_CHEVRONS(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_PARENS_OPT, XPK_BRACKETS_OPT, XPK_BRACES_OPT, XPK_CHEVRONS_OPT I XPK_PARENS_OPT(pieces ...) XPK_BRACKETS_OPT(pieces ...) XPK_BRACES_OPT(pieces ...) XPK_CHEVERONS_OPT(pieces ...) Each of the four contained structure 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. =head2 XPK_..._pieces XPK_SEQUENCE_pieces(ptr) XPK_OPTIONAL_pieces(ptr) ... For each of the C macros that takes a variable-length list of pieces, there is a variant whose name ends with C<..._pieces>, taking a single pointer argument directly. This must point at a C array whose final element is the zero element. Normally hand-written C code of a fixed grammar would be unlikely to use these forms, but they may be useful in dynamically-generated cases. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; XS-Parse-Keyword-0.44/lib/XS/Parse/Keyword.xs000444001750001750 640214646455562 17540 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-2024 -- 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" /* v1 hooks.newop did not pass parsedata */ struct XSParseInfixHooks_v1 { U16 flags; U8 lhs_flags, 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); OP *(*parse_rhs)(pTHX_ void *hookdata); }; static void XSParseInfix_register_v1(pTHX_ const char *opname, const struct XSParseInfixHooks_v1 *hooks_v1, void *hookdata) { if(hooks_v1->rhs_flags & (1 << 7) /* was XPI_OPERAND_CUSTOM */) croak("XPI_OPERAND_CUSTOM is no longer supported"); if(hooks_v1->parse_rhs) croak("XSParseInfixHooks.parse_rhs is no longer supported"); struct XSParseInfixHooks *hooks; Newx(hooks, 1, struct XSParseInfixHooks); hooks->flags = hooks_v1->flags | (1<<15) /* NO_PARSEDATA */; hooks->lhs_flags = hooks_v1->lhs_flags; hooks->rhs_flags = hooks_v1->rhs_flags; hooks->cls = hooks_v1->cls; hooks->wrapper_func_name = hooks_v1->wrapper_func_name; hooks->permit_hintkey = hooks_v1->permit_hintkey; hooks->permit = hooks_v1->permit; hooks->new_op = (OP *(*)(pTHX_ U32, OP *, OP *, SV **, void *))hooks_v1->new_op; hooks->ppaddr = hooks_v1->ppaddr; hooks->parse = NULL; XSParseInfix_register(aTHX_ opname, hooks, hookdata); } MODULE = XS::Parse::Keyword PACKAGE = XS::Parse::Infix bool check_opname(SV *opname) CODE: { STRLEN namelen; const char *namepv = SvPV(opname, namelen); RETVAL = XSParseInfix_check_opname(aTHX_ namepv, namelen); } OUTPUT: RETVAL 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), 1); sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/ABIVERSION_MAX", 1), XSPARSEINFIX_ABI_VERSION); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/parse()@2", 1), PTR2UV(&XSParseInfix_parse)); 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()@1", 1), PTR2UV(&XSParseInfix_register_v1)); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/register()@2", 1), PTR2UV(&XSParseInfix_register)); XSParseInfix_boot(aTHX); XS-Parse-Keyword-0.44/lib/XS/Parse/Infix000755001750001750 014646455562 16456 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/lib/XS/Parse/Infix/Builder.pm000444001750001750 412414646455562 20540 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.44; 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; This method no longer does anything I. =cut sub write_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; require File::ShareDir; require File::Spec; return "-I" . File::Spec->catdir( File::ShareDir::dist_dir( "XS-Parse-Keyword" ), "include" ), 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 ) = @_; # 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.44/lib/XS/Parse/Infix/Builder_data.pm.PL000444001750001750 141314646455562 22041 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 ); __DATA__ package XS::Parse::Infix::Builder_data 0.44; use v5.14; use warnings; # Additional CFLAGS arguments to pass during compilation use constant BUILDER_CFLAGS => __BUILDER_CFLAGS__; 0x55AA; XS-Parse-Keyword-0.44/lib/XS/Parse/Keyword000755001750001750 014646455562 17025 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/lib/XS/Parse/Keyword/Builder.pm000444001750001750 416214646455562 21111 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.44; 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 use XS::Parse::Keyword::Builder_data; =head1 FUNCTIONS =cut =head2 write_XSParseKeyword_h XS::Parse::Keyword::Builder->write_XSParseKeyword_h; This method no longer does anything I. =cut sub write_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; require File::ShareDir; require File::Spec; return "-I" . File::Spec->catdir( File::ShareDir::dist_dir( "XS-Parse-Keyword" ), "include" ), 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 ) = @_; # 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.44/lib/XS/Parse/Keyword/Builder_data.pm.PL000444001750001750 141514646455562 22412 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 ); __DATA__ package XS::Parse::Keyword::Builder_data 0.44; use v5.14; use warnings; # Additional CFLAGS arguments to pass during compilation use constant BUILDER_CFLAGS => __BUILDER_CFLAGS__; 0x55AA; XS-Parse-Keyword-0.44/share000755001750001750 014646455562 14331 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/share/include000755001750001750 014646455562 15754 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/share/include/XSParseInfix.h000444001750001750 1331514646455562 20630 0ustar00leoleo000000000000#ifndef __XS_PARSE_INFIX_H__ #define __XS_PARSE_INFIX_H__ #define XSPARSEINFIX_ABI_VERSION 2 /* 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 <=> */ /* Since the _MISC categories never turn up in selections, put them at high * index so as to leave space for more */ XPI_CLS_LOW_MISC = 0x80, /* an operator at low precedence */ XPI_CLS_LOGICAL_OR_LOW_MISC, XPI_CLS_LOGICAL_AND_LOW_MISC, XPI_CLS_ASSIGN_MISC, XPI_CLS_LOGICAL_OR_MISC, XPI_CLS_LOGICAL_AND_MISC, XPI_CLS_ADD_MISC, /* an operator at addition-like precedence */ XPI_CLS_MUL_MISC, /* an operator at multiplication-like precedence */ XPI_CLS_POW_MISC, /* an operator at power exponentiation-like precedence */ XPI_CLS_HIGH_MISC, /* an operator at high precedence */ }; 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 */ }; /* flags */ enum { XPI_FLAG_LISTASSOC = (1<<0), }; /* lhs_flags, rhs_flags */ enum { 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, SV **parsedata, void *hookdata); OP *(*ppaddr)(pTHX); /* A pp func used directly in newBINOP_custom() */ /* optional */ void (*parse)(pTHX_ U32 flags, SV **parsedata, void *hookdata); }; struct XSParseInfixInfo { const char *opname; OPCODE opcode; const struct XSParseInfixHooks *hooks; void *hookdata; enum XSParseInfixClassification cls; }; static bool (*parse_infix_func)(pTHX_ enum XSParseInfixSelection select, struct XSParseInfixInfo **infop); #define parse_infix(select, infop) S_parse_infix(aTHX_ select, infop) static bool S_parse_infix(pTHX_ enum XSParseInfixSelection select, struct XSParseInfixInfo **infop) { if(!parse_infix_func) croak("Must call boot_xs_parse_infix() first"); struct XSParseInfixInfo *infocopy; return (*parse_infix_func)(aTHX_ select, infop); } 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; load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("XS::Parse::Infix"), 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); parse_infix_func = INT2PTR(bool (*)(pTHX_ enum XSParseInfixSelection, struct XSParseInfixInfo **), SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Infix/parse()@2", 0))); 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()@2", 0))); } #endif XS-Parse-Keyword-0.44/share/include/XSParseKeyword.h000444001750001750 3564714646455562 21213 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; /* containers */ void (*callback)(pTHX_ void *hookdata); /* SETUP, ANONSUB PREPARE+START */ OP *(*op_wrap_callback)(pTHX_ OP *o, void *hookdata); } u; }; enum { XPK_FLAG_EXPR = (1<<0), XPK_FLAG_STMT = (1<<1), XPK_FLAG_AUTOSEMI = (1<<2), XPK_FLAG_BLOCKSCOPE = (1<<3), }; enum { /* skip zero */ /* emits */ XS_PARSE_KEYWORD_LITERALCHAR = 1, /* nothing */ XS_PARSE_KEYWORD_LITERALSTR, /* nothing */ XS_PARSE_KEYWORD_AUTOSEMI, /* nothing */ XS_PARSE_KEYWORD_WARNING = 0x0e, /* nothing */ XS_PARSE_KEYWORD_FAILURE, /* nothing */ XS_PARSE_KEYWORD_BLOCK = 0x10, /* op */ XS_PARSE_KEYWORD_ANONSUB, /* cv */ XS_PARSE_KEYWORD_ARITHEXPR, /* op */ XS_PARSE_KEYWORD_TERMEXPR, /* 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_INTRO_MY = 0x60, /* emits nothing */ XS_PARSE_KEYWORD_SETUP = 0x70, /* invokes callback, emits nothing */ XS_PARSE_KEYWORD_ANONSUB_PREPARE, /* invokes callback, emits nothing */ XS_PARSE_KEYWORD_ANONSUB_START, /* invokes callback, emits nothing */ XS_PARSE_KEYWORD_ANONSUB_END, /* invokes op_wrap_callback, emits nothing */ XS_PARSE_KEYWORD_ANONSUB_WRAP, /* invokes op_wrap_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_PARENS = 0xb0, /* contained */ XS_PARSE_KEYWORD_BRACKETS, /* contained */ XS_PARSE_KEYWORD_BRACES, /* contained */ XS_PARSE_KEYWORD_CHEVRONS, /* 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_LITERALSTR: keyword 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 */ XPK_TYPEFLAG_MAYBEPARENS = (1<<21), /* parens themselves are optional on PARENS */ }; #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_ANONSUB_PREPARE(func) {.type = XS_PARSE_KEYWORD_ANONSUB_PREPARE, .u.callback = func} #define XPK_ANONSUB_START(func) {.type = XS_PARSE_KEYWORD_ANONSUB_START, .u.callback = func} #define XPK_ANONSUB_END(func) {.type = XS_PARSE_KEYWORD_ANONSUB_END, .u.op_wrap_callback = func} #define XPK_ANONSUB_WRAP(func) {.type = XS_PARSE_KEYWORD_ANONSUB_WRAP, .u.op_wrap_callback = func} #define XPK_STAGED_ANONSUB(...) \ {.type = XS_PARSE_KEYWORD_ANONSUB, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_ARITHEXPR_flags(flags) {.type = XS_PARSE_KEYWORD_ARITHEXPR|(flags)} #define XPK_ARITHEXPR XPK_ARITHEXPR_flags(0) #define XPK_ARITHEXPR_VOIDCTX XPK_ARITHEXPR_flags(XPK_TYPEFLAG_G_VOID) #define XPK_ARITHEXPR_SCALARCTX XPK_ARITHEXPR_flags(XPK_TYPEFLAG_G_SCALAR) #define XPK_ARITHEXPR_OPT XPK_ARITHEXPR_flags(XPK_TYPEFLAG_OPT) #define XPK_ARITHEXPR_VOIDCTX_OPT XPK_ARITHEXPR_flags(XPK_TYPEFLAG_G_VOID|XPK_TYPEFLAG_OPT) #define XPK_ARITHEXPR_SCALARCTX_OPT XPK_ARITHEXPR_flags(XPK_TYPEFLAG_G_SCALAR|XPK_TYPEFLAG_OPT) #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_TERMEXPR_OPT XPK_TERMEXPR_flags(XPK_TYPEFLAG_OPT) #define XPK_TERMEXPR_VOIDCTX_OPT XPK_TERMEXPR_flags(XPK_TYPEFLAG_G_VOID|XPK_TYPEFLAG_OPT) #define XPK_TERMEXPR_SCALARCTX_OPT XPK_TERMEXPR_flags(XPK_TYPEFLAG_G_SCALAR|XPK_TYPEFLAG_OPT) #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_LISTEXPR_OPT XPK_LISTEXPR_flags(XPK_TYPEFLAG_OPT) #define XPK_LISTEXPR_LISTCTX_OPT XPK_LISTEXPR_flags(XPK_TYPEFLAG_G_LIST|XPK_TYPEFLAG_OPT) #define XPK_PREFIXED_TERMEXPR_flags(flags,...) \ {.type = XS_PARSE_KEYWORD_TERMEXPR|(flags), .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_PREFIXED_TERMEXPR_ENTERLEAVE(...) XPK_PREFIXED_TERMEXPR_flags(XPK_TYPEFLAG_ENTERLEAVE, __VA_ARGS__) #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(kind) {.type = XS_PARSE_KEYWORD_LEXVAR, .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_AUTOSEMI {.type = XS_PARSE_KEYWORD_AUTOSEMI} #define XPK_KEYWORD(s) {.type = XS_PARSE_KEYWORD_LITERALSTR|XPK_TYPEFLAG_SPECIAL, .u.str = (const char *)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_INTRO_MY {.type = XS_PARSE_KEYWORD_INTRO_MY} #define XPK_SEQUENCE_pieces(p) {.type = XS_PARSE_KEYWORD_SEQUENCE, .u.pieces = p} #define XPK_SEQUENCE(...) XPK_SEQUENCE_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) /* First piece of these must be something probe-able */ #define XPK_OPTIONAL_pieces(p) {.type = XS_PARSE_KEYWORD_SEQUENCE|XPK_TYPEFLAG_OPT, .u.pieces = p} #define XPK_OPTIONAL(...) XPK_OPTIONAL_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) #define XPK_REPEATED_pieces(p) {.type = XS_PARSE_KEYWORD_REPEATED, .u.pieces = p} #define XPK_REPEATED(...) XPK_REPEATED_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) /* Every piece must be probeable */ #define XPK_CHOICE_pieces(p) {.type = XS_PARSE_KEYWORD_CHOICE, .u.pieces = p} #define XPK_CHOICE(...) XPK_CHOICE_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) /* Every piece must be probeable, and followed by XPK_TAG */ #define XPK_TAGGEDCHOICE_pieces(p) {.type = XS_PARSE_KEYWORD_TAGGEDCHOICE, .u.pieces = p} #define XPK_TAGGEDCHOICE(...) XPK_TAGGEDCHOICE_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_WARNING_bit(bit,s) {.type = (XS_PARSE_KEYWORD_WARNING|(bit << 24)), .u.str = (const char *)s} #define XPK_WARNING(s) XPK_WARNING_bit(0,s) #define XPK_WARNING_AMBIGUOUS(s) XPK_WARNING_bit(WARN_AMBIGUOUS, s) #define XPK_WARNING_DEPRECATED(s) XPK_WARNING_bit(WARN_DEPRECATED, s) #define XPK_WARNING_EXPERIMENTAL(s) XPK_WARNING_bit(WARN_EXPERIMENTAL,s) #define XPK_WARNING_PRECEDENCE(s) XPK_WARNING_bit(WARN_PRECEDENCE, s) #define XPK_WARNING_SYNTAX(s) XPK_WARNING_bit(WARN_SYNTAX, s) #define XPK_FAILURE(s) {.type = XS_PARSE_KEYWORD_FAILURE, .u.str = (const char *)s} #define XPK_PARENS_pieces(p) {.type = XS_PARSE_KEYWORD_PARENS, .u.pieces = p} #define XPK_PARENS(...) XPK_PARENS_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) #define XPK_PARENS_OPT(...) \ {.type = XS_PARSE_KEYWORD_PARENS|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_ARGS_pieces(p) {.type = XS_PARSE_KEYWORD_PARENS|XPK_TYPEFLAG_MAYBEPARENS, .u.pieces = p} #define XPK_ARGS(...) XPK_ARGS_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) #define XPK_BRACKETS_pieces(p) {.type = XS_PARSE_KEYWORD_BRACKETS, .u.pieces = p} #define XPK_BRACKETS(...) XPK_BRACKETS_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) #define XPK_BRACKETS_OPT(...) \ {.type = XS_PARSE_KEYWORD_BRACKETS|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_BRACES_pieces(p) {.type = XS_PARSE_KEYWORD_BRACES, .u.pieces = p} #define XPK_BRACES(...) XPK_BRACES_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) #define XPK_BRACES_OPT(...) \ {.type = XS_PARSE_KEYWORD_BRACES|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} #define XPK_CHEVRONS_pieces(p) {.type = XS_PARSE_KEYWORD_CHEVRONS, .u.pieces = p} #define XPK_CHEVRONS(...) XPK_CHEVRONS_pieces(((const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} })) #define XPK_CHEVRONS_OPT(...) \ {.type = XS_PARSE_KEYWORD_CHEVRONS|XPK_TYPEFLAG_OPT, .u.pieces = (const struct XSParseKeywordPieceType []){ __VA_ARGS__, {0} }} /* back-compat for older names */ #define XPK_PARENSCOPE_pieces XPK_PARENS_pieces #define XPK_PARENSCOPE XPK_PARENS #define XPK_PARENSCOPE_OPT XPK_PARENS_OPT #define XPK_ARGSCOPE_pieces XPK_ARGS_pieces #define XPK_ARGSCOPE XPK_ARGS #define XPK_BRACKETSCOPE_pieces XPK_BRACKETS_pieces #define XPK_BRACKETSCOPE XPK_BRACKETS #define XPK_BRACKETSCOPE_OPT XPK_BRACKETS_OPT #define XPK_BRACESCOPE_pieces XPK_BRACES_pieces #define XPK_BRACESCOPE XPK_BRACES #define XPK_BRACESCOPE_OPT XPK_BRACES_OPT #define XPK_CHEVRONSCOPE_pieces XPK_CHEVRONS_pieces #define XPK_CHEVRONSCOPE XPK_CHEVRONS #define XPK_CHEVRONSCOPE_OPT XPK_CHEVRONS_OPT /* 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.44/src000755001750001750 014646455562 14016 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/src/infix.c000444001750001750 10170514646455562 15500 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-2024 -- 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 "optree-additions.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,37,7) # define HAVE_PL_INFIX_PLUGIN #endif #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, SHAPE_LISTASSOC_SCALARS, SHAPE_LISTASSOC_LISTS, }; static enum OperandShape operand_shape(const struct HooksAndData *hd) { U8 lhs_gimme; switch(hd->hooks->lhs_flags & 0x07) { case 0: lhs_gimme = G_SCALAR; break; case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: lhs_gimme = G_LIST; break; default: croak("TODO: Unsure how to classify operand shape of .lhs_flags=%02X\n", hd->hooks->lhs_flags & 0x07); } if(hd->hooks->flags & XPI_FLAG_LISTASSOC) { switch(lhs_gimme) { case G_SCALAR: return SHAPE_LISTASSOC_SCALARS; case G_LIST: return SHAPE_LISTASSOC_LISTS; } } U8 rhs_gimme; switch(hd->hooks->rhs_flags & 0x07) { case 0: rhs_gimme = G_SCALAR; break; case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: rhs_gimme = G_LIST; break; default: croak("TODO: Unsure how to classify operand shape of .rhs_flags=%02X\n", hd->hooks->rhs_flags & 0x07); } switch((lhs_gimme << 4) | (rhs_gimme)) { /* scalar OP scalar */ case (G_SCALAR<<4) | G_SCALAR: return SHAPE_SCALARSCALAR; /* scalar OP list */ case (G_SCALAR<<4) | G_LIST: return SHAPE_SCALARLIST; /* list OP list */ case (G_LIST<<4) | G_LIST: return SHAPE_LISTLIST; default: croak("TODO: Unsure how to classify operand shape of lhs_gimme=%d rhs_gimme=%d\n", lhs_gimme, rhs_gimme); 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; struct HooksAndData hd; STRLEN permit_hintkey_len; int opname_is_WIDE : 1; int opname_is_ident : 1; int opname_is_fq : 1; }; static struct Registration *registrations, /* for legacy-style global key-enabled ones */ *fqregistrations; /* for new lexically named ones */ static OP *new_op(pTHX_ const struct HooksAndData hd, U32 flags, OP *lhs, OP *rhs, SV **parsedata) { if(hd.hooks->new_op) { if(hd.hooks->flags & (1<<15)) { OP *(*new_op_v1)(pTHX_ U32, OP *, OP *, void *) = (OP *(*)(pTHX_ U32, OP *, OP *, void *))hd.hooks->new_op; return (*new_op_v1)(aTHX_ flags, lhs, rhs, hd.data); /* no parsedata */ } return (*hd.hooks->new_op)(aTHX_ flags, lhs, rhs, parsedata, hd.data); } OP *ret; if(hd.hooks->flags & XPI_FLAG_LISTASSOC) { OP *listop = lhs; /* Skip an ex-list + pushmark structure */ if(listop->op_type == OP_NULL && cUNOPx(listop)->op_first && cUNOPx(listop)->op_first->op_type == OP_PUSHMARK) listop = OpSIBLING(cUNOPx(listop)->op_first); if(listop && listop->op_type == OP_CUSTOM && listop->op_ppaddr == hd.hooks->ppaddr && !(listop->op_flags & OPf_PARENS)) { /* combine new operand with existing listop */ if(listop->op_private == 255) croak("TODO: Unable to handle a list-associative infix operator with > 255 operands"); OP *last = cLISTOPx(listop)->op_last; OpMORESIB_set(last, rhs); cLISTOPx(listop)->op_last = rhs; OpLASTSIB_set(rhs, listop); listop->op_private++; ret = lhs; } else { /* base case */ ret = newLISTOP_CUSTOM(hd.hooks->ppaddr, flags, lhs, rhs); ret->op_private = 2; } } else 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; cLISTOPx(cUNOPo->op_first)->op_flags &= ~OPf_KIDS; 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; cLISTOPx(cUNOPo->op_first)->op_flags &= ~OPf_KIDS; 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)); } enum { FINDREG_SKIP_BUILTIN = (1<<0), }; #define find_reg(op, oplen, regp, flags) S_find_reg(aTHX_ op, oplen, regp, flags) static STRLEN S_find_reg(pTHX_ const char *op, STRLEN oplen, struct Registration **regp, U32 flags) { HV *hints = GvHV(PL_hintgv); /* New-style lexically named operators */ { bool opname_is_ident = isIDFIRST_utf8_safe(op, op + oplen); SV *keysv = sv_newmortal(); for(int len = oplen; len > 0; len--) { sv_setpvf(keysv, "XS::Parse::Infix/%.*s", len, op); HE *ophe = hv_fetch_ent(hints, keysv, 0, 0); if(!ophe && opname_is_ident) break; if(!ophe) continue; /* We found something suitable. Commit to this or fail */ char *fqop = SvPVX(HeVAL(ophe)); STRLEN fqoplen = SvCUR(HeVAL(ophe)); for(struct Registration *reg = fqregistrations; reg; reg = reg->next) { if(!reg->hd.hooks) continue; if(reg->oplen != fqoplen || !strEQ(reg->info.opname, fqop)) continue; if(reg->hd.hooks->permit && !(*reg->hd.hooks->permit)(aTHX_ reg->hd.data)) continue; *regp = reg; return len; } croak("XS::Parse::Infix does not know of a registered infix operator named '%" SVf "'", SVfARG(HeVAL(ophe))); } } /* Legacy hinthash-enabled global operators */ struct Registration *reg, *bestreg = NULL; for(reg = registrations; reg; reg = reg->next) { /* custom registrations have hooks, builtin ones do not */ if((flags & FINDREG_SKIP_BUILTIN) && !reg->hd.hooks) continue; if(reg->oplen > oplen || !strnEQ(reg->info.opname, op, reg->oplen)) continue; /* names like identifiers must match the whole length */ if(reg->opname_is_ident && reg->oplen != oplen) 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; /* This is a candidate and the best one, unless we already have something * longer */ if(bestreg && bestreg->oplen > reg->oplen) continue; bestreg = reg; } if(!bestreg) return 0; *regp = bestreg; return bestreg->oplen; } #ifdef HAVE_PL_INFIX_PLUGIN static void parse(pTHX_ SV **parsedata, struct Perl_custom_infix *def) { struct Registration *reg = (struct Registration *)def; (*reg->hd.hooks->parse)(aTHX_ 0, parsedata, reg->hd.data); } static OP *build_op(pTHX_ SV **parsedata, OP *lhs, OP *rhs, struct Perl_custom_infix *def) { struct Registration *reg = (struct Registration *)def; switch(reg->hd.hooks->lhs_flags & 0x07) { case 0: break; case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: lhs = force_list_keeping_pushmark(lhs); break; } /* TODO: maybe operator has a 'parse' hook? */ switch(reg->hd.hooks->rhs_flags & 0x07) { case 0: break; case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: rhs = force_list_keeping_pushmark(rhs); break; } return new_op(aTHX_ reg->hd, 0, lhs, rhs, parsedata); } 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); struct Registration *reg = NULL; STRLEN consumed = find_reg(op, oplen, ®, FINDREG_SKIP_BUILTIN); if(!consumed) return (*next_infix_plugin)(aTHX_ op, oplen, def); *def = ®->def; return consumed; } #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 *op = PL_parser->bufptr, *opend; if(isIDFIRST_utf8_safe(op, PL_parser->bufend)) { /* If the operator name is an identifer then we don't want to capture a * longer identifier from the incoming source of which this is just a * prefix */ opend = op + UTF8SKIP(op); while(opend < PL_parser->bufend && isIDCONT_utf8_safe(opend, PL_parser->bufend)) opend += UTF8SKIP(opend); } else { opend = PL_parser->bufend; } struct Registration *reg = NULL; STRLEN consumed = find_reg(op, opend - op, ®, 0); if(!consumed) return FALSE; if(!(selection & (1 << reg->info.cls))) return FALSE; *infop = ®->info; lex_read_to(PL_parser->bufptr + consumed); return TRUE; } 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, NULL); 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, NULL); } 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), NULL); } static OP *ckcall_wrapper_func_listassoc_scalars(pTHX_ OP *op, GV *namegv, SV *ckobj) { struct HooksAndData *hd = NUM2PTR(struct HooksAndData *, SvUV(ckobj)); /* We'll convert this if it looks like a compiletime-constant number of * scalar arguments */ assert(op->op_type == OP_ENTERSUB); 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; kid = OpSIBLING(kid); OP *firstarg = kid, *lastarg; int argcount = 0; OP *nextkid; while(kid && (nextkid = OpSIBLING(kid))) { if(!op_yields_oneval(kid)) goto no_wrapper; argcount++; lastarg = kid; kid = nextkid; } /* kid now points at final op which is the gvop of the OP_ENTERSUB */ if(!argcount) { op_free(op); return newLISTOP_CUSTOM(hd->hooks->ppaddr, 0, NULL, NULL); } /* Splice out the args list and throw away the old optree */ OpMORESIB_set(pushmark, kid); op_free(op); /* newLISTOP_CUSTOM doesn't quite handle already created child op chains. We * must pass in NULL then set the child ops manually */ op = newLISTOP_CUSTOM(hd->hooks->ppaddr, 0, NULL, NULL); op->op_private = argcount; op->op_flags |= OPf_KIDS; cLISTOPx(op)->op_first = firstarg; cLISTOPx(op)->op_last = lastarg; OpLASTSIB_set(lastarg, op); return op; no_wrapper: op = ck_entersub_args_proto_or_list(op, namegv, &PL_sv_undef); return op; } static OP *ckcall_wrapper_func_listassoc_lists(pTHX_ OP *op, GV *namegv, SV *ckobj) { struct HooksAndData *hd = NUM2PTR(struct HooksAndData *, SvUV(ckobj)); /* We'll convert this if it looks like a compiletime-constant number of * scalar arguments */ assert(op->op_type == OP_ENTERSUB); 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; kid = OpSIBLING(kid); OP *firstarg = kid, *lastarg; int argcount = 0; OP *nextkid; while(kid && (nextkid = OpSIBLING(kid))) { if(!op_yields_oneval(kid)) goto no_wrapper; argcount++; lastarg = kid; kid = nextkid; } /* kid now points at final op which is the gvop of the OP_ENTERSUB */ if(!argcount) { op_free(op); return newLISTOP_CUSTOM(hd->hooks->ppaddr, 0, NULL, NULL); } /* Splice out the args list and throw away the old optree */ OpMORESIB_set(pushmark, kid); OpLASTSIB_set(lastarg, NULL); op_free(op); /* We now need to unwrap_list() on each of the args ops */ kid = firstarg; firstarg = NULL; lastarg = NULL; while(kid) { OP *nextkid = OpSIBLING(kid); OpLASTSIB_set(kid, NULL); OP *newkid = unwrap_list(kid, hd->hooks->lhs_flags & XPI_OPERAND_ONLY_LOOK); if(lastarg) OpMORESIB_set(lastarg, newkid); if(!firstarg) firstarg = newkid; lastarg = newkid; kid = nextkid; } /* newLISTOP_CUSTOM doesn't quite handle already created child op chains. We * must pass in NULL and then set the child ops manually */ op = newLISTOP_CUSTOM(hd->hooks->ppaddr, 0, NULL, NULL); op->op_private = argcount; op->op_flags |= OPf_KIDS; cLISTOPx(op)->op_first = firstarg; cLISTOPx(op)->op_last = lastarg; OpLASTSIB_set(lastarg, op); return op; no_wrapper: op = ck_entersub_args_proto_or_list(op, namegv, &PL_sv_undef); return op; } static OP *pp_push_defav_with_count(pTHX) { dSP; AV *defav = GvAV(PL_defgv); bool explode = (PL_op->op_flags & OPf_SPECIAL); U32 count = av_count(defav); SV **svp = AvARRAY(defav); if(!explode) EXTEND(SP, count); for(U32 i = 0; i < count; i++) if(explode) { if(!SvRV(svp[i]) || SvTYPE(SvRV(svp[i])) != SVt_PVAV) croak("Expected an ARRAY reference, got %" SVf, SVfARG(svp[i])); AV *av = (AV *)SvRV(svp[i]); PUSHMARK(SP); U32 acount = av_count(av); SV **asvp = AvARRAY(av); EXTEND(SP, acount); for(U32 i = 0; i < acount; i++) PUSHs(asvp[i]); } else PUSHs(svp[i]); mXPUSHu(count); RETURN; } static void make_wrapper_func(pTHX_ const struct HooksAndData *hd) { SV *funcname = newSVpvn(hd->hooks->wrapper_func_name, strlen(hd->hooks->wrapper_func_name)); GV *gv; if((gv = gv_fetchsv(funcname, 0, 0)) && GvCV(gv)) { /* The wrapper function already exists. We presume this is due to a duplicate * registration of identical hooks under a different name and just skip */ return; } /* Prepare to make a new optree-based CV */ I32 floor_ix = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); 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), NULL)); 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))), NULL)); /* 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))), NULL)); ckcall = &ckcall_wrapper_func_listlist; break; case SHAPE_LISTASSOC_SCALARS: if(hd->hooks->new_op) croak("TODO: Cannot make wrapper func for list-associative operator that has hooks->new_op"); body = op_append_list(OP_LINESEQ, body, newSTATEOP(0, NULL, NULL)); /* Body of the function invokes the op with the values from @_, and an extra IV giving the count */ body = op_append_list(OP_LINESEQ, body, newLISTOP_CUSTOM(hd->hooks->ppaddr, OPf_STACKED, newOP_CUSTOM(&pp_push_defav_with_count, 0), NULL)); ckcall = &ckcall_wrapper_func_listassoc_scalars; break; case SHAPE_LISTASSOC_LISTS: if(hd->hooks->new_op) croak("TODO: Cannot make wrapper func for list-associative operator that has hooks->new_op"); body = op_append_list(OP_LINESEQ, body, newSTATEOP(0, NULL, NULL)); /* Body of the function invokes the op with the values from all the * ARRAYs refed by @_, plus marks on the markstack, and an extra IV * giving the count */ body = op_append_list(OP_LINESEQ, body, newLISTOP_CUSTOM(hd->hooks->ppaddr, OPf_STACKED /* explode */, newOP_CUSTOM(&pp_push_defav_with_count, OPf_SPECIAL), NULL)); ckcall = &ckcall_wrapper_func_listassoc_lists; 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; SV *opnamesv; bool infix_is_visible = FALSE; /* Operator visibility rules differ for fully-qualified operator names */ if(reg->opname_is_fq) { hv_iterinit(hinthash); HE *he; while((he = hv_iternext(hinthash))) { #define PREFIXLEN 17 STRLEN len; if(!strnEQ(HePV(he, len), "XS::Parse::Infix/", PREFIXLEN)) continue; if(!strEQ(SvPV_nolen(HeVAL(he)), reg->info.opname)) continue; infix_is_visible = TRUE; opnamesv = newSVpvn_flags(HePV(he, len) + PREFIXLEN, len - PREFIXLEN, HeUTF8(he) ? SVf_UTF8 : 0); break; } } else { infix_is_visible = (hinthash && hv_fetch(hinthash, reg->hd.hooks->permit_hintkey, reg->permit_hintkey_len, 0)); opnamesv = newSVpvn_flags(reg->info.opname, reg->oplen, reg->opname_is_WIDE ? SVf_UTF8 : 0); } if(infix_is_visible) { ENTER; SAVETMPS; EXTEND(SP, 4); PUSHMARK(SP); PUSHs(deparseobj); mPUSHs(opnamesv); 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->info.cls = cls; reg->oplen = strlen(opname); reg->opname_is_ident = isIDFIRST_utf8_safe(opname, opname + strlen(opname)); reg->hd.hooks = NULL; reg->hd.data = NULL; reg->permit_hintkey_len = 0; { reg->next = registrations; registrations = reg; } } bool XSParseInfix_check_opname(pTHX_ const char *opname, STRLEN oplen) { const char *opname_end = opname + oplen; bool opname_is_fq = strstr(opname, "::") != NULL; bool opname_is_ident = !opname_is_fq && isIDFIRST_utf8_safe(opname, opname_end); const char *s = opname; s += UTF8SKIP(s); while(s < opname_end) { if(opname_is_ident) { if(!isIDCONT_utf8_safe(s, opname_end)) // name that starts with an identifier may not have non-identifier characters in it return FALSE; } else { if(isIDFIRST_utf8_safe(s, opname_end)) // name that does not start with an identifer may not have identifier characters in it return FALSE; } s += UTF8SKIP(s); } return TRUE; } void XSParseInfix_register(pTHX_ const char *opname, const struct XSParseInfixHooks *hooks, void *hookdata) { STRLEN oplen = strlen(opname); const char *opname_end = opname + oplen; bool opname_is_fq = strstr(opname, "::") != NULL; bool opname_is_ident = !opname_is_fq && isIDFIRST_utf8_safe(opname, opname_end); if(!opname_is_fq) { if(!XSParseInfix_check_opname(aTHX_ opname, oplen)) croak("Infix operator name is invalid; must be an identifier or entirely non-identifier characters"); } bool is_listassoc = hooks->flags & XPI_FLAG_LISTASSOC; if(hooks->flags & ~(XPI_FLAG_LISTASSOC | (1<<15))) /* (1<<15) == undocumented internal flag to indicate v1-compatible ->new_op hook function */ croak("Unrecognised XSParseInfixHooks.flags value 0x%X", hooks->flags); switch(hooks->lhs_flags & ~(XPI_OPERAND_ONLY_LOOK)) { case 0: case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: break; default: croak("Unrecognised XSParseInfixHooks.lhs_flags value 0x%X", hooks->lhs_flags); } switch(hooks->rhs_flags & ~(XPI_OPERAND_ONLY_LOOK)) { case 0: case XPI_OPERAND_TERM_LIST: case XPI_OPERAND_LIST: break; default: croak("Unrecognised XSParseInfixHooks.rhs_flags value 0x%X", hooks->rhs_flags); case (1 << 7) /* was XPI_OPERAND_CUSTOM */: croak("TODO: Currently XPI_OPERAND_CUSTOM is not supported"); } if(is_listassoc) { if(hooks->lhs_flags != hooks->rhs_flags) croak("Cannot register a list-associative infix operator with lhs_flags=%02X not equal to rhs_flags=%02X", hooks->lhs_flags, hooks->rhs_flags); } #ifdef HAVE_PL_INFIX_PLUGIN enum Perl_custom_infix_precedence prec = 0; switch(hooks->cls) { case 0: warn("Unspecified operator classification for %s; treating it as RELATION for precedence", opname); case XPI_CLS_RELATION: case XPI_CLS_EQUALITY: case XPI_CLS_MATCH_MISC: prec = INFIX_PREC_REL; break; case XPI_CLS_LOW_MISC: prec = INFIX_PREC_LOW; break; case XPI_CLS_LOGICAL_OR_LOW_MISC: prec = INFIX_PREC_LOGICAL_OR_LOW; break; case XPI_CLS_LOGICAL_AND_LOW_MISC: prec = INFIX_PREC_LOGICAL_AND_LOW; break; case XPI_CLS_ASSIGN_MISC: prec = INFIX_PREC_ASSIGN; break; case XPI_CLS_LOGICAL_OR_MISC: prec = INFIX_PREC_LOGICAL_OR; break; case XPI_CLS_LOGICAL_AND_MISC: prec = INFIX_PREC_LOGICAL_AND; break; case XPI_CLS_ADD_MISC: prec = INFIX_PREC_ADD; break; case XPI_CLS_MUL_MISC: prec = INFIX_PREC_MUL; break; case XPI_CLS_POW_MISC: prec = INFIX_PREC_POW; break; case XPI_CLS_HIGH_MISC: prec = INFIX_PREC_HIGH; break; default: croak("TODO: need to write code for hooks->cls == %d\n", hooks->cls); } #endif struct Registration *reg; Newx(reg, 1, struct Registration); #ifdef HAVE_PL_INFIX_PLUGIN reg->def.prec = prec; if(hooks->parse) reg->def.parse = &parse; else reg->def.parse = NULL; reg->def.build_op = &build_op; #endif reg->info.opname = savepv(opname); reg->info.opcode = OP_CUSTOM; reg->info.hooks = hooks; reg->info.hookdata = hookdata; reg->info.cls = hooks->cls; reg->oplen = oplen; reg->opname_is_ident = opname_is_ident; reg->opname_is_fq = opname_is_fq; 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; if(opname_is_fq) { reg->next = fqregistrations; fqregistrations = reg; } else { 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); { char *doublecolon; while((doublecolon = strstr(SvPVX(namesv)+sizeof("B::Deparse::pp::"), "::"))) /* Turn '::' into '__', a length-preserving operation */ doublecolon[0] = '_', doublecolon[1] = '_'; } 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, is_listassoc ? OA_LISTOP : 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; } } 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 wrap_infix_plugin(&my_infix_plugin, &next_infix_plugin); #endif } XS-Parse-Keyword-0.44/src/infix.h000444001750001750 62714646455562 15426 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); bool XSParseInfix_check_opname(pTHX_ const char *opname, STRLEN oplen); void XSParseInfix_register(pTHX_ const char *opname, const struct XSParseInfixHooks *hooks, void *hookdata); void XSParseInfix_boot(pTHX); XS-Parse-Keyword-0.44/src/keyword.c000444001750001750 6206614646455562 16035 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-2023 -- 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, b) MY_lex_probe_str(aTHX_ s, b) STRLEN MY_lex_probe_str(pTHX_ const char *s, bool boundarycheck) { STRLEN i; for(i = 0; s[i]; i++) { if(s[i] != PL_parser->bufptr[i]) return 0; } if(boundarycheck && isALNUM(PL_parser->bufptr[i])) return 0; return i; } #define lex_expect_str(s, b) MY_lex_expect_str(aTHX_ s, b) void MY_lex_expect_str(pTHX_ const char *s, bool boundarycheck) { STRLEN len = lex_probe_str(s, boundarycheck); if(!len) yycroakf("Expected \"%s\"", s); lex_read_to(PL_parser->bufptr + len); } #define parse_autosemi() MY_parse_autosemi(aTHX) void MY_parse_autosemi(pTHX) { 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"); } 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); bool is_special = !!(piece->type & XPK_TYPEFLAG_SPECIAL); 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, is_special); 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; lex_read_space(0); 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; lex_read_space(0); if(pieces[2].type) parse_pieces(aTHX_ argsv, argidx, pieces + 2, hookdata); lex_read_space(0); if(!probe_piece(aTHX_ argsv, argidx, pieces + 0, hookdata)) return TRUE; while(1) { parse_pieces(aTHX_ argsv, argidx, pieces + 1, hookdata); THISARG.i++; lex_read_space(0); if(!probe_piece(aTHX_ argsv, argidx, pieces + 0, hookdata)) break; } return TRUE; } case XS_PARSE_KEYWORD_PARENS: if(piece->type & XPK_TYPEFLAG_MAYBEPARENS) croak("TODO: probe_piece on type=PARENS+MAYBEPARENS"); if(lex_peek_unichar(0) != '(') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_BRACKETS: if(lex_peek_unichar(0) != '[') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_BRACES: if(lex_peek_unichar(0) != '{') return FALSE; parse_piece(aTHX_ argsv, argidx, piece, hookdata); return TRUE; case XS_PARSE_KEYWORD_CHEVRONS: 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_prefix_pieces(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *pieces, void *hookdata) { 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++; } intro_my(); /* in case any of the pieces was XPK_LEXVAR_MY */ } static void parse_piece(pTHX_ SV *argsv, size_t *argidx, const struct XSParseKeywordPieceType *piece, void *hookdata) { int argi = *argidx; #define CHECK_GROW_ARGSV \ do { \ if(argi >= (SvLEN(argsv) / sizeof(XSParseKeywordPiece))) \ SvGROW(argsv, SvLEN(argsv) * 2); \ } while(0) #define THISARG ((XSParseKeywordPiece *)SvPVX(argsv))[argi] CHECK_GROW_ARGSV; 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 optflag = is_optional ? PARSE_OPTIONAL : 0; 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, is_special); return; case XS_PARSE_KEYWORD_AUTOSEMI: parse_autosemi(); return; case XS_PARSE_KEYWORD_WARNING: { int warnbit = piece->type >> 24; if(warnbit && !ckWARN(warnbit)) return; warn("%s", 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) { parse_prefix_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); if(*argidx > argi) { argi = *argidx; CHECK_GROW_ARGSV; } } /* 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: { const struct XSParseKeywordPieceType *stages = piece->u.pieces; while(stages && stages->type == XS_PARSE_KEYWORD_ANONSUB_PREPARE) { (*stages->u.callback)(aTHX_ hookdata); stages++; } I32 floor_ix = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); I32 save_ix = block_start(0); while(stages && stages->type == XS_PARSE_KEYWORD_ANONSUB_START) { (*stages->u.callback)(aTHX_ hookdata); stages++; } OP *body = parse_block(0); CHECK_PARSEFAIL; while(stages && stages->type == XS_PARSE_KEYWORD_ANONSUB_END) { body = (*stages->u.op_wrap_callback)(aTHX_ body, hookdata); stages++; } SvREFCNT_inc(PL_compcv); body = block_end(save_ix, body); while(stages && stages->type == XS_PARSE_KEYWORD_ANONSUB_WRAP) { body = (*stages->u.op_wrap_callback)(aTHX_ body, hookdata); stages++; } THISARG.cv = newATTRSUB(floor_ix, NULL, NULL, NULL, body); (*argidx)++; return; } case XS_PARSE_KEYWORD_ARITHEXPR: case XS_PARSE_KEYWORD_TERMEXPR: { if(is_enterleave) ENTER; if(piece->u.pieces) { parse_prefix_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); if(*argidx > argi) { argi = *argidx; CHECK_GROW_ARGSV; } } /* 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); lex_read_space(0); if(lex_peek_unichar(0) == ')') THISARG.op = newOP(OP_STUB, 0); else { THISARG.op = parse_fullexpr(optflag); CHECK_PARSEFAIL; lex_read_space(0); } lex_expect_unichar(')'); } else { switch(type) { case XS_PARSE_KEYWORD_ARITHEXPR: THISARG.op = parse_arithexpr(optflag); break; case XS_PARSE_KEYWORD_TERMEXPR: THISARG.op = parse_termexpr(optflag); break; } CHECK_PARSEFAIL; } if(want && THISARG.op) THISARG.op = op_contextualize(THISARG.op, want); (*argidx)++; if(is_enterleave) LEAVE; return; } case XS_PARSE_KEYWORD_LISTEXPR: THISARG.op = parse_listexpr(optflag); CHECK_PARSEFAIL; if(want && THISARG.op) 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(); if(!varname) yycroak("Expected a lexical variable name"); 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 #if HAVE_PERL_VERSION(5, 16, 0) THISARG.padix = pad_findmy_pvn(SvPVX(varname), SvCUR(varname), 0); #else THISARG.padix = pad_findmy(SvPVX(varname), SvCUR(varname), 0); #endif (*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(optflag); (*argidx)++; return; case XS_PARSE_KEYWORD_INTRO_MY: intro_my(); 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++; lex_read_space(0); } 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++; lex_read_space(0); 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++; lex_read_space(0); if(!probe_piece(aTHX_ argsv, argidx, piece->u.pieces + 0, hookdata)) break; lex_read_space(0); } return; case XS_PARSE_KEYWORD_PARENS: { bool has_paren = (lex_peek_unichar(0) == '('); if(is_optional) { THISARG.i = 0; (*argidx)++; if(!has_paren) return; THISARG.i++; } if(has_paren) { lex_expect_unichar('('); lex_read_space(0); parse_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); lex_expect_unichar(')'); } else if(piece->type & XPK_TYPEFLAG_MAYBEPARENS) { /* We didn't find a '(' but that's OK; they're optional */ parse_pieces(aTHX_ argsv, argidx, piece->u.pieces, hookdata); } else /* We know this should fail */ lex_expect_unichar('('); return; } case XS_PARSE_KEYWORD_BRACKETS: 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_BRACES: 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_CHEVRONS: 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); bool is_blockscope = hooks->flags & XPK_FLAG_BLOCKSCOPE; int floor; if(is_blockscope) floor = block_start(TRUE); 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); parse_autosemi(); } 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. */ XSParseKeywordPiece **argptrs = NULL; if(argidx) { SV *ptrssv = newSV(argidx * sizeof(XSParseKeywordPiece *)); SAVEFREESV(ptrssv); argptrs = (XSParseKeywordPiece **)SvPVX(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); if(is_blockscope) *op = op_scope(block_end(floor, *op)); 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); break; 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); break; } 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.44/src/keyword.h000444001750001750 41014646455562 15763 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.44/t000755001750001750 014646455562 13472 5ustar00leoleo000000000000XS-Parse-Keyword-0.44/t/00use.t000444001750001750 20014646455562 14720 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; require XS::Parse::Keyword; pass( "Modules loaded" ); done_testing; XS-Parse-Keyword-0.44/t/10stages-permit.t000444001750001750 131514646455562 16741 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use lib "t"; use testcase "t::stages"; sub stages { return $_[0] } # not permitted { my $ret = stages { one => "one" }; is( $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( $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.44/t/11stages-check.t000444001750001750 70714646455562 16503 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/30pieces-literal.t000444001750001750 111414646455562 17056 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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' ); } { my $ret = piecekw bar ; is( $ret, "bar", 'result of piecekw' ); } { my $ret1 = do { pieceautosemi; }; is( $ret1, "EOS", 'result of pieceautosemi with ;' ); my $ret2 = do { pieceautosemi }; is( $ret2, "EOS", 'result of pieceautosemi at end of block' ); } done_testing; XS-Parse-Keyword-0.44/t/31pieces-block.t000444001750001750 146614646455562 16527 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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( \@ret, [ "fedcba" ], 'pieceblock_scalar forces scalar context' ); @ret = pieceblock_list { reverse "abc", "def" }; is( \@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.44/t/32pieces-anonsub.t000444001750001750 113614646455562 17075 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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' ); } { my $ret = piecestagedanonsub { return "$VAR, world" }; is( ref $ret, "CODE", 'result of piecestagedanonsub is CODE reference' ); is( $ret->(), "Hello, world", 'result of invoking' ); is( $::STAGES, "PREPARE,START,END,WRAP", 'All ANONSUB stages were invoked' ); } done_testing; XS-Parse-Keyword-0.44/t/33pieces-arithexpr.t000444001750001750 156214646455562 17442 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } my $ret; { $ret = piecearithexpr "a term"; is( $ret, "(a term)", 'a single term' ); } # arithexpr vs concat { $ret = piecearithexpr "x" . "y"; is( $ret, "(xy)", 'arithexpr consumes concat' ); } # arithexpr vs comma { $ret = join "", "x", piecearithexpr "inside", "y"; is( $ret, "x(inside)y", 'arithexpr stops before comma' ); } # arithexpr in piece1 can act as entire parens { $ret = piecearithexpr( "x" ) . "y"; is( $ret, "(x)y", 'arithexpr treats (PARENS) as entire expression' ); } # optional arithexpr { my $ret1 = piecearithexpr_opt "term"; my $ret2 = piecearithexpr_opt; is( $ret1, "(term)", 'optional arithexpr with value' ); is( $ret2, undef, 'optional arithexpr empty' ); } done_testing; XS-Parse-Keyword-0.44/t/33pieces-listexpr.t000444001750001750 127114646455562 17303 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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' ); } # optional listexpr { my $ret1 = piecelistexpr_opt 1, 2, 3; my $ret2 = piecelistexpr_opt; is( $ret1, "1,2,3", 'optional listexpr with values' ); is( $ret2, undef, 'optional listexpr empty' ); } done_testing; XS-Parse-Keyword-0.44/t/33pieces-termexpr.t000444001750001750 223114646455562 17274 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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' ); } # termexpr in piece1 can act as eat empty parens { no warnings 'uninitialized'; $ret = piecetermexpr() . "y"; is( $ret, "()y", 'termexpr accepts empty (PARENS)' ); } { $ret = pieceprefixedtermexpr_VAR $VAR . ", world!"; is( $ret, "(Hello, world!)", 'result of pieceprefixedtermexpr_VAR' ); } # optional termexpr { my $ret1 = piecetermexpr_opt "term"; my $ret2 = piecetermexpr_opt; is( $ret1, "(term)", 'optional termexpr with value' ); is( $ret2, undef, 'optional termexpr empty' ); } done_testing; XS-Parse-Keyword-0.44/t/34pieces-ident.t000444001750001750 152614646455562 16540 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/35pieces-lexvar.t000444001750001750 157114646455562 16737 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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; my $ret2 = piecelexvar $scalar; is( $ret2, $ret, 'result of piecelexvar matches previous' ); } # intro_my() { my $one = "outside"; my $ret = piecelexvarmyintro $one in $one + 2; is( $ret, 3, 'result of piecelexvarmyintro' ); is( $one, "outside", 'lexvar inside does not leak out' ); } done_testing; XS-Parse-Keyword-0.44/t/36pieces-attrs.t000444001750001750 107014646455562 16566 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/37pieces-vstring.t000444001750001750 72714646455562 17116 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/38pieces-infix.t000444001750001750 121714646455562 16553 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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' ); ok( !defined eval "pieceinfix gtx", 'pieceinfix does not accept gtx' ); $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.44/t/39pieces-warning.t000444001750001750 123114646455562 17100 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use lib "t"; use testcase "t::pieces"; BEGIN { $^H{"t::pieces/permit"} = 1; } my @warnings; BEGIN { $SIG{__WARN__} = sub { push @warnings, $_[0] }; } { BEGIN { undef @warnings; } piecewarning; BEGIN { is( \@warnings, [ "A warning here\n" ], 'piecewarning emits warning' ) }; } { BEGIN { undef @warnings; } piecewarndep; BEGIN { is( \@warnings, [ "A deprecated warning here\n" ], 'piecewarndep emits warning' ) }; BEGIN { undef @warnings; } no warnings 'deprecated'; piecewarndep; BEGIN { is( \@warnings, [], 'piecewarndep warning is conditional' ) }; } done_testing; XS-Parse-Keyword-0.44/t/40build.t000444001750001750 42214646455562 15235 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/41structures.t000444001750001750 172414646455562 16410 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/42containers.t000444001750001750 121114646455562 16322 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use lib "t"; use testcase "t::structures"; BEGIN { $^H{"t::structures/permit"} = 1; } # parens { is( parens ( "abc" ), "abc", 'parenthesis container' ); } # args - parens are optional { is( args ( "123" ), "123", 'arguments container with parens' ); is( args "123", "123", 'arguments container without parens' ); } # brackets { is( brackets [ "def" ], "def", 'bracket container' ); } # braces { is( braces { "ghi" }, "ghi", 'brace container' ); } # chevrons { # takes a bareword identifier is( chevrons < jkl >, "jkl", 'chevron container' ); } done_testing; XS-Parse-Keyword-0.44/t/43probing.t000444001750001750 331314646455562 15623 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/50flags-autosemi.t000444001750001750 56414646455562 17066 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/60line.t000444001750001750 35214646455562 15071 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/70infix.t000444001750001750 1311514646455562 15321 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; use Test2::V0; use B::Deparse; my $deparser = B::Deparse->new( "-p" ); use lib "t"; use testcase "t::infix"; BEGIN { plan skip_all => "No PL_infix_plugin" unless XS::Parse::Infix::HAVE_PL_INFIX_PLUGIN; } use feature 'current_sub'; 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( $aref, [qw( a | b | c )], 'intersperse infix operator' ); my @list = qw( x y z ); $aref = ["|" intersperse @list]; is( $aref, [qw( x | y | z )], 'intersperse infix operator on PADAV' ); is( [ (2, 4, 6) addpairs (1, 1, 1) ], [ 3, 5, 7 ], 'addpairs infix operator' ); } # fully-qualified + lexical alias { BEGIN { t::infix->XS::Parse::Infix::apply_infix( 1, [ "fqadd" ], qw( fqadd ) ); } my $result = 5 fqadd 10; is( $result, 15, 'fqadd infix operator' ); } { my @importargs; BEGIN { @importargs = ( 123, fqadd => { -as => "localname" }, 456 ); t::infix->XS::Parse::Infix::apply_infix( 1, \@importargs, qw( fqadd ) ); } my $result = 6 localname 12; is( $result, 18, 'infix operator renamed' ); is( \@importargs, [ 123, 456 ], 'apply_infix correctly mutated import args' ); } sub _getoptree { my ( $sub ) = @_; # Ugh - this would be so much neater if we could pass coderefs into # B::walkoptree directly # Additionally there's no pre-mid-postfix walk options :( my $dump_optree = sub { my $sub = __SUB__; my ( $op ) = @_; my $opname = $op->name; # Avoid test-dependence on the actual ppaddr by mangling out the name $opname =~ s/0x[[:xdigit:]]+/0xXXX/; return $op->first->$sub if $opname eq "null"; my @kids; if( $op->flags & B::OPf_KIDS ) { my $kid = $op->first; while( $kid ) { push @kids, $kid->$sub; $kid = $kid->sibling; undef $kid if ref($kid) eq "B::NULL"; } } my $ret = $opname; $ret .= "[" . join( ", ", @kids ) . "]" if @kids; return $ret; }; # Reach inside to the first statement return B::svref_2object( $sub )->ROOT->first->first->sibling ->$dump_optree; } sub is_optree { my ( $sub, $exp, $name ) = @_; is( _getoptree( $sub ), $exp, $name ); } { is_optree sub { $_[0] add $_[1] }, "infix_add_0xXXX[aelemfast, aelemfast]", 'optree of call to infix operator'; # Check precedence of operator parsing by observing the following precedence # ordering: # <--High Low--> # ** * + && is_optree sub { $_[0] * $_[1] add $_[2] * $_[3] }, "infix_add_0xXXX[multiply[aelemfast, aelemfast], multiply[aelemfast, aelemfast]]", 'optree binds add lower than *'; is_optree sub { $_[0] + $_[1] add $_[2] + $_[3] }, "add[infix_add_0xXXX[add[aelemfast, aelemfast], aelemfast], aelemfast]", 'optree binds add equal to +'; is_optree sub { $_[0] && $_[1] add $_[2] && $_[3] }, "and[and[aelemfast, infix_add_0xXXX[aelemfast, aelemfast]], aelemfast]", 'optree binds add higher than &&'; is_optree sub { $_[0] ** $_[1] mul $_[2] ** $_[3] }, "infix_mul_0xXXX[pow[aelemfast, aelemfast], pow[aelemfast, aelemfast]]", 'optree binds mul lower than **'; is_optree sub { $_[0] * $_[1] mul $_[2] * $_[3] }, "multiply[infix_mul_0xXXX[multiply[aelemfast, aelemfast], aelemfast], aelemfast]", 'optree binds mul equal to *'; is_optree sub { $_[0] + $_[1] mul $_[2] + $_[3] }, "add[add[aelemfast, infix_mul_0xXXX[aelemfast, aelemfast]], aelemfast]", 'optree binds mul higher than +'; is_optree sub { $_[0] * ($_[1] add $_[2]) * $_[3] }, "multiply[multiply[aelemfast, infix_add_0xXXX[aelemfast, aelemfast]], aelemfast]", 'optree of call to infix operator at forced precedence'; } 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 add operator'; is_deparsed sub { $_[0] * $_[1] add $_[2] * $_[3] }, '($_[0] * $_[1]) add ($_[2] * $_[3]);', 'deparsed call to infix add operator at default precedence'; 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'; } # list-associative operator { is( "a" cat "b" cat "c", "^abc^", 'cat operator runs correctly' ); is_optree sub { "a" cat "b" cat "c" }, "infix_cat_0xXXX[const, const, const]", 'optree of list-associative cat operator'; is_optree sub { ( "a" cat "b" ) cat "c" }, "infix_cat_0xXXX[infix_cat_0xXXX[const, const], const]", 'parens on LHS defeat list-associativity'; is_optree sub { "a" cat ( "b" cat "c" ) }, "infix_cat_0xXXX[const, infix_cat_0xXXX[const, const]]", 'parens on RHS defeat list-associativity'; is_deparsed sub { "a" cat "b" cat "c" }, q['a' cat 'b' cat 'c';], 'deparsed list-associative cat operator'; } done_testing; XS-Parse-Keyword-0.44/t/71infix-wrapper.t000444001750001750 1744014646455562 17005 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; use Test2::V0; 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( $aref, [qw( a Z b )], 'intersperse wrapper func' ); is( [ 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( [ $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( [ $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( [ $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( [ $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( [ $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( [ $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( [ $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'; } # list-associative { # wrapper by direct call is( t::infix::catfunc( "a", "b", "c" ), "^abc^", 'List-associative wrapper function by direct call' ); # wrapper by direct call non-convertable my @args = qw( a b c ); is( t::infix::catfunc( @args ), "^abc^", 'List-associative wrapper function by non-convertable direct call' ); my $wrapper = \&t::infix::catfunc; is( $wrapper->( "d", "e", "f" ), "^def^", 'List-associative wrapper function by CODE reference' ); } # call-checker for list-associative ops { my $code; my %opcounts; # scalars %opcounts = count_ops $code = sub { t::infix::catfunc "X", "Y" }; ok( (scalar grep { m/^infix_cat_0x/ } keys %opcounts), 'callchecker generated an OP_CUSTOM call for listassoc scalars' ); ok( !$opcounts{entersub}, 'callchecker removed an OP_ENTERSUB call for listassoc scalars' ); is( $code->(), "^XY^", 'result of callcheckered code for listassoc scalars' ); # lists %opcounts = count_ops $code = sub { t::infix::LLfunc ["X"], ["Y"] }; ok( (scalar grep { m/^infix_LL_0x/ } keys %opcounts), 'callchecker generated an OP_CUSTOM call for listassoc lists' ); ok( !$opcounts{entersub}, 'callchecker removed an OP_ENTERSUB call for listassoc lists' ); is( $code->(), "([X][Y])", 'result of callcheckered code for listassoc lists' ); # RT153244 $code = sub { t::infix::catfunc() }; pass( 'Compiling a zero argument listassoc scalars wrapper did not crash' ); $code = sub { t::infix::LLfunc() }; pass( 'Compiling a zero argument listassoc scalars wrapper did not crash' ); } done_testing; XS-Parse-Keyword-0.44/t/99pod.t000444001750001750 25514646455562 14742 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.44/t/build.xs000444001750001750 163714646455562 15311 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.44/t/flags.xs000444001750001750 146514646455562 15305 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.44/t/infix.xs000444001750001750 1151214646455562 15340 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-2024 -- 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 = { .cls = XPI_CLS_ADD_MISC, .permit_hintkey = hintkey, .wrapper_func_name = "t::infix::addfunc", .ppaddr = &pp_add, }; OP *pp_mul(pTHX) { croak("TODO"); /* We never actually call code with this so it doesn't matter */ } static const struct XSParseInfixHooks hooks_mul = { .cls = XPI_CLS_MUL_MISC, .permit_hintkey = hintkey, .ppaddr = &pp_mul, }; OP *pp_xor(pTHX) { dSP; SV *right = POPs; SV *left = POPs; mPUSHi(SvIV(left) ^ SvIV(right)); RETURN; } static const struct XSParseInfixHooks hooks_xor = { .cls = XPI_CLS_ADD_MISC, .permit_hintkey = hintkey, .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 = { .cls = XPI_CLS_ADD_MISC, .rhs_flags = XPI_OPERAND_LIST, .permit_hintkey = hintkey, .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 = { .cls = XPI_CLS_ADD_MISC, .lhs_flags = XPI_OPERAND_LIST, .rhs_flags = XPI_OPERAND_LIST|XPI_OPERAND_ONLY_LOOK, /* only on RHS so we can test the logic */ .permit_hintkey = hintkey, .wrapper_func_name = "t::infix::addpairsfunc", .ppaddr = &pp_addpairs, }; OP *pp_cat(pTHX) { dSP; int n = (PL_op->op_flags & OPf_STACKED) ? POPu : PL_op->op_private; SV *ret = newSVpvs("^"); SV **args = SP - n + 1; for(int i = 0; i < n; i++) sv_catsv(ret, args[i]); sv_catpvs(ret, "^"); SP -= n; mPUSHs(ret); RETURN; } static const struct XSParseInfixHooks hooks_cat = { .cls = XPI_CLS_ADD_MISC, .flags = XPI_FLAG_LISTASSOC, .permit_hintkey = hintkey, .wrapper_func_name = "t::infix::catfunc", .ppaddr = &pp_cat, }; OP *pp_LL(pTHX) { dSP; int n = (PL_op->op_flags & OPf_STACKED) ? POPu : PL_op->op_private; if(n > 2) croak("TODO: unit test cannot cope with n > 2"); U32 counts[2]; SV **args[2]; for(int listi = n-1; listi >= 0; listi--) { SV **mark = PL_stack_base + POPMARK; counts[listi] = SP - mark; args[listi] = mark + 1; SP = mark; } SV *ret = newSVpvs("("); for(int listi = 0; listi < n; listi++) { sv_catpvs(ret, "["); for(int argi = 0; argi < counts[listi]; argi++) sv_catsv(ret, args[listi][argi]); sv_catpvs(ret, "]"); } sv_catpvs(ret, ")"); mPUSHs(ret); RETURN; } static const struct XSParseInfixHooks hooks_LL = { .cls = XPI_CLS_ADD_MISC, .flags = XPI_FLAG_LISTASSOC, .lhs_flags = XPI_OPERAND_LIST|XPI_OPERAND_ONLY_LOOK, .rhs_flags = XPI_OPERAND_LIST|XPI_OPERAND_ONLY_LOOK, .permit_hintkey = hintkey, .wrapper_func_name = "t::infix::LLfunc", .ppaddr = &pp_LL, }; OP *pp_fqadd(pTHX) /* Like pp_add but we need a second address so as not to upset the deparse tests */ { return pp_add(aTHX); } static const struct XSParseInfixHooks hooks_fqadd = { .cls = XPI_CLS_ADD_MISC, .ppaddr = &pp_fqadd, }; MODULE = t::infix PACKAGE = t::infix BOOT: boot_xs_parse_infix(0); register_xs_parse_infix("add", &hooks_add, NULL); register_xs_parse_infix("mul", &hooks_mul, NULL); register_xs_parse_infix("⊕", &hooks_xor, NULL); register_xs_parse_infix("intersperse", &hooks_intersperse, NULL); register_xs_parse_infix("addpairs", &hooks_addpairs, NULL); register_xs_parse_infix("cat", &hooks_cat, NULL); register_xs_parse_infix("LL", &hooks_LL, NULL); register_xs_parse_infix("t::infix::fqadd", &hooks_fqadd, NULL); XS-Parse-Keyword-0.44/t/line.xs000444001750001750 144514646455562 15136 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.44/t/pieces.xs000444001750001750 3136514646455562 15503 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-2022 -- 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) { OP *expr = arg0->op; if(!expr) { *out = newOP(OP_STUB, 0); return KEYWORD_PLUGIN_EXPR; } /* 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(expr)), 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 = newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV *)arg0->cv)); return KEYWORD_PLUGIN_EXPR; } static int build_list(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { OP *list = arg0->op; if(!list) { *out = newOP(OP_STUB, 0); return KEYWORD_PLUGIN_EXPR; } /* 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, SvREFCNT_inc((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 int build_lexvar_intro(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { PADOFFSET padix = args[0]->padix; OP *expr = args[1]->op; OP *varop = newOP(OP_PADSV, OPf_MOD|OPf_REF | (OPpLVAL_INTRO << 8)); varop->op_targ = padix; OP *assignop = newASSIGNOP(OPf_WANT_VOID, varop, 0, newSVOP(OP_CONST, 0, newSViv(1))); *out = newLISTOP(OP_LINESEQ, 0, assignop, expr); 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 void callback_catpv_stages(pTHX_ const char *pv) { SV *sv = get_sv("main::STAGES", GV_ADD); if(!SvPOK(sv)) sv_setpvs(sv, ""); if(SvCUR(sv)) sv_catpvs(sv, ","); sv_catpv(sv, pv); } static void callback_PREPARE(pTHX_ void *hookdata) { callback_catpv_stages(aTHX_ "PREPARE"); } static void callback_START(pTHX_ void *hookdata) { callback_catpv_stages(aTHX_ "START"); } static OP *callback_END(pTHX_ OP *o, void *hookdata) { callback_catpv_stages(aTHX_ "END"); return o; } static OP *callback_WRAP(pTHX_ OP *o, void *hookdata) { callback_catpv_stages(aTHX_ "WRAP"); return o; } 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_stagedanonsub = { .permit_hintkey = hintkey, .piece1 = XPK_STAGED_ANONSUB( XPK_ANONSUB_PREPARE(&callback_PREPARE), XPK_ANONSUB_START(&callback_START), XPK_ANONSUB_START(&setup_block_VAR), XPK_ANONSUB_END(&callback_END), XPK_ANONSUB_WRAP(&callback_WRAP) ), .build1 = &build_anonsub, }; static const struct XSParseKeywordHooks hooks_arithexpr = { .permit_hintkey = hintkey, .piece1 = XPK_ARITHEXPR, .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_arithexpr_opt = { .permit_hintkey = hintkey, .piece1 = XPK_ARITHEXPR_OPT, .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_termexpr = { .permit_hintkey = hintkey, .piece1 = XPK_TERMEXPR, .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_termexpr_opt = { .permit_hintkey = hintkey, .piece1 = XPK_TERMEXPR_OPT, .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_prefixedtermexpr_VAR = { .permit_hintkey = hintkey, .piece1 = XPK_PREFIXED_TERMEXPR_ENTERLEAVE( XPK_SETUP(&setup_block_VAR) ), .build1 = &build_expr, }; static const struct XSParseKeywordHooks hooks_listexpr = { .permit_hintkey = hintkey, .piece1 = XPK_LISTEXPR, .build1 = &build_list, }; static const struct XSParseKeywordHooks hooks_listexpr_opt = { .permit_hintkey = hintkey, .piece1 = XPK_LISTEXPR_OPT, .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 = { .permit_hintkey = hintkey, .piece1 = XPK_LEXVAR(XPK_LEXVAR_ANY), .build1 = &build_constpadix, }; 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_lexvar_my_intro = { .flags = XPK_FLAG_BLOCKSCOPE, .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_LEXVAR_MY(XPK_LEXVAR_ANY), XPK_KEYWORD("in"), XPK_INTRO_MY, XPK_TERMEXPR, 0 }, .build = &build_lexvar_intro, }; 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, }; static const struct XSParseKeywordHooks hooks_kw = { .permit_hintkey = hintkey, .piece1 = XPK_KEYWORD("bar"), .build1 = &build_literal, }; static const struct XSParseKeywordHooks hooks_autosemi = { .permit_hintkey = hintkey, .piece1 = XPK_AUTOSEMI, .build1 = &build_literal, }; static const struct XSParseKeywordHooks hooks_warning = { .permit_hintkey = hintkey, .piece1 = XPK_WARNING("A warning here\n"), .build1 = &build_literal, }; static const struct XSParseKeywordHooks hooks_warning_deprecated = { .permit_hintkey = hintkey, .piece1 = XPK_WARNING_DEPRECATED("A deprecated warning here\n"), .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("piecestagedanonsub", &hooks_stagedanonsub, "$VAR"); register_xs_parse_keyword("piecearithexpr", &hooks_arithexpr, NULL); register_xs_parse_keyword("piecearithexpr_opt", &hooks_arithexpr_opt, NULL); register_xs_parse_keyword("piecetermexpr", &hooks_termexpr, NULL); register_xs_parse_keyword("piecetermexpr_opt", &hooks_termexpr_opt, NULL); register_xs_parse_keyword("piecelistexpr", &hooks_listexpr, NULL); register_xs_parse_keyword("piecelistexpr_opt", &hooks_listexpr_opt, NULL); register_xs_parse_keyword("pieceprefixedtermexpr_VAR", &hooks_prefixedtermexpr_VAR, "$VAR"); 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("piecelexvar", &hooks_lexvar, NULL); register_xs_parse_keyword("piecelexvarmy", &hooks_lexvar_my, NULL); register_xs_parse_keyword("piecelexvarmyintro", &hooks_lexvar_my_intro, 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")); register_xs_parse_keyword("piecekw", &hooks_kw, newSVpvs("bar")); register_xs_parse_keyword("pieceautosemi", &hooks_autosemi, newSVpvs("EOS")); register_xs_parse_keyword("piecewarning", &hooks_warning, &PL_sv_undef); register_xs_parse_keyword("piecewarndep", &hooks_warning_deprecated, &PL_sv_undef); XS-Parse-Keyword-0.44/t/probing.xs000444001750001750 1135714646455562 15672 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_PARENS( XPK_TERMEXPR ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_brackets = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_BRACKETS( XPK_TERMEXPR ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_braces = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_BRACES( XPK_TERMEXPR ) ), {0} }, .build = &build_constbool, }; static const struct XSParseKeywordHooks hooks_chevrons = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_OPTIONAL( XPK_CHEVRONS( 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.44/t/stages.xs000444001750001750 225414646455562 15474 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.44/t/structures.xs000444001750001750 1063514646455562 16453 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_parens = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_PARENS( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_args = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_ARGS( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_brackets = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_BRACKETS( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_braces = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ XPK_BRACES( XPK_TERMEXPR ), {0} }, .build = &build_op, }; static const struct XSParseKeywordHooks hooks_chevrons = { .permit_hintkey = hintkey, .pieces = (const struct XSParseKeywordPieceType []){ /* A TERMEXPR inside chevrons is ambiguous, because of the < 2 > 1 > problem */ XPK_CHEVRONS( 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("parens", &hooks_parens, NULL); register_xs_parse_keyword("args", &hooks_args, NULL); register_xs_parse_keyword("brackets", &hooks_brackets, NULL); register_xs_parse_keyword("braces", &hooks_braces, NULL); register_xs_parse_keyword("chevrons", &hooks_chevrons, NULL); XS-Parse-Keyword-0.44/t/testcase.pm000444001750001750 42314646455562 15757 0ustar00leoleo000000000000package testcase; use v5.14; 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 ); } sub unimport { die "testcase cannot be unimported"; } 0x55AA;