commit 38c0eac41fdbb4f1dc5ee2dbe6e018810f825553 Author: zhangyichun Date: Mon Oct 10 14:50:11 2022 +0800 Import Upstream version 0.27 diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..ff12268 --- /dev/null +++ b/Build.PL @@ -0,0 +1,35 @@ +use v5; +use strict; +use warnings; + +use Module::Build; +use XS::Parse::Keyword::Builder; + +my $build = Module::Build->new( + module_name => "Syntax::Keyword::Try", + test_requires => { + 'Test::More' => '0.88', # done_testing + }, + configure_requires => { + 'Module::Build' => '0.4004', # test_requires + 'XS::Parse::Keyword::Builder' => '0.06', + }, + requires => { + 'perl' => '5.014', # pluggable keywords, XOP + 'XS::Parse::Keyword' => '0.06', + }, + license => 'perl', + create_license => 1, + create_readme => 1, + meta_merge => { + resources => { + x_IRC => "irc://irc.perl.org/#io-async", + }, + }, + + extra_compiler_flags => [qw( -Ihax )], +); + +XS::Parse::Keyword::Builder->extend_module_build( $build ); + +$build->create_build_script; diff --git a/Changes b/Changes new file mode 100644 index 0000000..e17e9a8 --- /dev/null +++ b/Changes @@ -0,0 +1,190 @@ +Revision history for Syntax-Keyword-Try + +0.27 2022-02-22 + [CHANGES] + * Updates to support Feature::Compat::Try 0.05 with new `finally {}` + blocks + +0.26 2021-10-12 + [CHANGES] + * Many internal updates to hax/ support files + + [BUGFIXES] + * Fix try { return } to work correctly in all contexts without + upsetting -DDEBUGGING perls + +0.25 2021-06-01 + [CHANGES] + * Rewrite parsing logic to use XS::Parse::Keyword 0.06 + * Removed the new-deprecated `try do { ... }` experimental syntax + * Updated docs now that 5.34 is officially released, including + `use feature 'try'`. + +0.24 2021-05-10 + [CHANGES] + * Deprecate the `try do { ... }` (experimental) syntax now that + try-in-do works reliably. It will be removed soon because it gets + in the way of converting the parser logic to XS::Parse::Keyword + * Add documentation about the core `use feature 'try'` and + Feature::Compat::Try module + * Added an initial attempt at B::Deparse logic + +0.23 2021-03-27 + [CHANGES] + * Unit tests and documentation of the handling of the final-value + semantics of `do { try ... }` + * Also mention core's `feature 'try'` in documentation + * Gives notice that the experimental 'try_value' feature is now + discouraged and will eventually be removed + +0.22 2021-03-26 + [CHANGES] + * Preserve wantarray context within the try {} block (RT133616) + * List-context `try do {}` now works fine as well + * Apply unit-testing for RT134790 + +0.21 2021-01-22 + [CHANGES] + * Add some import configuration options required to make + Feature::Compat::Try work. Currently unit-tested but undocumented. + +0.20 2020-11-24 + [BUGFIXES] + * Fix for perl 5.14 by #include'ing hax/ files in the right order + +0.19 2020-11-24 + [CHANGES] + * Avoid the core Off() and Bit() macros as they were removed after + perl 5.33.3 + * Support :experimental(try_value) to activate and silence the + warning + * Add documentation about the scalar context propagation issue of + RT124229 + +0.18 2020-08-01 + [CHANGES] + * De-experiment the `catch ($var)` syntax + +0.17 2020-07-31 + [CHANGES] + * Ensure that `catch ($var)` does not retain exception value after + block exit + * Docs fixes for clarity on experimental status of `catch ($var)` + + [BUGFIXES] + * Ensure sv_isa_sv is a macro for aTHX on threaded perls + +0.16 2020-07-23 + [CHANGES] + * Provide the `:experimental` import tag as a nicer way to silence + experimental warnings + + [BUGFIXES] + * Don't name a variable `class` because it upsets some C compilers + (RT133043) + +0.15 2020-07-21 + [CHANGES] + * Experimental typed `catch (VAR ...)` conditions + +0.14 2020-07-07 + [CHANGES] + * Optional experimental syntax of `catch (VAR)` instead of previous + experimental `catch my VAR` + * Mark `catch my VAR` as deprecated + * Added explicit use VERSION declarations to every perl file + +0.13 2020-06-29 + [BUGFIXES] + * Pack correct MANIFEST to include hax/ files + +0.12 2020-06-29 + [CHANGES] + * Optional and experimental allocation of a new lexical under + `catch my $VAR` syntax (RT130702). However, this syntax may not + survive long, as part of the ongoing typed catch design work. + + [BUGFIXES] + * Work around perl versions prior to 5.22 built with -DDEBUGGING + getting upset about new*OP() being invoked with OP_CUSTOM + (RT128562) + +0.11 2019-09-07 + [CHANGES] + * Use wrap_keyword_plugin() instead of direct access to + PL_keyword_plugin + [BUGFIXES] + * Build OP_ENTER/OP_LEAVE structure the correct way so perl 5.31.3 + doesn't crash + * Fix OP_NEXT/OP_LAST/OP_REDO mangling for perl 5.31.3 to avoid + CPU spin (RT129975) + +0.10 2019-06-13 + [CHANGES] + * Added experimental value-semantic expression form (RT121267) + * Document that the module works nicely with Future::AsyncAwait + * Ignore import symbols `catch` and `finally` + + [BUGFIXES] + * Fixed spelling mistakes in documentation (patch from debian) + (RT124140) + +0.09 2017-11-08 14:33:19 + [BUGFIXES] + * Make module loading thread-safe on perls 5.16 and above. (RT123547) + Safety on perl 5.14 is still an unsolved problem. + +0.08 2017-09-14 17:26:20 + [BUGFIXES] + * Handle the OpSIBLING of an OP_{NEXT,LAST,REDO} correctly (RT123040) + +0.07 2017-08-13 23:11:39 + [CHANGES] + * Capture 80await+try.t unit test from Future-AsyncAwait + * Improved implementation of OP_PUSHFINALLY to help make try/finally + inside async/await subs work + + [BUGFIXES] + * Make 'eval { try { return ... } }' work correctly + * Make 'return LIST' inside try{} blocks work correctly (RT122795) + - with thanks to Zefram for code inspiration + +0.06 2017/06/06 14:59:30 + [CHANGES] + * Clarify documentation about the behaviour of try {} blocks without + catch {}; include comparison with other modules + + [BUGFIXES] + * Fix typo in #ifdef test (RT119709) + * Restore C89 compatibility again (RT119665) + +0.05 2017/06/05 14:04:06 + [CHANGES] + * Add a SEE ALSO link pointing at the value-semantics RT ticket + + [BUGFIXES] + * Fix cLISTOP->op_last field to keep DEBUGGING builds happy + (RT119095) + +0.04 2016/11/25 15:06:18 + [CHANGES] + * Removed stale documentation about now-fixed warnings from + next/last/redo + + [BUGFIXES] + * Fix C code for C89 compatibility (RT118950) + * Localise $@ around try/catch (RT118415) + +0.03 2016/11/24 10:27:45 + [CHANGES] + * Default import of 'try' keyword + * Suppress 'exiting' warning around next/last/redo inside a try block + * Don't bother outputting a Makefile.PL + +0.02 2016/09/06 21:29:25 + [BUGFIXES] + * Use OpSIBLING() macro for compatibility for perl 5.25.x + * Documentation fixes + +0.01 2016/09/05 22:19:33 + First version, released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..7f7fca7 --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 2022 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) 2022 by Paul Evans . + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2022 by Paul Evans . + +This is free software, licensed under: + + The Artistic License 1.0 + +The Artistic License + +Preamble + +The intent of this document is to state the conditions under which a Package +may be copied, such that the Copyright Holder maintains some semblance of +artistic control over the development of the package, while giving the users of +the package the right to use and distribute the Package in a more-or-less +customary fashion, plus the right to make reasonable modifications. + +Definitions: + + - "Package" refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + - "Standard Version" refers to such a Package if it has not been modified, + or has been modified in accordance with the wishes of the Copyright + Holder. + - "Copyright Holder" is whoever is named in the copyright or copyrights for + the package. + - "You" is you, if you're thinking about copying or distributing this Package. + - "Reasonable copying fee" is whatever you can justify on the basis of media + cost, duplication charges, time of people involved, and so on. (You will + not be required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + - "Freely Available" means that no fee is charged for the item itself, though + there may be fees involved in handling the item. It also means that + recipients of the item may redistribute it under the same conditions they + received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications derived +from the Public Domain or from the Copyright Holder. A Package modified in such +a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided that +you insert a prominent notice in each changed file stating how and when you +changed that file, and provided that you do at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or an + equivalent medium, or placing the modifications on a major archive site + such as ftp.uu.net, or by allowing the Copyright Holder to include your + modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict with + standard executables, which must also be provided, and provide a separate + manual page for each non-standard executable that clearly documents how it + differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or executable +form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where to + get the Standard Version. + + b) accompany the distribution with the machine-readable source of the Package + with your modifications. + + c) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting the differences in manual pages (or + equivalent), together with instructions on where to get the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this Package. You +may not charge a fee for this Package itself. However, you may distribute this +Package in aggregate with other (possibly commercial) programs as part of a +larger (possibly commercial) software distribution provided that you do not +advertise this Package as a product of your own. + +6. The scripts and library files supplied as input to or produced as output +from the programs of this Package do not automatically fall under the copyright +of this Package, but belong to whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +The End + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..8748c52 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,34 @@ +Build.PL +Changes +hax/newOP_CUSTOM.c.inc +hax/op_sibling_splice.c.inc +hax/optree-additions.c.inc +hax/perl-additions.c.inc +hax/perl-backcompat.c.inc +lib/Syntax/Keyword/Try.pm +lib/Syntax/Keyword/Try.xs +lib/Syntax/Keyword/Try/Deparse.pm +MANIFEST This list of files +t/00use.t +t/01trycatch.t +t/02tryfinally.t +t/03trycatchfinally.t +t/04catch-types.t +t/10snail.t +t/11loop.t +t/12return.t +t/13die-in-finally.t +t/14try-localises.t +t/15context.t +t/16final-expr.t +t/30compat.t +t/70deparse.t +t/80await+SKT.t +t/80defer+SKT.t +t/90rt123547.t +t/90rt125971.t +t/99pod.t +README +LICENSE +META.yml +META.json diff --git a/META.json b/META.json new file mode 100644 index 0000000..d0d154e --- /dev/null +++ b/META.json @@ -0,0 +1,59 @@ +{ + "abstract" : "a C syntax for perl", + "author" : [ + "Paul Evans " + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.4231", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Syntax-Keyword-Try", + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::CBuilder" : "0" + } + }, + "configure" : { + "requires" : { + "Module::Build" : "0.4004", + "XS::Parse::Keyword::Builder" : "0.06" + } + }, + "runtime" : { + "requires" : { + "XS::Parse::Keyword" : "0.06", + "perl" : "5.014" + } + }, + "test" : { + "requires" : { + "Test::More" : "0.88" + } + } + }, + "provides" : { + "Syntax::Keyword::Try" : { + "file" : "lib/Syntax/Keyword/Try.pm", + "version" : "0.27" + }, + "Syntax::Keyword::Try::Deparse" : { + "file" : "lib/Syntax/Keyword/Try/Deparse.pm", + "version" : "0.27" + } + }, + "release_status" : "stable", + "resources" : { + "license" : [ + "http://dev.perl.org/licenses/" + ], + "x_IRC" : "irc://irc.perl.org/#io-async" + }, + "version" : "0.27", + "x_serialization_backend" : "JSON::PP version 4.06" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..59ef11c --- /dev/null +++ b/META.yml @@ -0,0 +1,32 @@ +--- +abstract: 'a C syntax for perl' +author: + - 'Paul Evans ' +build_requires: + ExtUtils::CBuilder: '0' + Test::More: '0.88' +configure_requires: + Module::Build: '0.4004' + XS::Parse::Keyword::Builder: '0.06' +dynamic_config: 1 +generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Syntax-Keyword-Try +provides: + Syntax::Keyword::Try: + file: lib/Syntax/Keyword/Try.pm + version: '0.27' + Syntax::Keyword::Try::Deparse: + file: lib/Syntax/Keyword/Try/Deparse.pm + version: '0.27' +requires: + XS::Parse::Keyword: '0.06' + perl: '5.014' +resources: + IRC: irc://irc.perl.org/#io-async + license: http://dev.perl.org/licenses/ +version: '0.27' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/README b/README new file mode 100644 index 0000000..f0c1275 --- /dev/null +++ b/README @@ -0,0 +1,398 @@ +NAME + + Syntax::Keyword::Try - a try/catch/finally syntax for perl + +SYNOPSIS + + use Syntax::Keyword::Try; + + sub foo { + try { + attempt_a_thing(); + return "success"; + } + catch ($e) { + warn "It failed - $e"; + return "failure"; + } + } + +DESCRIPTION + + This module provides a syntax plugin that implements exception-handling + semantics in a form familiar to users of other languages, being built + on a block labeled with the try keyword, followed by at least one of a + catch or finally block. + + As well as providing a handy syntax for this useful behaviour, this + module also serves to contain a number of code examples for how to + implement parser plugins and manipulate optrees to provide new syntax + and behaviours for perl code. + + Syntax similar to this module has now been added to core perl, starting + at version 5.34.0. If you are writing new code, it is suggested that + you instead use the Feature::Compat::Try module instead, as that will + enable the core feature on those supported perl versions, falling back + to Syntax::Keyword::Try on older perls. + +Experimental Features + + Some of the features of this module are currently marked as + experimental. They will provoke warnings in the experimental category, + unless silenced. + + You can silence this with no warnings 'experimental' but then that will + silence every experimental warning, which may hide others + unintentionally. For a more fine-grained approach you can instead use + the import line for this module to only silence this module's warnings + selectively: + + use Syntax::Keyword::Try qw( try :experimental(typed) ); + + use Syntax::Keyword::Try qw( try :experimental ); # all of the above + + Don't forget to import the main try symbol itself, to activate the + syntax. + +KEYWORDS + + try + + try { + STATEMENTS... + } + ... + + A try statement provides the main body of code that will be invoked, + and must be followed by either a catch statement, a finally statement, + or both. + + Execution of the try statement itself begins from the block given to + the statement and continues until either it throws an exception, or + completes successfully by reaching the end of the block. What will + happen next depends on the presence of a catch or finally statement + immediately following it. + + The body of a try {} block may contain a return expression. If + executed, such an expression will cause the entire containing function + to return with the value provided. This is different from a plain eval + {} block, in which circumstance only the eval itself would return, not + the entire function. + + The body of a try {} block may contain loop control expressions (redo, + next, last) which will have their usual effect on any loops that the + try {} block is contained by. + + The parsing rules for the set of statements (the try block and its + associated catch and finally) are such that they are parsed as a self- + contained statement. Because of this, there is no need to end with a + terminating semicolon. + + Even though it parses as a statement and not an expression, a try block + can still yield a value if it appears as the final statement in its + containing sub or do block. For example: + + my $result = do { + try { attempt_func() } + catch ($e) { "Fallback Value" } + }; + + Note (especially to users of Try::Tiny and similar) that the try {} + block itself does not necessarily stop exceptions thrown inside it from + propagating outside. It is the presence of a later catch {} block which + causes this to happen. A try with only a finally and no catch will + still propagate exceptions up to callers as normal. + + catch + + ... + catch ($var) { + STATEMENTS... + } + + or + + ... + catch { + STATEMENTS... + } + + A catch statement provides a block of code to the preceding try + statement that will be invoked in the case that the main block of code + throws an exception. Optionally a new lexical variable can be provided + to store the exception in. If not provided, the catch block can inspect + the raised exception by looking in $@ instead. + + Presence of this catch statement causes any exception thrown by the + preceding try block to be non-fatal to the surrounding code. If the + catch block wishes to optionally handle some exceptions but not others, + it can re-raise it (or another exception) by calling die in the usual + manner. + + As with try, the body of a catch {} block may also contain a return + expression, which as before, has its usual meaning, causing the entire + containing function to return with the given value. The body may also + contain loop control expressions (redo, next or last) which also have + their usual effect. + + If a catch statement is not given, then any exceptions raised by the + try block are raised to the caller in the usual way. + + catch (Typed) + + ... + catch ($var isa Class) { ... } + + ... + catch ($var =~ m/^Regexp match/) { ... } + + Experimental; since version 0.15. + + Optionally, multiple catch statements can be provided, where each block + is given a guarding condition, to control whether or not it will catch + particular exception values. Use of this syntax will provoke an + experimental category warning on supporting perl versions, unless + silenced by importing the :experimental(typed) tag (see above). + + Two kinds of condition are supported: + + * + + catch ($var isa Class) + + The block is invoked only if the caught exception is a blessed + object, and derives from the given package name. + + On Perl version 5.32 onwards, this condition test is implemented + using the same op type that the core $var isa Class syntax is + provided by and works in exactly the same way. + + On older perl versions it is emulated by a compatibility function. + Currently this function does not respect a ->isa method overload on + the exception instance. Usually this should not be a problem, as + exception class types rarely provide such a method. + + * + + catch ($var =~ m/regexp/) + + The block is invoked only if the caught exception is a string that + matches the given regexp. + + When an exception is caught, each condition is tested in the order they + are written in, until a matching case is found. If such a case is found + the corresponding block is invoked, and no further condition is tested. + If no contional block matched and there is a default (unconditional) + block at the end then that is invoked instead. If no such block exists, + then the exception is propagated up to the calling scope. + + finally + + ... + finally { + STATEMENTS... + } + + A finally statement provides a block of code to the preceding try + statement (or try/catch pair) which is executed afterwards, both in the + case of a normal execution or a thrown exception. This code block may + be used to provide whatever clean-up operations might be required by + preceding code. + + Because it is executed during a stack cleanup operation, a finally {} + block may not cause the containing function to return, or to alter the + return value of it. It also cannot see the containing function's @_ + arguments array (though as it is block scoped within the function, it + will continue to share any normal lexical variables declared up until + that point). It is protected from disturbing the value of $@. If the + finally {} block code throws an exception, this will be printed as a + warning and discarded, leaving $@ containing the original exception, if + one existed. + +OTHER MODULES + + There are already quite a number of modules on CPAN that provide a + try/catch-like syntax for Perl. + + * Try + + * TryCatch + + * Try::Tiny + + * Syntax::Feature::Try + + In addition, core perl itself gained a try/catch syntax based on this + module at version 5.34.0. It is available as use feature 'try'. + + They are compared here, by feature: + + True syntax plugin + + Like Try and Syntax::Feature::Try, this module is implemented as a true + syntax plugin, allowing it to provide new parsing rules not available + to simple functions. Most notably here it means that the resulting + combination does not need to end in a semicolon. + + The core feature 'try' is also implemented as true native syntax in the + perl parser. + + In comparison, Try::Tiny is plain perl and provides its functionality + using regular perl functions; as such its syntax requires the trailing + semicolon. + + TryCatch is a hybrid that uses Devel::Declare to parse the syntax tree. + + @_ in a try or catch block + + Because the try and catch block code is contained in a true block + rather than an entire anonymous subroutine, invoking it does not + interfere with the @_ arguments array. Code inside these blocks can + interact with the containing function's array as before. + + This feature is unique among these modules; none of the others listed + have this ability. + + The core feature 'try' also behaves in this manner. + + return in a try or catch block + + Like TryCatch and Syntax::Feature::Try, the return statement has its + usual effect within a subroutine containing syntax provided by this + module. Namely, it causes the containing sub itself to return. + + It also behaves this way using the core feature 'try'. + + In comparison, using Try or Try::Tiny mean that a return statement will + only exit from the try block. + + next/last/redo in a try or catch block + + The loop control keywords of next, last and redo have their usual + effect on dynamically contained loops. + + These also work fine when using the core feature 'try'. + + Syntax::Feature::Try documents that these do not work there. The other + modules make no statement either way. + + Value Semantics + + Like Try and Syntax::Feature::Try, the syntax provided by this module + only works as a syntax-level statement and not an expression. You + cannot assign from the result of a try block. A common workaround is to + wrap the try/catch statement inside a do block, where its final + expression can be captured and used as a value. + + The same do block wrapping also works for the core feature 'try'. + + In comparison, the behaviour implemented by Try::Tiny can be used as a + valued expression, such as assigned to a variable or returned to the + caller of its containing function. + + try without catch + + Like Syntax::Feature::Try, the syntax provided by this module allows a + try block to be followed by only a finally block, with no catch. In + this case, exceptions thrown by code contained by the try are not + suppressed, instead they propagate as normal to callers. This matches + the behaviour familiar to Java or C++ programmers. + + In comparison, the code provided by Try and Try::Tiny always suppress + exception propagation even without an actual catch block. + + The TryCatch module does not allow a try block not followed by catch. + + The core feature 'try' does not implement finally at all, and also + requires that every try block be followed by a catch. + + Typed catch + + Try and Try::Tiny make no attempt to perform any kind of typed dispatch + to distinguish kinds of exception caught by catch blocks. + + Likewise the core feature 'try' currently does not provide this + ability, though it remains an area of ongoing design work. + + TryCatch and Syntax::Feature::Try both attempt to provide a kind of + typed dispatch where different classes of exception are caught by + different blocks of code, or propagated up entirely to callers. + + This module provides such an ability, via the currently-experimental + catch (VAR cond...) syntax. + + The design thoughts continue on the RT ticket + https://rt.cpan.org/Ticket/Display.html?id=123918. + +WITH OTHER MODULES + + Future::AsyncAwait + + As of Future::AsyncAwait version 0.10 and Syntax::Keyword::Try version + 0.07, cross-module integration tests assert that basic try/catch blocks + inside an async sub work correctly, including those that attempt to + return from inside try. + + use Future::AsyncAwait; + use Syntax::Keyword::Try; + + async sub attempt + { + try { + await func(); + return "success"; + } + catch { + return "failed"; + } + } + +ISSUES + + Thread-safety at load time cannot be assured before perl 5.16 + + On perl versions 5.16 and above this module is thread-safe. + + On perl version 5.14 this module is thread-safe provided that it is + used before any additional threads are created. + + However, when using 5.14 there is a race condition if this module is + loaded late in the program startup, after additional threads have been + created. This leads to the potential for it to be started up multiple + times concurrently, which creates data races when modifying internal + structures and likely leads to a segmentation fault, either during load + or soon after when more code is compiled. + + As a workaround, for any such program that creates multiple threads, + loads additional code (such as dynamically-discovered plugins), and has + to run on 5.14, it should make sure to + + use Syntax::Keyword::Try; + + early on in startup, before it spins out any additional threads. + + (See also https://rt.cpan.org/Public/Bug/Display.html?id=123547) + + $@ is not local'ised by try do before perl 5.24 + + On perl versions 5.24 and above, or when using only control-flow + statement syntax, $@ is always correctly localised. + + However, when using the experimental value-yielding expression version + try do {...} on perl versions 5.22 or older, the localisation of $@ + does not correctly apply around the expression. After such an + expression, the value of $@ will leak out if a failure happened and the + catch block was invoked, overwriting any previous value that was + visible there. + + (See also https://rt.cpan.org/Public/Bug/Display.html?id=124366) + +ACKNOWLEDGEMENTS + + With thanks to Zefram, ilmari and others from irc.perl.org/#p5p for + assisting with trickier bits of XS logic. + +AUTHOR + + Paul Evans + diff --git a/hax/newOP_CUSTOM.c.inc b/hax/newOP_CUSTOM.c.inc new file mode 100644 index 0000000..9bf7ab3 --- /dev/null +++ b/hax/newOP_CUSTOM.c.inc @@ -0,0 +1,109 @@ +/* vi: set ft=c : */ + +/* Before perl 5.22 under -DDEBUGGING, various new*OP() functions throw assert + * failures on OP_CUSTOM. + * https://rt.cpan.org/Ticket/Display.html?id=128562 + */ + +#define newOP_CUSTOM(func, flags) S_newOP_CUSTOM(aTHX_ func, flags) +#define newUNOP_CUSTOM(func, flags, first) S_newUNOP_CUSTOM(aTHX_ func, flags, first) +#define newSVOP_CUSTOM(func, flags, sv) S_newSVOP_CUSTOM(aTHX_ func, flags, sv) +#define newBINOP_CUSTOM(func, flags, first, last) S_newBINOP_CUSTOM(aTHX_ func, flags, first, last) +#define newLOGOP_CUSTOM(func, flags, first, other) S_newLOGOP_CUSTOM(aTHX_ func, flags, first, other) + +static OP *S_newOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags) +{ + OP *op = newOP(OP_CUSTOM, flags); + op->op_ppaddr = func; + return op; +} + +static OP *S_newUNOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first) +{ + UNOP *unop; +#if HAVE_PERL_VERSION(5,22,0) + unop = (UNOP *)newUNOP(OP_CUSTOM, flags, first); +#else + NewOp(1101, unop, 1, UNOP); + unop->op_type = (OPCODE)OP_CUSTOM; + unop->op_first = first; + unop->op_flags = (U8)(flags | OPf_KIDS); + unop->op_private = (U8)(1 | (flags >> 8)); +#endif + unop->op_ppaddr = func; + return (OP *)unop; +} + +static OP *S_newSVOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, SV *sv) +{ + SVOP *svop; +#if HAVE_PERL_VERSION(5,22,0) + svop = (SVOP *)newSVOP(OP_CUSTOM, flags, sv); +#else + NewOp(1101, svop, 1, SVOP); + svop->op_type = (OPCODE)OP_CUSTOM; + svop->op_sv = sv; + svop->op_next = (OP *)svop; + svop->op_flags = 0; + svop->op_private = 0; +#endif + svop->op_ppaddr = func; + return (OP *)svop; +} + +static OP *S_newBINOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last) +{ + BINOP *binop; +#if HAVE_PERL_VERSION(5,22,0) + binop = (BINOP *)newBINOP(OP_CUSTOM, flags, first, last); +#else + NewOp(1101, binop, 1, BINOP); + binop->op_type = (OPCODE)OP_CUSTOM; + binop->op_first = first; + first->op_sibling = last; + binop->op_last = last; + binop->op_flags = (U8)(flags | OPf_KIDS); + binop->op_private = (U8)(2 | (flags >> 8)); +#endif + binop->op_ppaddr = func; + return (OP *)binop; +} + +static OP *S_newLOGOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *other) +{ + OP *o; +#if HAVE_PERL_VERSION(5,22,0) + o = newLOGOP(OP_CUSTOM, flags, first, other); +#else + /* Parts of this code copypasted from perl 5.20.0's op.c S_new_logop() + */ + LOGOP *logop; + + first = op_contextualize(first, G_SCALAR); + + NewOp(1101, logop, 1, LOGOP); + + logop->op_type = (OPCODE)OP_CUSTOM; + logop->op_ppaddr = NULL; /* Because caller only overrides it anyway */ + logop->op_first = first; + logop->op_flags = (U8)(flags | OPf_KIDS); + logop->op_other = LINKLIST(other); + /* logop->op_private has nothing interesting for OP_CUSTOM */ + + /* Link in postfix order */ + logop->op_next = LINKLIST(first); + first->op_next = (OP *)logop; + first->op_sibling = other; + + /* No CHECKOP for OP_CUSTOM */ + o = newUNOP(OP_NULL, 0, (OP *)logop); + other->op_next = o; +#endif + + /* the returned op is actually an UNOP that's either NULL or NOT; the real + * logop is the op_next of it + */ + cUNOPx(o)->op_first->op_ppaddr = func; + + return o; +} diff --git a/hax/op_sibling_splice.c.inc b/hax/op_sibling_splice.c.inc new file mode 100644 index 0000000..522231f --- /dev/null +++ b/hax/op_sibling_splice.c.inc @@ -0,0 +1,44 @@ +/* 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 diff --git a/hax/optree-additions.c.inc b/hax/optree-additions.c.inc new file mode 100644 index 0000000..8133785 --- /dev/null +++ b/hax/optree-additions.c.inc @@ -0,0 +1,82 @@ +/* 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))); +} + +#define newPADxVOP(type, padix, flags, private) S_newPADxVOP(aTHX_ type, padix, flags, private) +static OP *S_newPADxVOP(pTHX_ I32 type, PADOFFSET padix, I32 flags, U32 private) +{ + OP *op = newOP(type, flags); + op->op_targ = padix; + op->op_private = private; + return op; +} + +#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; +} diff --git a/hax/perl-additions.c.inc b/hax/perl-additions.c.inc new file mode 100644 index 0000000..5c8d69e --- /dev/null +++ b/hax/perl-additions.c.inc @@ -0,0 +1,263 @@ +/* vi: set ft=c : */ + +#ifndef av_count +# define av_count(av) (AvFILL(av) + 1) +#endif + +#if HAVE_PERL_VERSION(5, 22, 0) +# define PadnameIsNULL(pn) (!(pn)) +#else +# define PadnameIsNULL(pn) (!(pn) || (pn) == &PL_sv_undef) +#endif + +#ifndef hv_deletes +# define hv_deletes(hv, skey, flags) hv_delete((hv), ("" skey ""), (sizeof(skey) - 1), flags) +#endif + +#if HAVE_PERL_VERSION(5, 22, 0) +# define PadnameOUTER_off(pn) (PadnameFLAGS(pn) &= ~PADNAMEt_OUTER) +#else + /* PadnameOUTER is really the SvFAKE flag */ +# define PadnameOUTER_off(pn) SvFAKE_off(pn) +#endif + +#define save_strndup(s, l) S_save_strndup(aTHX_ s, l) +static char *S_save_strndup(pTHX_ char *s, STRLEN l) +{ + /* savepvn doesn't put anything on the save stack, despite its name */ + char *ret = savepvn(s, l); + SAVEFREEPV(ret); + return ret; +} + +#define sv_setrv(s, r) S_sv_setrv(aTHX_ s, r) +static void S_sv_setrv(pTHX_ SV *sv, SV *rv) +{ + sv_setiv(sv, (IV)rv); +#if !HAVE_PERL_VERSION(5, 24, 0) + SvIOK_off(sv); +#endif + SvROK_on(sv); +} + +static char *PL_savetype_name[] PERL_UNUSED_DECL = { + /* These have been present since 5.16 */ + [SAVEt_ADELETE] = "ADELETE", + [SAVEt_AELEM] = "AELEM", + [SAVEt_ALLOC] = "ALLOC", + [SAVEt_APTR] = "APTR", + [SAVEt_AV] = "AV", + [SAVEt_BOOL] = "BOOL", + [SAVEt_CLEARSV] = "CLEARSV", + [SAVEt_COMPILE_WARNINGS] = "COMPILE_WARNINGS", + [SAVEt_COMPPAD] = "COMPPAD", + [SAVEt_DELETE] = "DELETE", + [SAVEt_DESTRUCTOR] = "DESTRUCTOR", + [SAVEt_DESTRUCTOR_X] = "DESTRUCTOR_X", + [SAVEt_FREECOPHH] = "FREECOPHH", + [SAVEt_FREEOP] = "FREEOP", + [SAVEt_FREEPV] = "FREEPV", + [SAVEt_FREESV] = "FREESV", + [SAVEt_GENERIC_PVREF] = "GENERIC_PVREF", + [SAVEt_GENERIC_SVREF] = "GENERIC_SVREF", + [SAVEt_GP] = "GP", + [SAVEt_GVSV] = "GVSV", + [SAVEt_HELEM] = "HELEM", + [SAVEt_HINTS] = "HINTS", + [SAVEt_HPTR] = "HPTR", + [SAVEt_HV] = "HV", + [SAVEt_I16] = "I16", + [SAVEt_I32] = "I32", + [SAVEt_I32_SMALL] = "I32_SMALL", + [SAVEt_I8] = "I8", + [SAVEt_INT] = "INT", + [SAVEt_INT_SMALL] = "INT_SMALL", + [SAVEt_ITEM] = "ITEM", + [SAVEt_IV] = "IV", + [SAVEt_LONG] = "LONG", + [SAVEt_MORTALIZESV] = "MORTALIZESV", + [SAVEt_NSTAB] = "NSTAB", + [SAVEt_OP] = "OP", + [SAVEt_PADSV_AND_MORTALIZE] = "PADSV_AND_MORTALIZE", + [SAVEt_PARSER] = "PARSER", + [SAVEt_PPTR] = "PPTR", + [SAVEt_REGCONTEXT] = "REGCONTEXT", + [SAVEt_SAVESWITCHSTACK] = "SAVESWITCHSTACK", + [SAVEt_SET_SVFLAGS] = "SET_SVFLAGS", + [SAVEt_SHARED_PVREF] = "SHARED_PVREF", + [SAVEt_SPTR] = "SPTR", + [SAVEt_STACK_POS] = "STACK_POS", + [SAVEt_SVREF] = "SVREF", + [SAVEt_SV] = "SV", + [SAVEt_VPTR] = "VPTR", + +#if HAVE_PERL_VERSION(5,18,0) + [SAVEt_CLEARPADRANGE] = "CLEARPADRANGE", + [SAVEt_GVSLOT] = "GVSLOT", +#endif + +#if HAVE_PERL_VERSION(5,20,0) + [SAVEt_READONLY_OFF] = "READONLY_OFF", + [SAVEt_STRLEN] = "STRLEN", +#endif + +#if HAVE_PERL_VERSION(5,22,0) + [SAVEt_FREEPADNAME] = "FREEPADNAME", +#endif + +#if HAVE_PERL_VERSION(5,24,0) + [SAVEt_TMPSFLOOR] = "TMPSFLOOR", +#endif + +#if HAVE_PERL_VERSION(5,34,0) + [SAVEt_STRLEN_SMALL] = "STRLEN_SMALL", + [SAVEt_HINTS_HH] = "HINTS_HH", +#endif +}; + +#define dKWARG(count) \ + U32 kwargi = count; \ + U32 kwarg; \ + SV *kwval; \ + /* TODO: complain about odd number of args */ + +#define KWARG_NEXT(args) \ + S_kwarg_next(aTHX_ args, &kwargi, items, ax, &kwarg, &kwval) +static bool S_kwarg_next(pTHX_ const char *args[], U32 *kwargi, U32 argc, U32 ax, U32 *kwarg, SV **kwval) +{ + if(*kwargi >= argc) + return FALSE; + + SV *argname = ST(*kwargi); (*kwargi)++; + if(!SvOK(argname)) + croak("Expected string for next argument name, got undef"); + + *kwarg = 0; + while(args[*kwarg]) { + if(strEQ(SvPV_nolen(argname), args[*kwarg])) { + *kwval = ST(*kwargi); (*kwargi)++; + return TRUE; + } + (*kwarg)++; + } + + croak("Unrecognised argument name '%" SVf "'", SVfARG(argname)); +} + +#define import_pragma(pragma, arg) S_import_pragma(aTHX_ pragma, arg) +static void S_import_pragma(pTHX_ const char *pragma, const char *arg) +{ + dSP; + bool unimport = FALSE; + + if(pragma[0] == '-') { + unimport = TRUE; + pragma++; + } + + SAVETMPS; + + EXTEND(SP, 2); + PUSHMARK(SP); + mPUSHp(pragma, strlen(pragma)); + if(arg) + mPUSHp(arg, strlen(arg)); + PUTBACK; + + call_method(unimport ? "unimport" : "import", G_VOID); + + FREETMPS; +} + +#define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version) +static void S_ensure_module_version(pTHX_ SV *module, SV *version) +{ + dSP; + + ENTER; + + PUSHMARK(SP); + PUSHs(module); + PUSHs(version); + PUTBACK; + + call_method("VERSION", G_VOID); + + LEAVE; +} + +#if HAVE_PERL_VERSION(5, 16, 0) + /* TODO: perl 5.14 lacks HvNAMEUTF8, gv_fetchmeth_pvn() */ +# define fetch_superclass_method_pv(stash, pv, len, level) S_fetch_superclass_method_pv(aTHX_ stash, pv, len, level) +static CV *S_fetch_superclass_method_pv(pTHX_ HV *stash, const char *pv, STRLEN len, U32 level) +{ +# if HAVE_PERL_VERSION(5, 18, 0) + GV *gv = gv_fetchmeth_pvn(stash, pv, len, level, GV_SUPER); +# else + SV *superclassname = newSVpvf("%*s::SUPER", HvNAMELEN_get(stash), HvNAME_get(stash)); + if(HvNAMEUTF8(stash)) + SvUTF8_on(superclassname); + SAVEFREESV(superclassname); + + HV *superstash = gv_stashsv(superclassname, GV_ADD); + GV *gv = gv_fetchmeth_pvn(superstash, pv, len, level, 0); +# endif + + if(!gv) + return NULL; + return GvCV(gv); +} +#endif /* HAVE_PERL_VERSION(5, 16, 0) */ + +#define get_class_isa(stash) S_get_class_isa(aTHX_ stash) +static AV *S_get_class_isa(pTHX_ HV *stash) +{ + GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0); + if(!gvp || !GvAV(*gvp)) + croak("Expected %s to have a @ISA list", HvNAME(stash)); + + return GvAV(*gvp); +} + +#define find_cop_for_lvintro(padix, o, copp) S_find_cop_for_lvintro(aTHX_ padix, o, copp) +static COP *S_find_cop_for_lvintro(pTHX_ PADOFFSET padix, OP *o, COP **copp) +{ + for( ; o; o = OpSIBLING(o)) { + if(OP_CLASS(o) == OA_COP) { + *copp = (COP *)o; + } + else if(o->op_type == OP_PADSV && o->op_targ == padix && o->op_private & OPpLVAL_INTRO) { + return *copp; + } + else if(o->op_flags & OPf_KIDS) { + COP *ret = find_cop_for_lvintro(padix, cUNOPx(o)->op_first, copp); + if(ret) + return ret; + } + } + + return NULL; +} + +#define lex_consume_unichar(c) MY_lex_consume_unichar(aTHX_ c) +static bool MY_lex_consume_unichar(pTHX_ U32 c) +{ + if(lex_peek_unichar(0) != c) + return FALSE; + + lex_read_unichar(0); + return TRUE; +} + +#if HAVE_PERL_VERSION(5, 16, 0) + /* TODO: perl 5.14 lacks HvNAMEUTF8, HvNAMELEN, sv_derived_from_pvn */ +# 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 /* HAVE_PERL_VERSION(5, 16, 0) */ diff --git a/hax/perl-backcompat.c.inc b/hax/perl-backcompat.c.inc new file mode 100644 index 0000000..788c7c2 --- /dev/null +++ b/hax/perl-backcompat.c.inc @@ -0,0 +1,138 @@ +/* vi: set ft=c : */ + +#define HAVE_PERL_VERSION(R, V, S) \ + (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) + +#ifndef NOT_REACHED +# define NOT_REACHED assert(0) +#endif + +#ifndef SvTRUE_NN +# define SvTRUE_NN(sv) SvTRUE(sv) +#endif + +#ifndef G_LIST +# define G_LIST G_ARRAY +#endif + +#if !HAVE_PERL_VERSION(5, 18, 0) +typedef AV PADNAMELIST; +# define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) +# define PadlistNAMES(pl) (*PadlistARRAY(pl)) + +typedef SV PADNAME; +# define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) +# define PadnameLEN(pn) SvCUR(pn) +# define PadnameOUTER(pn) (SvFAKE(pn) && !SvPAD_STATE(pn)) +# define PadnamelistARRAY(pnl) AvARRAY(pnl) +# define PadnamelistMAX(pnl) AvFILLp(pnl) + +# define PadARRAY(p) AvARRAY(p) +# define PadMAX(pad) AvFILLp(pad) +#endif + +#ifndef av_top_index +# define av_top_index(av) AvFILL(av) +#endif + +#ifndef block_end +# define block_end(a,b) Perl_block_end(aTHX_ a,b) +#endif + +#ifndef block_start +# define block_start(a) Perl_block_start(aTHX_ a) +#endif + +#ifndef cv_clone +# define cv_clone(a) Perl_cv_clone(aTHX_ a) +#endif + +#ifndef intro_my +# define intro_my() Perl_intro_my(aTHX) +#endif + +#ifndef pad_alloc +# define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) +#endif + +#ifndef CX_CUR +# define CX_CUR() (&cxstack[cxstack_ix]) +#endif + +#if HAVE_PERL_VERSION(5, 24, 0) +# define OLDSAVEIX(cx) (cx->blk_oldsaveix) +#else +# define OLDSAVEIX(cx) (PL_scopestack[cx->blk_oldscopesp-1]) +#endif + +#ifndef OpSIBLING +# define OpSIBLING(op) ((op)->op_sibling) +#endif + +#ifndef OpMORESIB_set +# define OpMORESIB_set(op,sib) ((op)->op_sibling = (sib)) +#endif + +#ifndef OpLASTSIB_set + /* older perls don't need to store this at all */ +# define OpLASTSIB_set(op,parent) +#endif + +#ifndef op_convert_list +# define op_convert_list(type, flags, o) S_op_convert_list(aTHX_ type, flags, o) +static OP *S_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) +{ + /* A minimal recreation just for our purposes */ + assert( + /* A hardcoded list of the optypes we know this will work for */ + type == OP_ENTERSUB || + type == OP_JOIN || + type == OP_PUSH || + 0); + + o->op_type = type; + o->op_flags |= flags; + o->op_ppaddr = PL_ppaddr[type]; + + o = PL_check[type](aTHX_ o); + + /* op_std_init() */ + if(PL_opargs[type] & OA_RETSCALAR) + o = op_contextualize(o, G_SCALAR); + if(PL_opargs[type] & OA_TARGET && !o->op_targ) + o->op_targ = pad_alloc(type, SVs_PADTMP); + + return o; +} +#endif + +#ifndef newMETHOP_named +# define newMETHOP_named(type, flags, name) newSVOP(type, flags, name) +#endif + +#ifndef PARENT_PAD_INDEX_set +# if HAVE_PERL_VERSION(5, 22, 0) +# define PARENT_PAD_INDEX_set(pn,val) (PARENT_PAD_INDEX(pn) = val) +# else + /* stolen from perl-5.20.0's pad.c */ +# define PARENT_PAD_INDEX_set(sv,val) \ + STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END +# endif +#endif + +/* On Perl 5.14 this had a different name */ +#ifndef pad_add_name_pvn +#define pad_add_name_pvn(name, len, flags, typestash, ourstash) MY_pad_add_name(aTHX_ name, len, flags, typestash, ourstash) +PADOFFSET MY_pad_add_name(pTHX_ const char *name, STRLEN len, U32 flags, HV *typestash, HV *ourstash) +{ + /* perl 5.14's Perl_pad_add_name requires a NUL-terminated name */ + SV *namesv = sv_2mortal(newSVpvn(name, len)); + + return Perl_pad_add_name(aTHX_ SvPV_nolen(namesv), SvCUR(namesv), flags, typestash, ourstash); +} +#endif + +#if !HAVE_PERL_VERSION(5, 26, 0) +# define isIDFIRST_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDFIRST_utf8(s)) +# define isIDCONT_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDCONT_utf8(s)) +#endif diff --git a/lib/Syntax/Keyword/Try.pm b/lib/Syntax/Keyword/Try.pm new file mode 100644 index 0000000..69ae7e0 --- /dev/null +++ b/lib/Syntax/Keyword/Try.pm @@ -0,0 +1,474 @@ +# 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, 2016-2022 -- leonerd@leonerd.org.uk + +package Syntax::Keyword::Try 0.27; + +use v5.14; +use warnings; + +use Carp; + +require XSLoader; +XSLoader::load( __PACKAGE__, our $VERSION ); + +=head1 NAME + +C - a C syntax for perl + +=head1 SYNOPSIS + + use Syntax::Keyword::Try; + + sub foo { + try { + attempt_a_thing(); + return "success"; + } + catch ($e) { + warn "It failed - $e"; + return "failure"; + } + } + +=head1 DESCRIPTION + +This module provides a syntax plugin that implements exception-handling +semantics in a form familiar to users of other languages, being built on a +block labeled with the C keyword, followed by at least one of a C +or C block. + +As well as providing a handy syntax for this useful behaviour, this module +also serves to contain a number of code examples for how to implement parser +plugins and manipulate optrees to provide new syntax and behaviours for perl +code. + +Syntax similar to this module has now been added to core perl, starting at +version 5.34.0. If you are writing new code, it is suggested that you instead +use the L module instead, as that will enable the core +feature on those supported perl versions, falling back to +C on older perls. + +=head1 Experimental Features + +Some of the features of this module are currently marked as experimental. They +will provoke warnings in the C category, unless silenced. + +You can silence this with C but then that will +silence every experimental warning, which may hide others unintentionally. For +a more fine-grained approach you can instead use the import line for this +module to only silence this module's warnings selectively: + + use Syntax::Keyword::Try qw( try :experimental(typed) ); + + use Syntax::Keyword::Try qw( try :experimental ); # all of the above + +Don't forget to import the main C symbol itself, to activate the syntax. + +=cut + +=head1 KEYWORDS + +=head2 try + + try { + STATEMENTS... + } + ... + +A C statement provides the main body of code that will be invoked, and +must be followed by either a C statement, a C statement, or +both. + +Execution of the C statement itself begins from the block given to the +statement and continues until either it throws an exception, or completes +successfully by reaching the end of the block. What will happen next depends +on the presence of a C or C statement immediately following +it. + +The body of a C block may contain a C expression. If executed, +such an expression will cause the entire containing function to return with +the value provided. This is different from a plain C block, in which +circumstance only the C itself would return, not the entire function. + +The body of a C block may contain loop control expressions (C, +C, C) which will have their usual effect on any loops that the +C block is contained by. + +The parsing rules for the set of statements (the C block and its +associated C and C) are such that they are parsed as a self- +contained statement. Because of this, there is no need to end with a +terminating semicolon. + +Even though it parses as a statement and not an expression, a C block can +still yield a value if it appears as the final statement in its containing +C or C block. For example: + + my $result = do { + try { attempt_func() } + catch ($e) { "Fallback Value" } + }; + +Note (especially to users of L and similar) that the C +block itself does not necessarily stop exceptions thrown inside it from +propagating outside. It is the presence of a later C block which +causes this to happen. A C with only a C and no C will +still propagate exceptions up to callers as normal. + +=head2 catch + + ... + catch ($var) { + STATEMENTS... + } + +or + + ... + catch { + STATEMENTS... + } + +A C statement provides a block of code to the preceding C +statement that will be invoked in the case that the main block of code throws +an exception. Optionally a new lexical variable can be provided to store the +exception in. If not provided, the C block can inspect the raised +exception by looking in C<$@> instead. + +Presence of this C statement causes any exception thrown by the +preceding C block to be non-fatal to the surrounding code. If the +C block wishes to optionally handle some exceptions but not others, it +can re-raise it (or another exception) by calling C in the usual manner. + +As with C, the body of a C block may also contain a C +expression, which as before, has its usual meaning, causing the entire +containing function to return with the given value. The body may also contain +loop control expressions (C, C or C) which also have their +usual effect. + +If a C statement is not given, then any exceptions raised by the C +block are raised to the caller in the usual way. + +=head2 catch (Typed) + + ... + catch ($var isa Class) { ... } + + ... + catch ($var =~ m/^Regexp match/) { ... } + +I + +Optionally, multiple catch statements can be provided, where each block is +given a guarding condition, to control whether or not it will catch particular +exception values. Use of this syntax will provoke an C category +warning on supporting perl versions, unless silenced by importing the +C<:experimental(typed)> tag (see above). + +Two kinds of condition are supported: + +=over 4 + +=item * + + catch ($var isa Class) + +The block is invoked only if the caught exception is a blessed object, and +derives from the given package name. + +On Perl version 5.32 onwards, this condition test is implemented using the +same op type that the core C<$var isa Class> syntax is provided by and works +in exactly the same way. + +On older perl versions it is emulated by a compatibility function. Currently +this function does not respect a C<< ->isa >> method overload on the exception +instance. Usually this should not be a problem, as exception class types +rarely provide such a method. + +=item * + + catch ($var =~ m/regexp/) + +The block is invoked only if the caught exception is a string that matches +the given regexp. + +=back + +When an exception is caught, each condition is tested in the order they are +written in, until a matching case is found. If such a case is found the +corresponding block is invoked, and no further condition is tested. If no +contional block matched and there is a default (unconditional) block at the +end then that is invoked instead. If no such block exists, then the exception +is propagated up to the calling scope. + +=head2 finally + + ... + finally { + STATEMENTS... + } + +A C statement provides a block of code to the preceding C +statement (or C pair) which is executed afterwards, both in the +case of a normal execution or a thrown exception. This code block may be used +to provide whatever clean-up operations might be required by preceding code. + +Because it is executed during a stack cleanup operation, a C block +may not cause the containing function to return, or to alter the return value +of it. It also cannot see the containing function's C<@_> arguments array +(though as it is block scoped within the function, it will continue to share +any normal lexical variables declared up until that point). It is protected +from disturbing the value of C<$@>. If the C block code throws an +exception, this will be printed as a warning and discarded, leaving C<$@> +containing the original exception, if one existed. + +=head1 OTHER MODULES + +There are already quite a number of modules on CPAN that provide a +C-like syntax for Perl. + +=over 2 + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=back + +In addition, core perl itself gained a C syntax based on this +module at version 5.34.0. It is available as C. + +They are compared here, by feature: + +=head2 True syntax plugin + +Like L and L, this module is implemented as a true +syntax plugin, allowing it to provide new parsing rules not available to +simple functions. Most notably here it means that the resulting combination +does not need to end in a semicolon. + +The core C is also implemented as true native syntax in the +perl parser. + +In comparison, L is plain perl and provides its functionality using +regular perl functions; as such its syntax requires the trailing semicolon. + +L is a hybrid that uses L to parse the syntax tree. + +=head2 C<@_> in a try or catch block + +Because the C and C block code is contained in a true block rather +than an entire anonymous subroutine, invoking it does not interfere with the +C<@_> arguments array. Code inside these blocks can interact with the +containing function's array as before. + +This feature is unique among these modules; none of the others listed have +this ability. + +The core C also behaves in this manner. + +=head2 C in a try or catch block + +Like L and L, the C statement has its +usual effect within a subroutine containing syntax provided by this module. +Namely, it causes the containing C itself to return. + +It also behaves this way using the core C. + +In comparison, using L or L mean that a C statement +will only exit from the C block. + +=head2 C/C/C in a try or catch block + +The loop control keywords of C, C and C have their usual +effect on dynamically contained loops. + +These also work fine when using the core C. + +L documents that these do not work there. The other +modules make no statement either way. + +=head2 Value Semantics + +Like L and L, the syntax provided by this module +only works as a syntax-level statement and not an expression. You cannot +assign from the result of a C block. A common workaround is to wrap +the C statement inside a C block, where its final expression +can be captured and used as a value. + +The same C block wrapping also works for the core C. + +In comparison, the behaviour implemented by L can be used as a +valued expression, such as assigned to a variable or returned to the caller of +its containing function. + +=head2 C without C + +Like L, the syntax provided by this module allows a +C block to be followed by only a C block, with no C. In +this case, exceptions thrown by code contained by the C are not +suppressed, instead they propagate as normal to callers. This matches the +behaviour familiar to Java or C++ programmers. + +In comparison, the code provided by L and L always suppress +exception propagation even without an actual C block. + +The L module does not allow a C block not followed by C. + +The core C does not implement C at all, and also +requires that every C block be followed by a C. + +=head2 Typed C + +L and L make no attempt to perform any kind of typed dispatch +to distinguish kinds of exception caught by C blocks. + +Likewise the core C currently does not provide this ability, +though it remains an area of ongoing design work. + +L and L both attempt to provide a kind of +typed dispatch where different classes of exception are caught by different +blocks of code, or propagated up entirely to callers. + +This module provides such an ability, via the currently-experimental +C syntax. + +The design thoughts continue on the RT ticket +L. + +=cut + +sub import +{ + my $class = shift; + my $caller = caller; + + $class->import_into( $caller, @_ ); +} + +my @EXPERIMENTAL = qw( typed ); + +sub import_into +{ + my $class = shift; + my ( $caller, @syms ) = @_; + + @syms or @syms = qw( try ); + + my %syms = map { $_ => 1 } @syms; + $^H{"Syntax::Keyword::Try/try"}++ if delete $syms{try}; + + # Largely for Feature::Compat::Try's benefit + $^H{"Syntax::Keyword::Try/no_finally"}++ if delete $syms{"-no_finally"}; + $^H{"Syntax::Keyword::Try/require_catch"}++ if delete $syms{"-require_catch"}; + $^H{"Syntax::Keyword::Try/require_var"}++ if delete $syms{"-require_var"}; + + # stablised experiments + delete $syms{":experimental($_)"} for qw( var ); + + foreach ( @EXPERIMENTAL ) { + $^H{"Syntax::Keyword::Try/experimental($_)"}++ if delete $syms{":experimental($_)"}; + } + + if( delete $syms{":experimental"} ) { + $^H{"Syntax::Keyword::Try/experimental($_)"}++ for @EXPERIMENTAL; + } + + # Ignore requests for these, as they come automatically with `try` + delete @syms{qw( catch finally )}; + + if( $syms{try_value} or $syms{":experimental(try_value)"} ) { + croak "The 'try_value' experimental feature is now removed\n" . + "Instead, you should use do { try ... } to yield a value from a try/catch statement"; + } + + croak "Unrecognised import symbols @{[ keys %syms ]}" if keys %syms; +} + +=head1 WITH OTHER MODULES + +=head2 Future::AsyncAwait + +As of C version 0.10 and L version +0.07, cross-module integration tests assert that basic C blocks +inside an C work correctly, including those that attempt to +C from inside C. + + use Future::AsyncAwait; + use Syntax::Keyword::Try; + + async sub attempt + { + try { + await func(); + return "success"; + } + catch { + return "failed"; + } + } + +=head1 ISSUES + +=head2 Thread-safety at load time cannot be assured before perl 5.16 + +On F versions 5.16 and above this module is thread-safe. + +On F version 5.14 this module is thread-safe provided that it is +Cd before any additional threads are created. + +However, when using 5.14 there is a race condition if this module is loaded +late in the program startup, after additional threads have been created. This +leads to the potential for it to be started up multiple times concurrently, +which creates data races when modifying internal structures and likely leads +to a segmentation fault, either during load or soon after when more code is +compiled. + +As a workaround, for any such program that creates multiple threads, loads +additional code (such as dynamically-discovered plugins), and has to run on +5.14, it should make sure to + + use Syntax::Keyword::Try; + +early on in startup, before it spins out any additional threads. + +(See also L) + +=head2 $@ is not local'ised by C before perl 5.24 + +On F versions 5.24 and above, or when using only control-flow statement +syntax, C<$@> is always correctly Cised. + +However, when using the experimental value-yielding expression version +C on perl versions 5.22 or older, the Cisation of C<$@> +does not correctly apply around the expression. After such an expression, the +value of C<$@> will leak out if a failure happened and the C block was +invoked, overwriting any previous value that was visible there. + +(See also L) + +=head1 ACKNOWLEDGEMENTS + +With thanks to C, C and others from C for +assisting with trickier bits of XS logic. + +=head1 AUTHOR + +Paul Evans + +=cut + +0x55AA; diff --git a/lib/Syntax/Keyword/Try.xs b/lib/Syntax/Keyword/Try.xs new file mode 100644 index 0000000..c3430f2 --- /dev/null +++ b/lib/Syntax/Keyword/Try.xs @@ -0,0 +1,624 @@ +/* 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, 2016-2021 -- leonerd@leonerd.org.uk + */ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "XSParseKeyword.h" + +#include "perl-backcompat.c.inc" + +#if HAVE_PERL_VERSION(5,32,0) +# define HAVE_OP_ISA +#endif + +#if HAVE_PERL_VERSION(5,26,0) +# define HAVE_OP_SIBPARENT +#endif + +#if HAVE_PERL_VERSION(5,19,4) +typedef SSize_t array_ix_t; +#else /* <5.19.4 */ +typedef I32 array_ix_t; +#endif /* <5.19.4 */ + +#include "perl-additions.c.inc" +#include "optree-additions.c.inc" +#include "op_sibling_splice.c.inc" +#include "newOP_CUSTOM.c.inc" + +static OP *pp_entertrycatch(pTHX); +static OP *pp_catch(pTHX); + +/* + * A modified version of pp_return for returning from inside a try block. + * To do this, we unwind the context stack to just past the CXt_EVAL and then + * chain to the regular OP_RETURN func + */ +static OP *pp_returnintry(pTHX) +{ + I32 cxix; + + for (cxix = cxstack_ix; cxix; cxix--) { + if(CxTYPE(&cxstack[cxix]) == CXt_SUB) + break; + + if(CxTYPE(&cxstack[cxix]) == CXt_EVAL && CxTRYBLOCK(&cxstack[cxix])) { + /* If this CXt_EVAL frame came from our own ENTERTRYCATCH, then the + * retop should point at an OP_CUSTOM and its first grand-child will be + * our custom modified ENTERTRY. We can skip over it and continue in + * this case. + */ + OP *retop = cxstack[cxix].blk_eval.retop; + OP *leave, *enter; + if(retop->op_type == OP_CUSTOM && retop->op_ppaddr == &pp_catch && + (leave = cLOGOPx(retop)->op_first) && leave->op_type == OP_LEAVETRY && + (enter = cLOGOPx(leave)->op_first) && enter->op_type == OP_ENTERTRY && + enter->op_ppaddr == &pp_entertrycatch) { + continue; + } + /* We have to stop at any other kind of CXt_EVAL */ + break; + } + } + if(!cxix) + croak("Unable to find an CXt_SUB to pop back to"); + + I32 gimme = cxstack[cxix].blk_gimme; + SV *retval; + + /* chunks of this code inspired by + * ZEFRAM/Scope-Escape-0.005/lib/Scope/Escape.xs + */ + switch(gimme) { + case G_VOID: + (void)POPMARK; + break; + + case G_SCALAR: { + dSP; + dMARK; + retval = (MARK == SP) ? &PL_sv_undef : TOPs; + SvREFCNT_inc(retval); + sv_2mortal(retval); + break; + } + + case G_LIST: { + dSP; + dMARK; + SV **retvals = MARK+1; + array_ix_t retcount = SP-MARK; + array_ix_t i; + AV *retav = newAV(); + retval = (SV *)retav; + sv_2mortal(retval); + av_fill(retav, retcount-1); + Copy(retvals, AvARRAY(retav), retcount, SV *); + for(i = 0; i < retcount; i++) + SvREFCNT_inc(retvals[i]); + break; + } + } + + dounwind(cxix); + + /* Now put the value back */ + switch(gimme) { + case G_VOID: { + dSP; + PUSHMARK(SP); + break; + } + + case G_SCALAR: { + dSP; + PUSHMARK(SP); + XPUSHs(retval); + PUTBACK; + break; + } + + case G_LIST: { + dSP; + PUSHMARK(SP); + AV *retav = (AV *)retval; + array_ix_t retcount = av_len(retav) + 1; /* because av_len means top index */ + EXTEND(SP, retcount); + Copy(AvARRAY(retav), SP+1, retcount, SV *); + SP += retcount; + PUTBACK; + break; + } + } + + return PL_ppaddr[OP_RETURN](aTHX); +} + +/* + * A custom SVOP that takes a CV and arranges for it to be invoked on scope + * leave + */ +static XOP xop_pushfinally; + +static void invoke_finally(pTHX_ void *arg) +{ + CV *finally = arg; + dSP; + + PUSHMARK(SP); + call_sv((SV *)finally, G_DISCARD|G_EVAL|G_KEEPERR); + + SvREFCNT_dec(finally); +} + +static OP *pp_pushfinally(pTHX) +{ + CV *finally = (CV *)cSVOP->op_sv; + + /* finally is a closure protosub; we have to clone it into a real sub. + * If we do this now then captured lexicals still work even around + * Future::AsyncAwait (see RT122796) + * */ + SAVEDESTRUCTOR_X(&invoke_finally, (SV *)cv_clone(finally)); + return PL_op->op_next; +} + +#define newLOCALISEOP(gv) MY_newLOCALISEOP(aTHX_ gv) +static OP *MY_newLOCALISEOP(pTHX_ GV *gv) +{ + OP *op = newGVOP(OP_GVSV, 0, gv); + op->op_private |= OPpLVAL_INTRO; + return op; +} + +#define newSTATEOP_nowarnings() MY_newSTATEOP_nowarnings(aTHX) +static OP *MY_newSTATEOP_nowarnings(pTHX) +{ + OP *op = newSTATEOP(0, NULL, NULL); + STRLEN *warnings = ((COP *)op)->cop_warnings; + char *warning_bits; + + if(warnings == pWARN_NONE) + return op; + + if(warnings == pWARN_STD) + /* TODO: understand what STD vs ALL means */ + warning_bits = WARN_ALLstring; + else if(warnings == pWARN_ALL) + warning_bits = WARN_ALLstring; + else + warning_bits = (char *)(warnings + 1); + + warnings = Perl_new_warnings_bitfield(aTHX_ warnings, warning_bits, WARNsize); + ((COP *)op)->cop_warnings = warnings; + + warning_bits = (char *)(warnings + 1); + warning_bits[(2*WARN_EXITING) / 8] &= ~(1 << (2*WARN_EXITING % 8)); + + return op; +} + +static void rethread_op(OP *op, OP *old, OP *new) +{ + if(op->op_next == old) + op->op_next = new; + + switch(OP_CLASS(op)) { + case OA_LOGOP: + if(cLOGOPx(op)->op_other == old) + cLOGOPx(op)->op_other = new; + break; + + case OA_LISTOP: + if(cLISTOPx(op)->op_last == old) + cLISTOPx(op)->op_last = new; + break; + } + + if(op->op_flags & OPf_KIDS) { + OP *kid; + for(kid = cUNOPx(op)->op_first; kid; kid = OpSIBLING(kid)) + rethread_op(kid, old, new); + } +} + +#define walk_optree_try_in_eval(op_ptr, root) MY_walk_optree_try_in_eval(aTHX_ op_ptr, root) +static void MY_walk_optree_try_in_eval(pTHX_ OP **op_ptr, OP *root); +static void MY_walk_optree_try_in_eval(pTHX_ OP **op_ptr, OP *root) +{ + OP *op = *op_ptr; + + switch(op->op_type) { + /* Fix 'return' to unwind the CXt_EVAL block that implements try{} first */ + case OP_RETURN: + op->op_ppaddr = &pp_returnintry; + break; + + /* wrap no warnings 'exiting' around loop controls */ + case OP_NEXT: + case OP_LAST: + case OP_REDO: + { +#ifdef HAVE_OP_SIBPARENT + OP *parent = OpHAS_SIBLING(op) ? NULL : op->op_sibparent; +#endif + + OP *stateop = newSTATEOP_nowarnings(); + + OP *scope = newLISTOP(OP_SCOPE, 0, + stateop, op); +#ifdef HAVE_OP_SIBPARENT + if(parent) + OpLASTSIB_set(scope, parent); + else + OpLASTSIB_set(scope, NULL); +#else + op->op_sibling = NULL; +#endif + + /* Rethread */ + scope->op_next = stateop; + stateop->op_next = op; + + *op_ptr = scope; + } + break; + + /* Don't enter inside nested eval{} blocks */ + case OP_LEAVETRY: + return; + } + + if(op->op_flags & OPf_KIDS) { + OP *kid, *next, *prev = NULL; + for(kid = cUNOPx(op)->op_first; kid; kid = next) { + OP *newkid = kid; + next = OpSIBLING(kid); + + walk_optree_try_in_eval(&newkid, root); + + if(newkid != kid) { + rethread_op(root, kid, newkid); + + if(prev) { + OpMORESIB_set(prev, newkid); + } + else + cUNOPx(op)->op_first = newkid; + + if(next) + OpMORESIB_set(newkid, next); + } + + prev = kid; + } + } +} + +static OP *pp_entertrycatch(pTHX) +{ + /* Localise the errgv */ + save_scalar(PL_errgv); + + return PL_ppaddr[OP_ENTERTRY](aTHX); +} + +static XOP xop_catch; + +static OP *pp_catch(pTHX) +{ + /* If an error didn't happen, then ERRSV will be both not true and not a + * reference. If it's a reference, then an error definitely happened + */ + if(SvROK(ERRSV) || SvTRUE(ERRSV)) + return cLOGOP->op_other; + else + return cLOGOP->op_next; +} + +#define newENTERTRYCATCHOP(flags, try, catch) MY_newENTERTRYCATCHOP(aTHX_ flags, try, catch) +static OP *MY_newENTERTRYCATCHOP(pTHX_ U32 flags, OP *try, OP *catch) +{ + OP *enter, *entertry, *ret; + + /* Walk the block for OP_RETURN ops, so we can apply a hack to them to + * make + * try { return } + * return from the containing sub, not just the eval block + */ + walk_optree_try_in_eval(&try, try); + + enter = newUNOP(OP_ENTERTRY, 0, try); + /* despite calling newUNOP(OP_ENTERTRY,...) the returned root node is the + * OP_LEAVETRY, whose first child is the ENTERTRY we wanted + */ + entertry = ((UNOP *)enter)->op_first; + entertry->op_ppaddr = &pp_entertrycatch; + + /* If we call newLOGOP_CUSTOM it will op_contextualize the enter block into + * G_SCALAR. This is not what we want + */ + { + LOGOP *logop; + + OP *first = enter, *other = newLISTOP(OP_SCOPE, 0, catch, NULL); + + NewOp(1101, logop, 1, LOGOP); + + logop->op_type = OP_CUSTOM; + logop->op_ppaddr = &pp_catch; + logop->op_first = first; + logop->op_flags = OPf_KIDS; + logop->op_other = LINKLIST(other); + + logop->op_next = LINKLIST(first); + enter->op_next = (OP *)logop; +#if HAVE_PERL_VERSION(5, 22, 0) + op_sibling_splice((OP *)logop, first, 0, other); +#else + first->op_sibling = other; +#endif + + ret = newUNOP(OP_NULL, 0, (OP *)logop); + other->op_next = ret; + } + + return ret; +} + +#ifndef HAVE_OP_ISA +static XOP xop_isa; + +/* Totally stolen from perl 5.32.0's pp.c */ +#define sv_isa_sv(sv, namesv) S_sv_isa_sv(aTHX_ sv, namesv) +static bool S_sv_isa_sv(pTHX_ SV *sv, SV *namesv) +{ + if(!SvROK(sv) || !SvOBJECT(SvRV(sv))) + return FALSE; + + /* TODO: ->isa invocation */ + +#if HAVE_PERL_VERSION(5,16,0) + return sv_derived_from_sv(sv, namesv, 0); +#else + return sv_derived_from(sv, SvPV_nolen(namesv)); +#endif +} + +static OP *pp_isa(pTHX) +{ + dSP; + + SV *left, *right; + + right = POPs; + left = TOPs; + + SETs(boolSV(sv_isa_sv(left, right))); + RETURN; +} +#endif + +static int build_try(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) +{ + U32 argi = 0; + + OP *try = args[argi++]->op; + + OP *ret = NULL; + HV *hints = GvHV(PL_hintgv); + + bool require_catch = hints && hv_fetchs(hints, "Syntax::Keyword::Try/require_catch", 0); + bool require_var = hints && hv_fetchs(hints, "Syntax::Keyword::Try/require_var", 0); + + U32 ncatches = args[argi++]->i; + + AV *condcatch = NULL; + OP *catch = NULL; + while(ncatches--) { + bool has_catchvar = args[argi++]->i; + PADOFFSET catchvar = has_catchvar ? args[argi++]->padix : 0; + int catchtype = has_catchvar ? args[argi++]->i : -1; + + bool warned = FALSE; + + OP *condop = NULL; + + switch(catchtype) { + case -1: /* no type */ + break; + + case 0: /* isa */ + { + OP *type = args[argi++]->op; +#ifdef HAVE_OP_ISA + condop = newBINOP(OP_ISA, 0, + newPADxVOP(OP_PADSV, catchvar, 0, 0), type); +#else + /* Allow a bareword on RHS of `isa` */ + if(type->op_type == OP_CONST) + type->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT); + + condop = newBINOP_CUSTOM(&pp_isa, 0, + newPADxVOP(OP_PADSV, catchvar, 0, 0), type); +#endif + break; + } + + case 1: /* =~ */ + { + OP *regexp = args[argi++]->op; + + if(regexp->op_type != OP_MATCH || cPMOPx(regexp)->op_first) + croak("Expected a regexp match"); +#if HAVE_PERL_VERSION(5,22,0) + /* Perl 5.22+ uses op_targ on OP_MATCH directly */ + regexp->op_targ = catchvar; +#else + /* Older perls need a stacked OP_PADSV op */ + cPMOPx(regexp)->op_first = newPADxVOP(OP_PADSV, catchvar, 0, 0); + regexp->op_flags |= OPf_KIDS|OPf_STACKED; +#endif + condop = regexp; + break; + } + + default: + croak("TODO\n"); + } + +#ifdef WARN_EXPERIMENTAL + if(condop && !warned && + (!hints || !hv_fetchs(hints, "Syntax::Keyword::Try/experimental(typed)", 0))) { + warned = true; + Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), + "typed catch syntax is experimental and may be changed or removed without notice"); + } +#endif + + OP *body = args[argi++]->op; + + if(require_var && !has_catchvar) + croak("Expected (VAR) for catch"); + + if(catch) + croak("Already have a default catch {} block"); + + OP *assignop = NULL; + if(catchvar) { + /* my $var = $@ */ + assignop = newBINOP(OP_SASSIGN, 0, + newGVOP(OP_GVSV, 0, PL_errgv), newPADxVOP(OP_PADSV, catchvar, OPf_MOD, OPpLVAL_INTRO)); + } + + if(condop) { + if(!condcatch) + condcatch = newAV(); + + av_push(condcatch, (SV *)op_append_elem(OP_LINESEQ, assignop, condop)); + av_push(condcatch, (SV *)body); + /* catch remains NULL for now */ + } + else if(assignop) { + catch = op_prepend_elem(OP_LINESEQ, + assignop, body); + } + else + catch = body; + } + + if(condcatch) { + I32 i; + + if(!catch) + /* A default fallthrough */ + /* die $@ */ + catch = newLISTOP(OP_DIE, 0, + newOP(OP_PUSHMARK, 0), newGVOP(OP_GVSV, 0, PL_errgv)); + + for(i = AvFILL(condcatch)-1; i >= 0; i -= 2) { + OP *body = (OP *)av_pop(condcatch), + *condop = (OP *)av_pop(condcatch); + + catch = newCONDOP(0, condop, op_scope(body), catch); + } + + SvREFCNT_dec(condcatch); + } + + if(require_catch && !catch) + croak("Expected a catch {} block"); + + bool no_finally = hints && hv_fetchs(hints, "Syntax::Keyword::Try/no_finally", 0); + + U32 has_finally = args[argi++]->i; + CV *finally = has_finally ? args[argi++]->cv : NULL; + + if(no_finally && finally) + croak("finally {} is not permitted here"); + + if(!catch && !finally) { + op_free(try); + croak(no_finally + ? "Expected try {} to be followed by catch {}" + : "Expected try {} to be followed by either catch {} or finally {}"); + } + + ret = try; + + if(catch) { + ret = newENTERTRYCATCHOP(0, try, catch); + } + + /* If there's a finally, make + * $RET = OP_PUSHFINALLY($FINALLY); $RET + */ + if(finally) { + ret = op_prepend_elem(OP_LINESEQ, + newSVOP_CUSTOM(&pp_pushfinally, 0, (SV *)finally), + ret); + } + + ret = op_append_list(OP_LEAVE, + newOP(OP_ENTER, 0), + ret); + + *out = ret; + return KEYWORD_PLUGIN_STMT; +} + +static struct XSParseKeywordHooks hooks_try = { + .permit_hintkey = "Syntax::Keyword::Try/try", + + .pieces = (const struct XSParseKeywordPieceType []){ + XPK_BLOCK, + XPK_REPEATED( + XPK_LITERAL("catch"), + XPK_PREFIXED_BLOCK( + /* optionally ($var), ($var isa Type) or ($var =~ m/.../) */ + XPK_PARENSCOPE_OPT( + XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR), + XPK_CHOICE( + XPK_SEQUENCE(XPK_LITERAL("isa"), XPK_TERMEXPR), + XPK_SEQUENCE(XPK_LITERAL("=~"), XPK_TERMEXPR) + ) + ) + ) + ), + XPK_OPTIONAL( + XPK_LITERAL("finally"), XPK_ANONSUB + ), + {0}, + }, + .build = &build_try, +}; + +MODULE = Syntax::Keyword::Try PACKAGE = Syntax::Keyword::Try + +BOOT: + XopENTRY_set(&xop_catch, xop_name, "catch"); + XopENTRY_set(&xop_catch, xop_desc, + "optionally invoke the catch block if required"); + XopENTRY_set(&xop_catch, xop_class, OA_LOGOP); + Perl_custom_op_register(aTHX_ &pp_catch, &xop_catch); + + XopENTRY_set(&xop_pushfinally, xop_name, "pushfinally"); + XopENTRY_set(&xop_pushfinally, xop_desc, + "arrange for a CV to be invoked at scope exit"); + XopENTRY_set(&xop_pushfinally, xop_class, OA_SVOP); + Perl_custom_op_register(aTHX_ &pp_pushfinally, &xop_pushfinally); +#ifndef HAVE_OP_ISA + XopENTRY_set(&xop_isa, xop_name, "isa"); + XopENTRY_set(&xop_isa, xop_desc, + "check if a value is an object of the given class"); + XopENTRY_set(&xop_isa, xop_class, OA_BINOP); + Perl_custom_op_register(aTHX_ &pp_isa, &xop_isa); +#endif + + boot_xs_parse_keyword(0.06); + + register_xs_parse_keyword("try", &hooks_try, NULL); diff --git a/lib/Syntax/Keyword/Try/Deparse.pm b/lib/Syntax/Keyword/Try/Deparse.pm new file mode 100644 index 0000000..d3daabb --- /dev/null +++ b/lib/Syntax/Keyword/Try/Deparse.pm @@ -0,0 +1,116 @@ +# 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 Syntax::Keyword::Try::Deparse 0.27; + +use v5.14; +use warnings; + +use B qw( opnumber ); + +require B::Deparse; + +use constant { + OP_CUSTOM => opnumber('custom'), + OP_ENTER => opnumber('enter'), + OP_LINESEQ => opnumber('lineseq'), +}; + +=head1 NAME + +C - L support for L + +=head1 DESCRIPTION + +Loading this module will apply some hacks onto L that attempts to +provide deparse support for code which uses the syntax provided by +L. + +=cut + +my $orig_pp_leave; +{ + no warnings 'redefine'; + no strict 'refs'; + $orig_pp_leave = *{"B::Deparse::pp_leave"}{CODE}; + *{"B::Deparse::pp_leave"} = \&pp_leave; +} + +sub pp_leave +{ + my $self = shift; + my ( $op ) = @_; + + my $enter = $op->first; + $enter->type == OP_ENTER or + return $self->$orig_pp_leave( @_ ); + + my $body = $enter->sibling; + my $first = $body->first; + + my $finally = ""; + + if( $body->type == OP_LINESEQ and $first->name eq "pushfinally" ) { + my $finally_cv = $first->sv; + $finally = "\nfinally " . $self->deparse_sub( $finally_cv ) . "\cK"; + + $first = $first->sibling; + $first = $first->sibling while $first and $first->name eq "lineseq"; + + # Jump over a scope op + if( $first->type == 0 ) { + $body = $first; + $first = $first->first; + } + } + + if( $first->type == OP_CUSTOM and $first->name eq "catch" ) { + # This is a try/catch block + shift; + return $self->deparse( $body, @_ ) . $finally; + } + elsif( length $finally ) { + # Body is the remaining siblings. We'll have to do them all together + my $try = B::Deparse::scopeop( 1, $self, $body, 0 ); + + return "try {\n\t$try\n\b}" . $finally; + } + + return $orig_pp_leave->($self, @_); +} + +sub B::Deparse::pp_catch +{ + my $self = shift; + my ( $op ) = @_; + + my $tryop = $op->first; + my $catchop = $op->first->sibling; + + my $try = $self->pp_leave($tryop, 0); + + # skip the OP_SCOPE and dive into the OP_LINESEQ inside + # + # TODO: Try to detect the `catch my $e` variable, though that will be hard + # to dishtinguish from actual code that really does that + my $catch = $self->deparse($catchop->first, 0); + + return "try {\n\t$try\n\b}\ncatch {\n\t$catch\n\b}\cK"; +} + +=head1 TODO + +Correctly handle typed dispatch cases +(C, C) + +=cut + +=head1 AUTHOR + +Paul Evans + +=cut + +0x55AA; diff --git a/t/00use.t b/t/00use.t new file mode 100644 index 0000000..74a7da6 --- /dev/null +++ b/t/00use.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use_ok( "Syntax::Keyword::Try" ); + +done_testing; diff --git a/t/01trycatch.t b/t/01trycatch.t new file mode 100644 index 0000000..1b92efc --- /dev/null +++ b/t/01trycatch.t @@ -0,0 +1,123 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try success +{ + my $s; + try { + $s = 1; + } + catch ($e) { + $s = 2; + } + + is( $s, 1, 'sucessful try{} runs' ); +} + +# try catches +{ + my $s; + ok( eval { + try { + die "oopsie"; + } + catch ($e) { } + + $s = 3; + "ok"; + }, 'try { die } is not fatal' ); + + is( $s, 3, 'code after try{} runs' ); +} + +# exceptions that are false +{ + my $caught; + try { + die FALSE->new; + } + catch ($e) { + $caught++; + } + + ok( $caught, 'catch{} sees a false exception' ); + + { + package FALSE; + use overload 'bool' => sub { 0 }; + sub new { bless [], shift } + } +} + +# catch sees exception +{ + my $caught; + try { + die "oopsie"; + } + catch ($e) { + $caught = $e; + } + + like( $caught, qr/^oopsie at /, 'catch{} sees $@' ); +} + +# catch block executes +{ + my $s; + try { + die "oopsie"; + } + catch ($e) { + $s = 4; + } + + is( $s, 4, 'catch{} of failed try{} runs' ); +} + +# catch can rethrow +{ + my $caught; + ok( !eval { + try { die "oopsie"; } + catch ($e) { $caught = $e; die $e } + }, 'die in catch{} is fatal' ); + my $e = $@; + + like( $e, qr/^oopsie at /, 'exception is thrown' ); + like( $caught, qr/^oopsie at /, 'exception was seen by catch{}' ); +} + +# catch without VAR +{ + try { + die "caught\n"; + } + catch { + my $e = $@; + is( $e, "caught\n", 'exception visible in $@' ); + } +} + +# catch lexical does not retain +{ + my $destroyed; + sub Canary::DESTROY { $destroyed++ } + + try { + die bless [], "Canary"; + } + catch ($e) { + # don't touch $e + } + + ok( $destroyed, 'catch ($var) does not retain value' ); +} + +done_testing; diff --git a/t/02tryfinally.t b/t/02tryfinally.t new file mode 100644 index 0000000..f46aaeb --- /dev/null +++ b/t/02tryfinally.t @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try success +{ + my $s; + try { + $s = 1; + } + finally { + $s = 2; + } + + is( $s, 2, 'sucessful try{} runs finally{}' ); +} + +# try failure +{ + my $s; + my $e; + ok( !eval { + try { + die "oopsie"; + } + finally { + $e = $@; + $s = 3; + } + }, 'failed try{} throws' ); + my $dollarat = $@; + + is( $s, 3, 'failed try{} runs finally{}' ); + like( $e, qr/^oopsie at /, 'finally{} sees $@' ); + like( $dollarat, qr/^oopsie at /, 'try/finally leaves $@ intact' ); +} + +# finally runs on 'return' +{ + my $final; + ( sub { + try { + return; + } + finally { + $final++; + } + } )->(); + + ok( $final, 'finally{} runs after return' ); +} + +# finally runs on 'goto' +{ + my $final; + try { + goto after; + } + finally { + $final++; + } + +after: + ok( $final, 'finally{} runs after goto' ); +} + +# finally runs on 'last' +{ + my $final; + LOOP: { + try { + last LOOP; + } + finally { + $final++; + } + } + + ok( $final, 'finally{} runs after last' ); +} + +done_testing; diff --git a/t/03trycatchfinally.t b/t/03trycatchfinally.t new file mode 100644 index 0000000..71597be --- /dev/null +++ b/t/03trycatchfinally.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try success +{ + my $s; + try { + $s = 1; # overwritten + } + catch ($e) { + die "FAIL"; + } + finally { + $s = 2; + } + + is( $s, 2, 't/c/f runs finally' ); +} + +# try failure +{ + my $s; + try { + die "oopsie"; + } + catch ($e) { + $s = 3; + } + finally { + $s++; + } + + is( $s, 4, 't/c/f runs catch{} and finally{} on failure' ); +} + +done_testing; diff --git a/t/04catch-types.t b/t/04catch-types.t new file mode 100644 index 0000000..14378ce --- /dev/null +++ b/t/04catch-types.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try qw( try :experimental ); + +sub func +{ + my ( $ret, $except ) = @_; + + try { + die $except if $except; + return "ret => $ret"; + } + catch ($e isa X) { + return "X => [@$e]"; + } + catch ($e =~ m/^Cannot /) { + chomp $e; + return "cannot => $e"; + } + catch ($e) { + return "default => $e"; + } +} + +is( func( 123 ), "ret => 123", 'typed catch succeeds' ); + +is( func( 0, "failure\n" ), "default => failure\n", + 'typed catch default case' ); +is( func( 0, bless [45], "X" ), "X => [45]", + 'typed catch isa case' ); +is( func( 0, "Cannot do X\n" ), "cannot => Cannot do X", + 'typed catch regexp case' ); + +sub fallthrough +{ + my ( $except ) = @_; + + try { + die $except; + } + catch ($e isa X) { + return "X => [@$e]"; + } + # no default +} + +is( fallthrough( bless ["OK"], "X" ), "X => [OK]", + 'typed catch not fallthrough' ); +is( eval { fallthrough( "Oopsie\n" ); 1 } ? undef : $@, "Oopsie\n", + 'typed catch fallthrough' ); + +done_testing; diff --git a/t/10snail.t b/t/10snail.t new file mode 100644 index 0000000..9d87842 --- /dev/null +++ b/t/10snail.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try gets @_ +{ + my @args; + ( sub { + try { @args = @_ } + catch ($e) {} + } )->( 1, 2, 3 ); + + is_deeply( \@args, [ 1, 2, 3 ], 'try{} sees surrounding @_' ); +} + +# catch sees @_ +{ + my @args; + ( sub { + try { die "oopsie" } + catch ($e) { @args = @_ } + } )->( 4, 5, 6 ); + + is_deeply( \@args, [ 4, 5, 6 ], 'catch{} sees @_' ); +} + +done_testing; diff --git a/t/11loop.t b/t/11loop.t new file mode 100644 index 0000000..c89315f --- /dev/null +++ b/t/11loop.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try can apply loop controls +{ + my $count = 0; + LOOP: { + try { + $count++; + redo LOOP if $count < 2; + } + catch ($e) { } + } + + is( $count, 2, 'try{redo} works' ); + + $count = 0; + my $after = 0; + + LOOP2: { + try { + last LOOP2; + $after++; # just to put a statement after 'last' + } + catch ($e) { } + $count++; + } + + is( $count, 0, 'try{last} works' ); +} + +# catch can apply loop controls +{ + my $count = 0; + LOOP: { + try { + die "oopsie"; + } + catch ($e) { + $count++; + redo LOOP if $count < 2; + } + } + + is( $count, 2, 'catch{redo} works' ); + + $count = 0; + + LOOP2: { + try { + die "oopsie"; + } + catch ($e) { + last LOOP2; + } + $count++; + } + + is( $count, 0, 'catch{last} works' ); +} + +done_testing; diff --git a/t/12return.t b/t/12return.t new file mode 100644 index 0000000..e14db63 --- /dev/null +++ b/t/12return.t @@ -0,0 +1,110 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# return from try +{ + my $after; + ( sub { + try { return } + catch ($e) {} + $after++; + } )->(); + ok( !$after, 'code after try{return} in void context is not invoked' ); +} + +# return SCALAR from try +{ + is( + scalar ( sub { + try { return "result" } + catch ($e) {} + return "nope"; + } )->(), + "result", + 'return SCALAR in try yields correct value' + ); +} + +# return LIST from try +{ + is_deeply( + [ sub { + try { return qw( A B C ) } catch ($e) {} + }->() ], + [qw( A B C )], + 'return LIST in try yields correct values' + ); +} + +# return from two nested try{}s +{ + my $after; + + is( + ( sub { + try { + try { return "result" } + catch ($e) {} + } + catch ($e) {} + $after++; + return "nope"; + } )->(), + "result", + 'return in try{try{}} leaves containing function' + ); + ok( !$after, 'code after try{try{return}} is not invoked' ); +} + +# return inside eval{} inside try{} +{ + is( + ( sub { + my $two; + try { + my $one = eval { return 1 }; + $two = $one + 1; + } + catch ($e) {} + return $two; + } )->(), + 2, + 'return in eval{} inside try{} behaves as expected' + ); +} + +# return inside try{} inside eval{} +{ + is( + ( sub { + my $ret = eval { + try { return "part"; } + catch ($e) {} + }; + return "($ret)"; + } )->(), + "(part)", + 'return in try{} inside eval{}' + ); +} + +# return from catch +{ + is( + ( sub { + try { die "oopsie" } + catch ($e) { return "result" } + return "nope"; + } )->(), + "result", + 'return in catch leaves containing function' + ); +} + +done_testing; diff --git a/t/13die-in-finally.t b/t/13die-in-finally.t new file mode 100644 index 0000000..6cf46a9 --- /dev/null +++ b/t/13die-in-finally.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# finally does not disturb $@ +{ + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; + + ok( !eval { + try { + die "oopsie"; + } + finally { + die "double oops"; + } + 1; + }, 'die in both try{} and finally{} is still fatal' ); + like( $@, qr/^oopsie at /, 'die in finally{} does not corrupt $@' ); + like( $warnings, qr/double oops at /, 'die in finally{} warns inner exception' ); +} + +done_testing; diff --git a/t/14try-localises.t b/t/14try-localises.t new file mode 100644 index 0000000..765fd7e --- /dev/null +++ b/t/14try-localises.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try/catch localises $@ (RT118415) +{ + eval { die "oopsie" }; + like( $@, qr/^oopsie at /, '$@ before try/catch' ); + + try { die "another failure" } catch ($e) {} + + like( $@, qr/^oopsie at /, '$@ after try/catch' ); +} + +done_testing; diff --git a/t/15context.t b/t/15context.t new file mode 100644 index 0000000..b97f6ad --- /dev/null +++ b/t/15context.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# wantarray inside try +{ + my $context; + sub whatcontext + { + try { + $context = wantarray ? "list" : + defined wantarray ? "scalar" : "void"; + } + catch ($e) { } + } + + whatcontext(); + is($context, "void", 'sub {try} in void'); + + my $scalar = whatcontext(); + is($context, "scalar", 'sub {try} in scalar'); + + my @array = whatcontext(); + is($context, "list", 'sub {try} in list'); +} + +done_testing; diff --git a/t/16final-expr.t b/t/16final-expr.t new file mode 100644 index 0000000..8a63071 --- /dev/null +++ b/t/16final-expr.t @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# try as final expression yields correct value +{ + my $scalar = do { + try { 123 } + catch ($e) { 456 } + }; + is($scalar, 123, 'do { try } in scalar context'); + + my @list = do { + try { 1, 2, 3 } + catch ($e) { 4, 5, 6 } + }; + is_deeply(\@list, [1, 2, 3], 'do { try } in list context'); +} + +# catch as final expression yields correct value +{ + my $scalar = do { + try { die "Oops" } + catch ($e) { 456 } + }; + is($scalar, 456, 'do { try/catch } in scalar context'); + + my @list = do { + try { die "Oops" } + catch ($e) { 4, 5, 6 } + }; + is_deeply(\@list, [4, 5, 6], 'do { try/catch } in list context'); + + $scalar = do { + try { die "Oops" } + catch ($e) { my $x = 123; 456 } + }; + is($scalar, 456, 'do { try/catch } with multiple statements'); +} + +done_testing; diff --git a/t/30compat.t b/t/30compat.t new file mode 100644 index 0000000..d8f1e82 --- /dev/null +++ b/t/30compat.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +# forbidding finally +{ + use Syntax::Keyword::Try '-no_finally'; + + ok( !defined eval <<'EOPERL', + try { 123 } + finally { 456 } +EOPERL + 'try/finally is forbidden' ); + like( $@, qr/^finally \{\} is not permitted here / ); +} + +# require var +{ + use Syntax::Keyword::Try '-require_var'; + + ok( !defined eval <<'EOPERL', + try { 123 } + catch { 456 } +EOPERL + 'try/catch requires var' ); + like( $@, qr/^Expected \(VAR\) for catch / ); +} + +done_testing; diff --git a/t/70deparse.t b/t/70deparse.t new file mode 100644 index 0000000..5fc0ab9 --- /dev/null +++ b/t/70deparse.t @@ -0,0 +1,54 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; +use Syntax::Keyword::Try::Deparse; + +use B::Deparse; +my $deparser = B::Deparse->new(); + +sub is_deparsed +{ + my ( $sub, $exp, $name ) = @_; + + my $got = $deparser->coderef2text( $sub ); + + # Deparsed output is '{ ... }'-wrapped + $got = ( $got =~ m/^{\n(.*)\n}$/s )[0]; + $got =~ s/^ //mg; + + # Deparsed output will have a lot of pragmata and so on + 1 while $got =~ s/^\s*(?:use|no) \w+.*\n//; + $got =~ s/^BEGIN \{\n.*?\n\}\n//s; + + # Trim a trailing linefeed + chomp $got; + + is( $got, $exp, $name ); +} + +is_deparsed + sub { try { ABC() } catch { DEF() } }, + "try {\n ABC();\n}\ncatch {\n DEF();\n}", + 'try/catch'; + +is_deparsed + sub { try { ABC() } catch($e) { DEF() } }, + "try {\n ABC();\n}\ncatch {\n my \$e = \$@;\n DEF();\n}", + 'try/catch(VAR)'; + +is_deparsed + sub { try { ABC() } finally { XYZ() } }, + "try {\n ABC();\n}\nfinally {\n XYZ();\n}", + 'try/finally'; + +is_deparsed + sub { try { ABC() } catch { DEF() } finally { XYZ() } }, + "try {\n ABC();\n}\ncatch {\n DEF();\n}\nfinally {\n XYZ();\n}", + 'try/catch/finally'; + +done_testing; diff --git a/t/80await+SKT.t b/t/80await+SKT.t new file mode 100644 index 0000000..9718cf0 --- /dev/null +++ b/t/80await+SKT.t @@ -0,0 +1,164 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +BEGIN { + plan skip_all => "Future is not available" + unless eval { require Future }; + plan skip_all => "Future::AsyncAwait >= 0.50 is not available" + unless eval { require Future::AsyncAwait; + Future::AsyncAwait->VERSION( '0.50' ) }; + plan skip_all => "Syntax::Keyword::Try >= 0.22 is not available" + unless eval { require Syntax::Keyword::Try; + Syntax::Keyword::Try->VERSION( '0.22' ) }; + + Future::AsyncAwait->import; + Syntax::Keyword::Try->import; + + diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . + "Syntax::Keyword::Try $Syntax::Keyword::Try::VERSION" ); +} + +# await in try/catch +{ + async sub with_trycatch + { + my $f = shift; + + my $ret; + + try { + await $f; + $ret = "result"; + } + catch ($e) { + $ret = "oopsie"; + } + return $ret; + } + + my $f1 = Future->new; + my $fdone = with_trycatch( $f1 ); + + $f1->done; + is( scalar $fdone->get, "result", '$fdone for successful await in try/catch' ); + + my $f2 = Future->new; + my $ffail = with_trycatch( $f2 ); + + $f2->fail( "fail" ); + is( scalar $ffail->get, "oopsie", '$ffail for failed await in try/catch' ); +} + +# await in try/catch with return +{ + my $fellthrough; + + async sub with_trycatch_return + { + my $f = shift; + + try { + await $f; + return "result"; + } + catch ($e) {} + $fellthrough++; + return "fallthrough"; + } + + my $f1 = Future->new; + my $fdone = with_trycatch_return( $f1 ); + + $f1->done; + + is( scalar $fdone->get, "result", '$fdone for successful await in try/catch with return' ); + ok( !$fellthrough, 'fallthrough after try{return} did not happen' ); +} + +# await in try/catch list context (RT134790) +{ + async sub return_list { return ( "first", "second" ); } + + async sub await_return_list + { + try { + return await return_list(); + } + catch ($e) { die $e; } + } + + my ( $r1, $r2 ) = await await_return_list(); + is( $r1, "first", 'first result from try/return list' ); + is( $r2, "second", 'second result from try/return list' ); +} + +# await in try/finally +{ + async sub with_tryfinally + { + my $f = shift; + + my $ret = ""; + + try { + await $f; + $ret .= "T"; + } + finally { + $ret .= "F"; + } + + return $ret; + } + + my $f1 = Future->new; + my $fret = with_tryfinally( $f1 ); + + $f1->done; + + is( scalar $fret->get, "TF", '$fret for await in try/finally' ); +} + +# finally still runs for cancel (RT135351) +{ + my $ok; + my $f1 = Future->new; + my $fret = (async sub { + try { + await $f1; + } + finally { + $ok++; + } + })->(); + + ok( !$ok, 'defer {} not run before ->cancel' ); + + $fret->cancel; + + ok( $ok, 'defer {} was run after ->cancel' ); +} + +# await in toplevel try +{ + try { + is( await Future->done( "success" ), "success", + 'await in toplevel try' ); + } + catch { + fail( 'await in toplevel try' ); + } + + try { + await Future->fail( "failure\n" ); + } + catch ( $e ) { + is( $e, "failure\n", 'await in toplevel try/catch failure' ); + } +} + +done_testing; diff --git a/t/80defer+SKT.t b/t/80defer+SKT.t new file mode 100644 index 0000000..6fc9e36 --- /dev/null +++ b/t/80defer+SKT.t @@ -0,0 +1,64 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +BEGIN { + plan skip_all => "Syntax::Keyword::Defer >= 0.02 is not available" + unless eval { require Syntax::Keyword::Defer; + Syntax::Keyword::Defer->VERSION( '0.02' ) }; + plan skip_all => "Syntax::Keyword::Try >= 0.18 is not available" + unless eval { require Syntax::Keyword::Try; + Syntax::Keyword::Try->VERSION( '0.18' ) }; + + Syntax::Keyword::Defer->import; + Syntax::Keyword::Try->import; + + diag( "Syntax::Keyword::Defer $Syntax::Keyword::Defer::VERSION, " . + "Syntax::Keyword::Try $Syntax::Keyword::Try::VERSION" ); +} + +# defer inside try +{ + my $ok; + try { + defer { $ok .= "2" } + $ok .= "1"; + } + catch ($e) { } + + is( $ok, "12", 'defer inside try' ); +} + +# defer inside catch +{ + my $ok; + try { + die "Oopsie\n"; + } + catch ($e) { + defer { $ok .= "4" } + $ok .= "3"; + } + + is( $ok, "34", 'defer inside catch' ); +} + +# try/catch inside defer +{ + my $ok; + + { + defer { + try { $ok .= "6" } + catch ($e) {} + } + $ok .= "5"; + } + + is( $ok, "56", 'try/catch inside defer' ); +} + +done_testing; diff --git a/t/90rt123547.t b/t/90rt123547.t new file mode 100644 index 0000000..dae78cb --- /dev/null +++ b/t/90rt123547.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +# RT123547 observes that if S:K:T is loaded late after multiple threads +# are actually started, it will crash + +BEGIN { + eval { require threads; threads->import; 1 } or + plan skip_all => "threads are not supported"; +} + +# Start two threads doing the same thing concurrently and hope we get +# to the end +my @threads = map { + threads->create( sub { + my $x; + + # We have to late-load the module and then demonstrate that it works + # Because of late loading we couldn't have written normal code here, so + # we'll string-eval it + eval <<'EOPERL' + use Syntax::Keyword::Try; + + try { + $x = "a"; + die "oops"; + } + catch ($e) { + $x .= "b"; + } + finally { + $x .= "c"; + } + 1; +EOPERL + or die "Failed - $@"; + return $x; + } ); +} 1 .. 2; + +is( $_->join, "abc", 'try/catch/finally correct result' ) for @threads; + +pass "Did not crash"; + +done_testing; diff --git a/t/90rt125971.t b/t/90rt125971.t new file mode 100644 index 0000000..ec09019 --- /dev/null +++ b/t/90rt125971.t @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +use Syntax::Keyword::Try; + +sub inner +{ + my $canary = Canary->new; # if this line is commented, nothing happens + try { + return 123; + } + catch ($e) { + die "Something terrible happened: $e"; + } +} + +sub outer +{ + my @result; + try { + @result = (1, scalar inner()); # scalar or void context is mandatory + 1; # or catch will be triggered + } + catch ($e) { + die "Something terrible happened: $e"; + } + return @result; +} + +is_deeply [ outer() ], [ 1, 123 ], "No extra data in return"; + +done_testing; + +package Canary; +sub new { + bless {}, shift; +} + +sub DESTROY { + my $x; # Destructor MUST be nonempty + $@ = "oops"; # Assigning to $@ is optional +} diff --git a/t/99pod.t b/t/99pod.t new file mode 100644 index 0000000..d1972ce --- /dev/null +++ b/t/99pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok();