Future-AsyncAwait-0.66000755001750001750 014476650556 13523 5ustar00leoleo000000000000Future-AsyncAwait-0.66/.editorconfig000444001750001750 5314476650556 16273 0ustar00leoleo000000000000root = true [*.{pm,pl,t}] indent_size = 3 Future-AsyncAwait-0.66/Build.PL000444001750001750 350514476650556 15157 0ustar00leoleo000000000000use v5; use strict; use warnings; use Config; use Module::Build; use XS::Parse::Keyword::Builder; use XS::Parse::Sublike::Builder; my @extra_compiler_flags = qw( -Ihax ); # MSWin32 needs NO_XSLOCKS to make longjmp work. I have no idea what this is # about, I just stole it from Scope::Escape # https://metacpan.org/source/ZEFRAM/Scope-Escape-0.005/Build.PL#L25 if( $^O eq "MSWin32" ) { push @extra_compiler_flags, "-DNO_XSLOCKS=1"; } # Thready perls before 5.22 are known to massively fail. For now lets just # declare such perls unsupported # https://rt.cpan.org/Ticket/Display.html?id=124351 die "OS unsupported - threaded perl earlier than 5.22 (RT124351)" if $] < 5.022 and ( $Config{usethreads} || "" ) eq "define"; my $build = Module::Build->new( module_name => 'Future::AsyncAwait', requires => { 'Future' => '0.50', 'perl' => '5.016', # PL_keyword_plugin, pad_new(), CvDYNFILE, many tests fail on 5.14 'XS::Parse::Keyword' => '0.13', 'XS::Parse::Sublike' => '0.14', }, test_requires => { 'Test::Future::Deferred' => 0, 'Test2::V0' => '0.000148', }, configure_requires => { 'Module::Build' => '0.4004', # test_requires 'XS::Parse::Keyword::Builder' => '0.13', 'XS::Parse::Sublike::Builder' => '0.14', }, license => 'perl', create_license => 1, create_readme => 1, meta_merge => { resources => { x_IRC => "irc://irc.perl.org/#io-async", }, }, extra_compiler_flags => \@extra_compiler_flags, ); XS::Parse::Keyword::Builder->extend_module_build( $build ); XS::Parse::Sublike::Builder->extend_module_build( $build ); if( eval { require Devel::MAT::Dumper::Helper and Devel::MAT::Dumper::Helper->VERSION( '0.44' ) } ) { Devel::MAT::Dumper::Helper->extend_module_build( $build ); } $build->create_build_script; Future-AsyncAwait-0.66/Changes000444001750001750 4452314476650556 15203 0ustar00leoleo000000000000Revision history for Future-AsyncAwait 0.66 2023-09-08 [CHANGES] * Add a unit test to check that `async method` works on core perl class syntax * Remember to implement `sub unimport` so that `no Future::AsyncAwait` works [BUGFIXES] * Provide a permit_hintkey to keep XPS happy 0.65 2023-03-17 [CHANGES] * More specific unit-testing of the croak location when testing `AWAIT_GET` (related to RT145249) * Swap all unit tests from `Test::More` to `Test2::V0` * Avoids test_requires on `Test::Refcount` or `Test::Fatal` [BUGFIXES] * A more robust handling of defav during suspend/resume to try not to upset `perl -d` (RT146246) 0.64 2023-02-14 [CHANGES] * Define ABI version 2, which adds pre_suspend and post_resume phase hooks 0.63 2023-02-12 [CHANGES] * Added various bits of API to extension modules using modhookdata more flexibly, including by pre-allocation before the first `await` * Legacy hook API now prints warnings about its deprecation and impending removal [BUGFIXES] * Bleadperl no longer supports `GIMME`, in any case should use `GIMME_V` * Fix memory leak around pre-allocated cancel AV 0.62 2022-12-20 [BUGFIXES] * Save/restore the value of the @_ array; does not work on perls before 5.24 for reasons unknown (RT130683) * Updated hax/ files to avoid a build warning on current bleadperl 0.61 2022-11-21 [BUGFIXES] * Fix for some C compilers which get upset about variable declarations having goto labels 0.60 2022-11-21 [CHANGES] * Added entirely new extension API based on structs of hook functions registered with the module; similar to Object::Pad and XS::Parse::* * Provide Future::AsyncAwait::ExtensionBuilder in a similar fashion to above * Added some more internal assert() and TRACEPRINT calls for debugging [BUGFIXES] * Don't crash if an async sub's returning future is abandoned outside of an await state 0.59 2022-09-23 [BUGFIXES] * Fix broken Future->get method resolution on recent Future + Future::XS experiments * Fix hax/docatch.c.inc for "NULL OP IN RUN" messages * Make t/31destroy.t less fragile in the case of non-HASH Future instances * Back-compat to perl 5.16 by passing `flags` arg to `cv_copy_flags` (RT143742) 0.58 2022-04-29 [BUGFIXES] * Fix memory leak with long-running futures and on_cancel (RT142222) * Copy SVs with SvPADTMP in case of running code, or folded constants that erroneously end up with that flag anyway (RT142468) 0.57 2022-03-16 [CHANGES] * Updates for Devel::MAT::Dumper v0.44 * Updates to bundled hax/ files 0.56 2022-01-26 [CHANGES] * Updated Awaitable API definition for AWAIT_ON_CANCEL * Actually use AWAIT_ON_CANCEL properly (RT137723) * Document the interaction of `multi async sub` 0.55 2021-12-16 [CHANGES] * Updated for XS::Parse::Keyword 0.15 * Hoist an OP_ARGCHECK to outside the ENTERTRY block if present, so that signature validation happens synchronously * Support and unit-test Syntax::Keyword::MultiSub * No longer set `-std=c89` compile flag now that core perl requires C99 anyway 0.54 2021-10-26 [CHANGES] * Add unit-test for await from within perl 5.35.5's multi-variable `for_list` feature * Add cross-module test for compatibility with Syntax::Keyword::Match [BUGFIXES] * Handle `state` vars correctly (RT139821) 0.53 2021-08-26 [CHANGES] * Updated for XS::Parse::Keyword 0.13 0.52 2021-07-13 [BUGFIXES] * Account for changed error message from XS::Parse::Keyword 0.09 (RT137589) 0.51 2021-05-31 [CHANGES] * Updates for XS::Parse::Keyword 0.05 * Removed unused hax/* files 0.50 2021-04-30 [CHANGES] * Rewrite of parser logic to use XS::Parse::Keyword instead of lowlevel code on PL_keyword_parser directly * Attempt to provide a name for the local'ized GV that cannot be handled (thanks fgasper) * Attempt to provide a name for SAVEt_* constants that cannot be handled * Added a shouty AWAIT_WAIT method to implement toplevel `await` (RT134671) * Docs update - remark that Rust and C++20 have async/await too (RT135356) [BUGFIXES] * Invoke defer {} and finally {} blocks on cancellation (RT135351) 0.49 2021-02-24 [BUGFIXES] * Handle the CXp_TRY and real try/catch syntax added in perl 5.33.7 (RT134414) 0.48 2021-02-02 [CHANGES] * Explicitly document that `async sub` works on anon subs too * Update to latest hax/ files [BUGFIXES] * t/80await+try.t requires Syntax::Keyword::Try version >= 0.18 (RT134250) 0.47 2020-11-29 [CHANGES] * Allow `await` expressions at toplevel of main script, for consistency of examples, unit tests, etc... (RT129306) 0.46 2020-11-09 [CHANGES] * Provide future_asyncawait_on_activate() in AsyncAwait.h * Adjusted docs around new `AWAIT_CHAIN_CANCEL` method * Depend on Future 0.43 for Awaitable role named methods, rather than monkey-patching older versions 0.45 2020-10-22 [CHANGES] * Have Test::Future::AsyncAwait::Awaitable check for the suggested new `AWAIT_CHAIN_CANCEL` method [BUGFIXES] * Avoid refcounting bug when cancelling a suspended SAVEt_SPTR (RT133564) * Turn on SvPADMY on precancel AV to keep -DDEBUGGING perl happy (RT133517) 0.44 2020-10-09 [CHANGES] * Added initial attempt at `CANCEL` blocks for handling Future cancellation - experimental * Announce upcoming API method rename of `AWAIT_ON_CANCEL` to `AWAIT_CHAIN_CANCEL` 0.43 2020-07-06 [CHANGES] * Added explicit use VERSION declarations to every perl file [BUGFIXES] * Don't segfault when awaiting in closures that capture outer 'our' variables (RT132945) 0.42 2020-06-29 [BUGFIXES] * Fixes for assert failures on -DDEBUGGING perls: + Workarounds for perl versions prior to 5.22 that get upset about new*OP() being invoked with OP_CUSTOM + Remember to set SVs_PADMY flag on newly-generated pad slot SVs during suspend * Don't leak SVs when cleaning up SAVEt_FREESV during cancellation 0.41 2020-06-20 [CHANGES] * Updates for XS::Parse::Sublike 0.10 [BUGFIXES] * Fix Build.PL declaration on XS::Parse::Sublike that it needs to be configure_requires 0.40 2020-04-15 [CHANGES] * Support a limited form of SAVEt_SPTR when the var is within the current pad; this supports SAVESPTR(PAD_SVl(padix)) as may be used by Object::Pad et.al. 0.39 2020-03-27 [CHANGES] * Updated for XS::Parse::Sublike 0.06 API 0.38 2020-03-24 [CHANGES] * Use XS::Parse::Sublike for `async sub` parsing. This makes it possible to coöperate with other sub-like keyword modules * Add cross-module test sthat module works correctly with Object::Pad, and additionally Syntax::Keyword::Dynamically as well 0.37 2020-03-10 [CHANGES] * Minor reärrangement of internal stages to closer match core's sub parser and allow more generic hooking in future [BUGFIXES] * Don't allow a space between attr name and optional parenthesized argument (RT131571) 0.36 2020-01-16 [CHANGES] * Add an optional 'force' callback to test_awaitable() [BUGFIXES] * Fix more segfault cases during compile failures (RT129987, RT131487) 0.35 2020-01-07 [CHANGES] * Support lexical scopes declaring a different class of future * Document the required API for awaitable objects * Provide an API conformance test for implementors of alternative future classes [BUGFIXES] * Provide scalar context to controlling expression of `await` 0.34 2019-12-01 01:45:23 [CHANGES] * Various internal changes to neaten up the hax/ directory of C source files, letting them be more shareable with other XS dists [BUGFIXES] * Fix (some of the cases of) RT129987 * Only fetch CX_CUR() after the future_done_from_stack() call (RT131118) 0.33 2019-09-08 05:16:05 [BUGFIXES] * Remember to SPAGAIN after future_done_from_stack() in case the stack array was moved (RT130464) 0.32 2019-09-03 17:00:35 [CHANGES] * Define a super-experimental C-level API for other modules to hook parts of the suspend/resume lifecycle to provide extension behaviour. [BUGFIXES] * Actually use perl's own `wrap_keyword_plugin()` * Avoid compiler warning about int/IV mismatch in printf (RT130285) * Use warn_sv() to avoid compiler wraning about formatless warn() on a plain PV (RT130285) * Don't segfault on parse errors from parse_block() (RT130417) 0.31 2019-07-25 15:09:04 [CHANGES] * Use `parse_subsignature()` on bleadperl and backport it to perl 5.26, allowing parsing of subroutine signatures (RT123465) 0.30 2019-07-05 16:09:02 [CHANGES] * Parse attribute lists on `async sub`s (RT129985) 0.29 2019-06-26 20:23:12 [CHANGES] * Further annotations in Devel::MAT::Dumper helper about loop state [BUGFIXES] * Fix various memory leaks of abandoned `async sub`s (RT129836) 0.28 2019-06-17 17:06:18 [BUGFIXES] * Fix localisation of hints hash at compiletime so nested `async sub` works correctly (RT129836) 0.27 2019-06-04 20:48:42 [CHANGES] * Detect certain forbidden constructs at compile-time; await inside: + non-lexical foreach + map and grep (RT129748) + string-eval (RT126036) [BUGFIXES] * Preserve regexp context across await boundary (RT129321) 0.26 2019-04-27 12:41:11 [BUGFIXES] * Further fixes for foreach(LIST) handling (RT129319) * Handle SAVEt_FREEPV (RT129320) * Cleanup itervar and SAVEt_PADSV_AND_MORTALIZE of abandoned futures (RT129320) * Ensure body of async sub starts with OP_NEXSTATE so as not to upset Devel::Cover (thanks ilmari) (RT128309) 0.25 2019-04-24 15:46:15 [BUGFIXES] * Print a warning but don't panic on resume with lost returning future (RT129303) 0.24 2019-04-18 23:47:56 [CHANGES] * Stop `async sub`s on ->cancel (RT129202) * Propagate ->cancel requests back to awaiting future, though at present only on perl 5.24+ (RT129202) * Added more internal consistency checks and `panic()` assertions [BUGFIXES] * Further fixes for broken behaviour of `foreach(LIST)` (RT129215) * Fix Devel::MAT::Dumper helper for expired but unreclaimed magic 0.23 2019-04-16 01:08:34 [BUGFIXES] * Many improvements to mortals handling, including workarounds for lack of cx->old_tmpsfloor on perls before 5.24 (RT128619) 0.22 2019-04-02 00:12:47 [CHANGES] * More detailed annotations in Devel::MAT::Dumper helper [BUGFIXES] * Partial attempt at freeing things when dropping a pending await future (RT128620) * Fix for labeled loop controls (RT128205) 0.21 2019-02-02 17:19:35 [BUGFIXES] * Fix more memory leaks - simple test case now executes cleanly (RT128222) 0.20 2019-01-16 22:34:20 [BUGFIXES] * Ensure mortal SVs aren't reclaimed prematurely during suspend/resume * Fix several memory leaks. Some still remain but overall the situation is much improved (RT128222) 0.19 2019-01-08 23:49:03 [BUGFIXES] * Replace stolen array or hash pad lexicals with newAV() / newHV() to maintain the expected SvTYPE() invariants (RT128176) 0.18 2019-01-05 20:08:38 [CHANGES] * Declare threaded perls before version 5.22 as unsupported. The bug remains open but for now I'm disinclined to look into it. (RT124351) [BUGFIXES] * Don't panic about blk_eval.old_eval_root or .cur_text fields, as it seems we can safely ignore those (RT126036) 0.17 2019-01-04 18:45:22 [BUGFIXES] * Perl 5.26 and above still needs SvREFCNT_inc() on the state array in CXt_LOOP_ARR (RT124353) * Better fix for scopestack name tracking under -DDEBUGGING (RT128164) * Set -DNO_XSLOCKS in order to get working JMPENV on MSWin32 (RT128163) 0.16 2019-01-03 22:09:28 [CHANGES] * Use ENTER_with_name/LEAVE_with_name variants for easier debug (thanks ilmari) * Don't clone the CVf_CVGV_RC flag * Unit-test that async/await also behaves fine through nested named method calls * Unit-test die after single await() [BUGFIXES] * Avoid call to non-public unshare_hek() function (RT125613) * Remember to wrap pp_await in docatch() if CATCH_GET is true. Fixes many failing test cases (double-nested await, RT126037, RT123062) 0.15 2018-01-24 04:12:04 [CHANGES] * Support older perls back to 5.16 (continues work on RT122252). Just 5.14 remains unsupported now * Neater implementation which avoids hacky workarounds from abusing `cv_clone()` [BUGFIXES] * Avoid using anonymous union in struct SuspendedFrame (thanks ilmari) (RT124171) 0.14 2018-01-22 04:42:02 [CHANGES] * Document and test that 'await' works from inside 'do {}' * Test that two nested 'async sub's can await nicely [BUGFIXES] * Fix for 'await' twice inside the same 'foreach' loop (RT124144) * Fix handling of ITERVAR save/restore on perl 5.24+ * Use correct printf format for IVs when debug printing * Ensure that captured lexicals from now-dead scopes remain working 0.13 2018-01-18 15:52:03 [CHANGES] * Support older perls back to 5.18 (continues work on RT122252) [BUGFIXES] * Ensure that 'async sub' called in list context doesn't leak its input arguments as well as Future result 0.12 2018-01-15 19:02:42 [CHANGES] * Support older perls back as far as 5.20 and 5.22 (partly solves RT122252) * Link to TPCiA talk recording on youtube 0.11 2018-01-07 16:35:25 [BUGFIXES] * Fixes for markstack restoration calculation * Don't save/restore PAD slots relating to outer captures or protosubs (RT124026) 0.10 2017-08-13 23:25:33 [BUGFIXES] * Implement enough of SAVEt_DESTRUCTOR_X to make try/finally work * Fix the remaining integration tests with Syntax::Keyword::Try now latest version (0.07) works correctly 0.09 2017-08-13 17:44:48 [CHANGES] * Link to TPCiA talk slides * Forbid the use of foreach loops on non-lexicals as that has semantic problems due to the implied 'local' * Unit-test that plain 'eval{}' works as expected * Allow specifically the use of 'local $@' to support common patterns around 'eval{}' * Unit-test that try/catch from Syntax::Keyword::Try works [BUGFIXES] * Save cx->blk_gimme on CXt_LOOP_* contexts (thanks rurban) (RT122673) 0.08 2017/08/10 16:48:52 [CHANGES] * Handle the other CXt_LOOP_* context types, making foreach() loops work 0.07 2017/07/11 23:26:48 [CHANGES] * Forbid the use of 'await' outside of 'async sub' * Handle CXt_BLOCK contexts * Handle SAVEt_CLEARSV and SAVEt_CLEARPADRANGE savestack entries * Further documentation rework [BUGFIXES] * Fix off-by-one error on reading the savestack, resulting in a number of false-"TODO" failures being fixed * Fix parser logic for parenthesized 'await( ... )' expressions 0.06 2017/06/29 17:43:19 [CHANGES] * Support suspend/resume within while loops and plain loop blocks * Import the syntax keywords by default, rather than having to request them as an import symbol * Added some initial documentation to explain the new syntax [BUGFIXES] * Declare (for now) dependency on perl 5.24 to prevent older versions from attempting it and failing. We hope to support older versions back to 5.14 in due course. 0.05 2017/06/27 15:20:54 [BUGFIXES] * Fix await op so it can await multiple times within the same sub 0.04 2017/06/06 18:42:15 [CHANGES] * Suspend and resume the PAD around an await so lexical variables are preserved * Ensure that anon async subs can suspend/resume - see also https://rt.perl.org/Public/Bug/Display.html?id=131519 [BUGFIXES] * Ensure MARK stack doesn't upset debugperl 0.03 2017/05/08 21:33:46 [CHANGES] * Handle the value and mark stacks around suspend/await, allowing some stack temporaries to be preserved * Avoid naming internal functions "Perl_..." [BUGFIXES] * Ensure that die after await is still caught * Avoid C++-style comments and C99-style for() loop variable declarations (RT121569) 0.02 2017/05/08 16:55:38 [CHANGES] * Initial tiny implementation of actual suspend/resume on 'await' Future-AsyncAwait-0.66/LICENSE000444001750001750 4375514476650556 14723 0ustar00leoleo000000000000This software is copyright (c) 2023 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) 2023 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) 2023 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 Future-AsyncAwait-0.66/MANIFEST000444001750001750 265714476650556 15023 0ustar00leoleo000000000000.editorconfig Build.PL Changes hax/cv_copy_flags.c.inc hax/cx_pushblock.c.inc hax/cx_pusheval.c.inc hax/docatch.c.inc hax/newOP_CUSTOM.c.inc hax/perl-additions.c.inc hax/perl-backcompat.c.inc hax/README hax/save_clearpadrange.c.inc lib/Future/AsyncAwait.h lib/Future/AsyncAwait.pm lib/Future/AsyncAwait.xs lib/Future/AsyncAwait/Awaitable.pm lib/Future/AsyncAwait/ExtensionBuilder.pm lib/Future/AsyncAwait/ExtensionBuilder_data.pm.PL lib/Test/Future/AsyncAwait/Awaitable.pm LICENSE MANIFEST This list of files META.json META.yml README t/00use.t t/01async-immediate.t t/02await-immediate.t t/03await.t t/04await-toplevel.t t/05await-expr.t t/06await-nested.t t/07await-label.t t/08await-cancel.t t/09await-cancel-block.t t/10pad.t t/11contexts.t t/12closure.t t/13regexp.t t/14packagevar.t t/15local-errsv.t t/16state.t t/17snail.t t/20context-block.t t/21context-while.t t/22context-foreach.t t/23context-map.t t/24context-foreach-list.t t/30stringeval.t t/31destroy.t t/32compile-errors.t t/40croak.t t/41end.t t/42unresolved.t t/43failure.t t/44sub-attrs.t t/45sub-signatures.t t/50future-subclass.t t/51awaitable-role.t t/52awaitable-future.t t/70await+feature-class.t t/70await+feature-try.t t/80async-method.t t/80async-multi-sub.t t/80await+defer.t t/80await+dynamically.t t/80await+matchcase.t t/80await+SKT.t t/81async-method+dynamically.t t/81memory-growth.t t/82devel-mat-dumper-helper.t t/90rt128176.t t/90rt129836.t t/90rt142468.t t/99pod.t Future-AsyncAwait-0.66/META.json000444001750001750 354114476650556 15304 0ustar00leoleo000000000000{ "abstract" : "deferred subroutine syntax for futures", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Future-AsyncAwait", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.4004", "XS::Parse::Keyword::Builder" : "0.13", "XS::Parse::Sublike::Builder" : "0.14" } }, "runtime" : { "requires" : { "Future" : "0.50", "XS::Parse::Keyword" : "0.13", "XS::Parse::Sublike" : "0.14", "perl" : "5.016" } }, "test" : { "requires" : { "Test2::V0" : "0.000148", "Test::Future::Deferred" : "0" } } }, "provides" : { "Future::AsyncAwait" : { "file" : "lib/Future/AsyncAwait.pm", "version" : "0.66" }, "Future::AsyncAwait::Awaitable" : { "file" : "lib/Future/AsyncAwait/Awaitable.pm", "version" : "0.66" }, "Future::AsyncAwait::ExtensionBuilder" : { "file" : "lib/Future/AsyncAwait/ExtensionBuilder.pm", "version" : "0.66" }, "Test::Future::AsyncAwait::Awaitable" : { "file" : "lib/Test/Future/AsyncAwait/Awaitable.pm", "version" : "0.66" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "x_IRC" : "irc://irc.perl.org/#io-async" }, "version" : "0.66", "x_serialization_backend" : "JSON::PP version 4.07" } Future-AsyncAwait-0.66/META.yml000444001750001750 231014476650556 15125 0ustar00leoleo000000000000--- abstract: 'deferred subroutine syntax for futures' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test2::V0: '0.000148' Test::Future::Deferred: '0' configure_requires: Module::Build: '0.4004' XS::Parse::Keyword::Builder: '0.13' XS::Parse::Sublike::Builder: '0.14' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Future-AsyncAwait provides: Future::AsyncAwait: file: lib/Future/AsyncAwait.pm version: '0.66' Future::AsyncAwait::Awaitable: file: lib/Future/AsyncAwait/Awaitable.pm version: '0.66' Future::AsyncAwait::ExtensionBuilder: file: lib/Future/AsyncAwait/ExtensionBuilder.pm version: '0.66' Test::Future::AsyncAwait::Awaitable: file: lib/Test/Future/AsyncAwait/Awaitable.pm version: '0.66' requires: Future: '0.50' XS::Parse::Keyword: '0.13' XS::Parse::Sublike: '0.14' perl: '5.016' resources: IRC: irc://irc.perl.org/#io-async license: http://dev.perl.org/licenses/ version: '0.66' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Future-AsyncAwait-0.66/README000444001750001750 4344214476650556 14567 0ustar00leoleo000000000000NAME Future::AsyncAwait - deferred subroutine syntax for futures SYNOPSIS use v5.14; use Future::AsyncAwait; async sub do_a_thing { my $first = await do_first_thing(); my $second = await do_second_thing(); return combine_things( $first, $second ); } do_a_thing()->get; DESCRIPTION This module provides syntax for deferring and resuming subroutines while waiting for Futures to complete. This syntax aims to make code that performs asynchronous operations using futures look neater and more expressive than simply using then chaining and other techniques on the futures themselves. It is also a similar syntax used by a number of other languages; notably C# 5, EcmaScript 6, Python 3, Dart, Rust, C++20. This module is still under active development. While it now seems relatively stable enough for most use-cases and has received a lot of "battle-testing" in a wide variety of scenarios, there may still be the occasional case of memory leak left in it, especially if still-pending futures are abandoned. The new syntax takes the form of two new keywords, async and await. async The async keyword should appear just before the sub keyword that declares a new function. When present, this marks that the function performs its work in a potentially asynchronous fashion. This has two effects: it permits the body of the function to use the await expression, and it wraps the return value of the function in a Future instance. async sub myfunc { return 123; } my $f = myfunc(); my $result = $f->get; As well as named function declarations it is also supported on anonymous function expressions. my $code = async sub { return 456 }; my $f = $code->(); my $result = $f->get; This async-declared function always returns a Future instance when invoked. The returned future instance will eventually complete when the function returns, either by the return keyword or by falling off the end; the result of the future will be the return value from the function's code. Alternatively, if the function body throws an exception, this will cause the returned future to fail. If the final expression in the body of the function returns a Future, don't forget to await it rather than simply returning it as it is, or else this return value will become double-wrapped - almost certainly not what you wanted. async sub otherfunc { ... } async sub myfunc { ... return await otherfunc(); } await The await keyword forms an expression which takes a Future instance as an operand and yields the eventual result of it. Superficially it can be thought of similar to invoking the get method on the future. my $result = await $f; my $result = $f->get; However, the key difference (and indeed the entire reason for being a new syntax keyword) is the behaviour when the future is still pending and is not yet complete. Whereas the simple get method would block until the future is complete, the await keyword causes its entire containing function to become suspended, making it return a new (pending) future instance. It waits in this state until the future it was waiting on completes, at which point it wakes up and resumes execution from the point of the await expression. When the now-resumed function eventually finishes (either by returning a value or throwing an exception), this value is set as the result of the future it had returned earlier. await provides scalar context to its controlling expression. async sub func { # this function is invoked in scalar context } await func(); Because the await keyword may cause its containing function to suspend early, returning a pending future instance, it is only allowed inside async-marked subs. The converse is not true; just because a function is marked as async does not require it to make use of the await expression. It is still useful to turn the result of that function into a future, entirely without awaiting on any itself. Any function that doesn't actually await anything, and just returns immediate futures can be neatened by this module too. Instead of writing sub imm { ... return Future->done( @result ); } you can now simply write async sub imm { ... return @result; } with the added side-benefit that any exceptions thrown by the elided code will be turned into an immediate-failed Future rather than making the call itself propagate the exception, which is usually what you wanted when dealing with futures. await (toplevel) Since version 0.47. An await expression is also permitted directly in the main script at toplevel, outside of async sub. This is implemented by simply invoking the get method on the future value. Thus, the following two lines are directly equivalent: await afunc(); afunc()->get; This is provided as a syntax convenience for unit tests, toplevel scripts, and so on. It allows code to be written in a style that can be easily moved into an async sub, and avoids encouraging "bad habits" of invoking the get method directly. CANCEL Experimental. Since version 0.44. The CANCEL keyword declares a block of code which will be run in the event that the future returned by the async sub is cancelled. async sub f { CANCEL { warn "This task was cancelled"; } await ... } f()->cancel; A CANCEL block is a self-contained syntax element, similar to perl constructions like BEGIN, and does not need a terminating semicolon. When a CANCEL block is encountered during execution of the async sub, the code in its block is stored for the case that the returned future is cancelled. Each will take effect as it is executed, possibly multiple times if it appears inside a loop, or not at all if it appears conditionally in a branch that was not executed. async sub g { if(0) { CANCEL { warn "This does not happen"; } } foreach my $x ( 1..3 ) { CANCEL { warn "This happens for x=$x"; } } await ... } g()->cancel; CANCEL blocks are only invoked if a still-pending future is cancelled. They are discarded without being executed if the function finishes; either successfully or if it throws an exception. 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 Future::AsyncAwait qw( :experimental(cancel) ); use Future::AsyncAwait qw( :experimental ); # all of the above SUPPORTED USES Most cases involving awaiting on still-pending futures should work fine: async sub foo { my ( $f ) = @_; BEFORE(); await $f; AFTER(); } async sub bar { my ( $f ) = @_; return 1 + await( $f ) + 3; } async sub splot { while( COND ) { await func(); } } async sub wibble { if( COND ) { await func(); } } async sub wobble { foreach my $var ( THINGs ) { await func(); } } async sub wubble { # on perl 5.35.5 and above foreach my ($k, $v) ( KVTHINGs ) { await func(); } } async sub quux { my $x = do { await func(); }; } async sub splat { eval { await func(); }; } Plain lexical variables are preserved across an await deferral: async sub quux { my $message = "Hello, world\n"; await func(); print $message; } On perl versions 5.26 and later async sub syntax supports the signatures feature if it is enabled: use v5.26; use feature 'signatures'; async sub quart($x, $y) { ... } Since version 0.55 any exceptions thrown by signature validation (because of too few or too many arguments being passed) are thrown synchronously, and do not result in a failed Future instance. Cancellation Cancelled futures cause a suspended async sub to simply stop running. async sub fizz { await func(); say "This is never reached"; } my $f = fizz(); $f->cancel; Cancellation requests can propagate backwards into the future the async sub is currently waiting on. async sub floof { ... await $f1; } my $f2 = floof(); $f2->cancel; # $f1 will be cancelled too This behaviour is still more experimental than the rest of the logic. The following should be noted: * Cancellation propagation is only implemented on Perl version 5.24 and above. An async sub in an earlier perl version will still stop executing if cancelled, but will not propagate the request backwards into the future that the async sub is currently waiting on. See "TODO". SUBCLASSING Future By default when an async sub returns a result or fails immediately before awaiting, it will return a new completed instance of the Future class. In order to allow code that wishes to use a different class to represent futures the module import method can be passed the name of a class to use instead. use Future::AsyncAwait future_class => "Subclass::Of::Future"; async sub func { ... } This has the usual lexically-scoped effect, applying only to async subs defined within the block; others are unaffected. use Future::AsyncAwait; { use Future::AsyncAwait future_class => "Different::Future"; async sub x { ... } } async sub y { ... } # returns a regular Future This will only affect immediate results. If the await keyword has to suspend the function and create a new pending future, it will do this by using the prototype constructor on the future it itself is waiting on, and the usual subclass-respecting semantics of "new" in Future will remain in effect there. As such it is not usually necessary to use this feature just for wrapping event system modules or other similar situations. Such an alternative subclass should implement the API documented by Future::AsyncAwait::Awaitable. WITH OTHER MODULES Syntax::Keyword::Try 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"; } } As of Future::AsyncAwait version 0.50, finally blocks are invoked even during cancellation. Syntax::Keyword::Dynamically As of Future::AsyncAwait version 0.32, cross-module integration tests assert that the dynamically correctly works across an await boundary. use Future::AsyncAwait; use Syntax::Keyword::Dynamically; our $var; async sub trial { dynamically $var = "value"; await func(); say "Var is still $var"; } Syntax::Keyword::Defer As of Future::AsyncAwait version 0.50, defer blocks are invoked even during cancellation. use Future::AsyncAwait; use Syntax::Keyword::Defer; async sub perhaps { defer { say "Cleaning up now" } await $f1; } my $fouter = perhaps(); $fouter->cancel; Object::Pad As of Future::AsyncAwait version 0.38 and Object::Pad version 0.15, both modules now use XS::Parse::Sublike to parse blocks of code. Because of this the two modules can operate together and allow class methods to be written as async subs which await expressions: use Future::AsyncAwait; use Object::Pad; class Example { async method perform($block) { say "$self is performing code"; await $block->(); say "code finished"; } } Syntax::Keyword::MultiSub As of Future::AsyncAwait version 0.55 and Syntax::Keyword::MultiSub version 0.02 a cross-module integration test asserts that the multi modifier can be applied to async sub. use Future::AsyncAwait; use Syntax::Keyword::MultiSub; async multi sub f () { return "nothing"; } async multi sub f ($key) { return await get_thing($key); } SEE ALSO * "Awaiting The Future" - TPC in Amsterdam 2017 https://www.youtube.com/watch?v=Xf7rStpNaT0 (slides) TODO * Suspend and resume with some consideration for the savestack; i.e. the area used to implement local and similar. While in general local support has awkward questions about semantics, there are certain situations and cases where internally-implied localisation of variables would still be useful and can be supported without the semantic ambiguities of generic local. our $DEBUG = 0; async sub quark { local $DEBUG = 1; await func(); } Since foreach loops on non-lexical iterator variables (usually the $_ global variable) effectively imply a local-like behaviour, these are also disallowed. async sub splurt { foreach ( LIST ) { await ... } } Some notes on what makes the problem hard can be found at https://rt.cpan.org/Ticket/Display.html?id=122793 * Currently this module requires perl version 5.16 or later. Additionally, threaded builds of perl earlier than 5.22 are not supported. https://rt.cpan.org/Ticket/Display.html?id=122252 https://rt.cpan.org/Ticket/Display.html?id=124351 * Implement cancel back-propagation for Perl versions earlier than 5.24. Currently this does not work due to some as-yet-unknown effects that installing the back-propagation has, causing future instances to be reclaimed too early. https://rt.cpan.org/Ticket/Display.html?id=129202 KNOWN BUGS This is not a complete list of all known issues, but rather a summary of the most notable ones that currently prevent the module from working correctly in a variety of situations. For a complete list of known bugs, see the RT queue at https://rt.cpan.org/Dist/Display.html?Name=Future-AsyncAwait. * await inside map or grep blocks does not work. This is due to the difficulty of detecting the map or grep context from internal perl state at suspend time, sufficient to be able to restore it again when resuming. https://rt.cpan.org/Ticket/Display.html?id=129748 As a workaround, consider converting a map expression to the equivalent form using push onto an accumulator array with a foreach loop: my @results = map { await func($_) } ITEMS; becomes my @results; foreach my $item ( ITEMS ) { push @results, await func($item); } with a similar transformation for grep expressions. Alternatively, consider using the fmap* family of functions from Future::Utils to provide a concurrent version of the same code, which can keep multiple items running concurrently: use Future::Utils qw( fmap ); my @results = await fmap { func( shift ) } foreach => [ ITEMS ], concurrent => 5; * The default arguments array (@_) is not saved and restored by an await call on perl versions before v5.24. On such older perls, the value seen in the @_ array after an await will not be the same as it was before. https://rt.cpan.org/Ticket/Display.html?id=130683 As a workaround, make sure to unpack the values out of it into regular lexical variables early on, before the the first await. The values of these lexicals will be saved and restored as normal. async sub f { my ($vars, $go, @here) = @_; # do not make further use of @_ afterwards await thing(); # $vars, $go, @here are all fine for use } ACKNOWLEDGEMENTS With thanks to Zefram, ilmari and others from irc.perl.org/#p5p for assisting with trickier bits of XS logic. Thanks to genio for project management and actually reminding me to write some code. Thanks to The Perl Foundation for sponsoring me to continue working on the implementation. AUTHOR Paul Evans Future-AsyncAwait-0.66/hax000755001750001750 014476650556 14303 5ustar00leoleo000000000000Future-AsyncAwait-0.66/hax/README000444001750001750 71214476650556 15300 0ustar00leoleo000000000000Many of these files copied (and slightly modified) from MAUKE/Function-Parameters original copyright message: COPYRIGHT & LICENSE Copyright (C) 2010-2014, 2017 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See for more information. Future-AsyncAwait-0.66/hax/cv_copy_flags.c.inc000444001750001750 1230214476650556 20210 0ustar00leoleo000000000000/* vi: set ft=c : */ #define padname_is_normal_lexical(pname) MY_padname_is_normal_lexical(aTHX_ pname) static bool MY_padname_is_normal_lexical(pTHX_ PADNAME *pname) { /* PAD slots without names are certainly not lexicals */ if(PadnameIsNULL(pname) || !PadnameLEN(pname)) return FALSE; /* Outer lexical captures are not lexicals */ if(PadnameOUTER(pname)) return FALSE; /* state variables are not lexicals */ if(PadnameIsSTATE(pname)) return FALSE; /* Protosubs for closures are not lexicals */ if(PadnamePV(pname)[0] == '&') return FALSE; /* anything left is a normal lexical */ return TRUE; } enum { CV_COPY_NULL_LEXICALS = (1<<0), /* regular lexicals end up NULL */ }; #define cv_copy_flags(orig, flags) MY_cv_copy_flags(aTHX_ orig, flags) static CV *MY_cv_copy_flags(pTHX_ CV *orig, U32 flags) { /* Parts of this code stolen from S_cv_clone() in pad.c */ CV *new = MUTABLE_CV(newSV_type(SVt_PVCV)); CvFLAGS(new) = CvFLAGS(orig) & ~CVf_CVGV_RC; CvFILE(new) = CvDYNFILE(orig) ? savepv(CvFILE(orig)) : CvFILE(orig); #if HAVE_PERL_VERSION(5, 18, 0) if(CvNAMED(orig)) { /* Perl core uses CvNAME_HEK_set() here, but that involves a call to a * non-public function unshare_hek(). The latter is only needed in the * case where an old value needs to be removed, but since we've only just * created the CV we know it will be empty, so we can just set the field * directly */ ((XPVCV*)MUTABLE_PTR(SvANY(new)))->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(orig)); CvNAMED_on(new); } else #endif CvGV_set(new, CvGV(orig)); CvSTASH_set(new, CvSTASH(orig)); { OP_REFCNT_LOCK; CvROOT(new) = OpREFCNT_inc(CvROOT(orig)); OP_REFCNT_UNLOCK; } CvSTART(new) = CvSTART(orig); CvOUTSIDE(new) = MUTABLE_CV(SvREFCNT_inc(CvOUTSIDE(orig))); CvOUTSIDE_SEQ(new) = CvOUTSIDE_SEQ(orig); /* No need to bother with SvPV slot because that's the prototype, and it's * too late for that here */ /* TODO: Consider what to do about SvPVX */ { ENTER_with_name("cv_copy_flags"); SAVESPTR(PL_compcv); PL_compcv = new; SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(orig)); CvPADLIST_set(new, pad_new(padnew_CLONE|padnew_SAVE)); #if HAVE_PERL_VERSION(5, 22, 0) CvPADLIST(new)->xpadl_id = CvPADLIST(orig)->xpadl_id; #endif PADNAMELIST *padnames = PadlistNAMES(CvPADLIST(orig)); const PADOFFSET fnames = PadnamelistMAX(padnames); const PADOFFSET fpad = AvFILLp(PadlistARRAY(CvPADLIST(orig))[1]); int depth = CvDEPTH(orig); if(!depth) depth = 1; SV **origpad = AvARRAY(PadlistARRAY(CvPADLIST(orig))[depth]); #if !HAVE_PERL_VERSION(5, 18, 0) /* Perls before 5.18.0 didn't copy the padnameslist */ SvREFCNT_dec(PadlistNAMES(CvPADLIST(new))); PadlistNAMES(CvPADLIST(new)) = (PADNAMELIST *)SvREFCNT_inc(PadlistNAMES(CvPADLIST(orig))); #endif av_fill(PL_comppad, fpad); PL_curpad = AvARRAY(PL_comppad); PADNAME **pnames = PadnamelistARRAY(padnames); PADOFFSET padix; /* TODO: What about padix 0? */ for(padix = 1; padix <= fpad; padix++) { PADNAME *pname = (padix <= fnames) ? pnames[padix] : NULL; SV *newval = NULL; if(padname_is_normal_lexical(pname)) { if(flags & CV_COPY_NULL_LEXICALS) continue; switch(PadnamePV(pname)[0]) { case '$': newval = newSV(0); break; case '@': newval = MUTABLE_SV(newAV()); break; case '%': newval = MUTABLE_SV(newHV()); break; default: croak("ARGH unsure how to handle pname=<%s> in cv_copy_flags\n", PadnamePV(pname)); break; } } else if(!origpad[padix]) newval = NULL; else if(SvPADTMP(origpad[padix])) { /* We still have to copy the value, in case it is live. Also core perl * is known to set SvPADTMP on non-temporaries, like folded constants * https://rt.cpan.org/Ticket/Display.html?id=142468 */ newval = newSVsv(origpad[padix]); SvPADTMP_on(newval); } else { #if !HAVE_PERL_VERSION(5, 18, 0) /* Before perl 5.18.0, inner anon subs didn't find the right CvOUTSIDE * at runtime, so we'll have to patch them up here */ CV *origproto; if(pname && PadnamePV(pname)[0] == '&' && CvOUTSIDE(origproto = MUTABLE_CV(origpad[padix])) == orig) { /* quiet any "Variable $FOO is not available" warnings about lexicals * yet to be introduced */ ENTER_with_name("find_cv_outside"); SAVEINT(CvDEPTH(origproto)); CvDEPTH(origproto) = 1; CV *newproto = cv_copy_flags(origproto, flags); CvPADLIST_set(newproto, CvPADLIST(origproto)); CvSTART(newproto) = CvSTART(origproto); SvREFCNT_dec(CvOUTSIDE(newproto)); CvOUTSIDE(newproto) = MUTABLE_CV(SvREFCNT_inc_simple_NN(new)); LEAVE_with_name("find_cv_outside"); newval = MUTABLE_SV(newproto); } else #endif if(origpad[padix]) newval = SvREFCNT_inc_NN(origpad[padix]); } PL_curpad[padix] = newval; } LEAVE_with_name("cv_copy_flags"); } return new; } Future-AsyncAwait-0.66/hax/cx_pushblock.c.inc000444001750001750 50414476650556 20017 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef cx_pushblock #define cx_pushblock(t, gimme, sp, saveix) S_cx_pushblock(aTHX_ t, gimme, sp, saveix) static PERL_CONTEXT *S_cx_pushblock(pTHX_ U32 t, U8 gimme, SV **sp, I32 saveix) { PERL_CONTEXT *cx; assert(saveix == PL_savestack_ix); PUSHBLOCK(cx, t, sp); return cx; } #endif Future-AsyncAwait-0.66/hax/cx_pusheval.c.inc000444001750001750 46214476650556 17657 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef cx_pusheval #define cx_pusheval(cx, retop, n) S_cx_pusheval(aTHX_ cx, retop, n) static void S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv) { PUSHEVAL(cx, NULL); cx->blk_eval.retop = retop; if(namesv) cx->blk_eval.old_namesv = namesv; } #endif Future-AsyncAwait-0.66/hax/docatch.c.inc000444001750001750 142514476650556 16763 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef docatch #define docatch(firstpp) S_docatch(aTHX_ firstpp) static OP *S_docatch(pTHX_ Perl_ppaddr_t firstpp) { int ret; OP * const oldop = PL_op; dJMPENV; assert(CATCH_GET == TRUE); JMPENV_PUSH(ret); switch (ret) { case 0: PL_op = firstpp(aTHX); redo_body: if(PL_op) CALLRUNOPS(aTHX); break; case 3: /* die caught by an inner eval - continue inner loop */ if (PL_restartop && PL_restartjmpenv == PL_top_env) { PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; } /* FALLTHROUGH */ default: JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; return NULL; } #endif Future-AsyncAwait-0.66/hax/newOP_CUSTOM.c.inc000444001750001750 612414476650556 17501 0ustar00leoleo000000000000/* vi: set ft=c : */ /* Before perl 5.22 under -DDEBUGGING, various new*OP() functions throw assert * failures on OP_CUSTOM. * https://rt.cpan.org/Ticket/Display.html?id=128562 */ #define newOP_CUSTOM(func, flags) S_newOP_CUSTOM(aTHX_ func, flags) #define newUNOP_CUSTOM(func, flags, first) S_newUNOP_CUSTOM(aTHX_ func, flags, first) #define newSVOP_CUSTOM(func, flags, sv) S_newSVOP_CUSTOM(aTHX_ func, flags, sv) #define newBINOP_CUSTOM(func, flags, first, last) S_newBINOP_CUSTOM(aTHX_ func, flags, first, last) #define newLOGOP_CUSTOM(func, flags, first, other) S_newLOGOP_CUSTOM(aTHX_ func, flags, first, other) static OP *S_newOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags) { OP *op = newOP(OP_CUSTOM, flags); op->op_ppaddr = func; return op; } static OP *S_newUNOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first) { UNOP *unop; #if HAVE_PERL_VERSION(5,22,0) unop = (UNOP *)newUNOP(OP_CUSTOM, flags, first); #else NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)OP_CUSTOM; unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); #endif unop->op_ppaddr = func; return (OP *)unop; } static OP *S_newSVOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, SV *sv) { SVOP *svop; #if HAVE_PERL_VERSION(5,22,0) svop = (SVOP *)newSVOP(OP_CUSTOM, flags, sv); #else NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)OP_CUSTOM; svop->op_sv = sv; svop->op_next = (OP *)svop; svop->op_flags = 0; svop->op_private = 0; #endif svop->op_ppaddr = func; return (OP *)svop; } static OP *S_newBINOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last) { BINOP *binop; #if HAVE_PERL_VERSION(5,22,0) binop = (BINOP *)newBINOP(OP_CUSTOM, flags, first, last); #else NewOp(1101, binop, 1, BINOP); binop->op_type = (OPCODE)OP_CUSTOM; binop->op_first = first; first->op_sibling = last; binop->op_last = last; binop->op_flags = (U8)(flags | OPf_KIDS); binop->op_private = (U8)(2 | (flags >> 8)); #endif binop->op_ppaddr = func; return (OP *)binop; } static OP *S_newLOGOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *other) { OP *o; #if HAVE_PERL_VERSION(5,22,0) o = newLOGOP(OP_CUSTOM, flags, first, other); #else /* Parts of this code copypasted from perl 5.20.0's op.c S_new_logop() */ LOGOP *logop; first = op_contextualize(first, G_SCALAR); NewOp(1101, logop, 1, LOGOP); logop->op_type = (OPCODE)OP_CUSTOM; logop->op_ppaddr = NULL; /* Because caller only overrides it anyway */ logop->op_first = first; logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_other = LINKLIST(other); /* logop->op_private has nothing interesting for OP_CUSTOM */ /* Link in postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP *)logop; first->op_sibling = other; /* No CHECKOP for OP_CUSTOM */ o = newUNOP(OP_NULL, 0, (OP *)logop); other->op_next = o; #endif /* the returned op is actually an UNOP that's either NULL or NOT; the real * logop is the op_next of it */ cUNOPx(o)->op_first->op_ppaddr = func; return o; } Future-AsyncAwait-0.66/hax/perl-additions.c.inc000444001750001750 1614414476650556 20320 0ustar00leoleo000000000000/* vi: set ft=c : */ #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; } 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; } #define av_push_from_av_inc(dst, src) S_av_push_from_av(aTHX_ dst, src, TRUE) #define av_push_from_av_noinc(dst, src) S_av_push_from_av(aTHX_ dst, src, FALSE) static void S_av_push_from_av(pTHX_ AV *dst, AV *src, bool refcnt_inc) { SSize_t count = av_count(src); SSize_t i; av_extend(dst, av_count(dst) + count - 1); SV **vals = AvARRAY(src); for(i = 0; i < count; i++) { SV *sv = vals[i]; av_push(dst, refcnt_inc ? SvREFCNT_inc(sv) : sv); } } Future-AsyncAwait-0.66/hax/perl-backcompat.c.inc000444001750001750 1361614476650556 20447 0ustar00leoleo000000000000/* vi: set ft=c : */ #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #ifndef NOT_REACHED # define NOT_REACHED assert(0) #endif #ifndef SvTRUE_NN # define SvTRUE_NN(sv) SvTRUE(sv) #endif #ifndef G_LIST # define G_LIST G_ARRAY #endif #if !HAVE_PERL_VERSION(5, 18, 0) typedef AV PADNAMELIST; # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) # define PadlistNAMES(pl) (*PadlistARRAY(pl)) typedef SV PADNAME; # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) # define PadnameLEN(pn) SvCUR(pn) # define PadnameIsSTATE(pn) (!!SvPAD_STATE(pn)) # define PadnameOUTER(pn) (SvFAKE(pn) && !SvPAD_STATE(pn)) # define PadnamelistARRAY(pnl) AvARRAY(pnl) # define PadnamelistMAX(pnl) AvFILLp(pnl) # define PadARRAY(p) AvARRAY(p) # define PadMAX(pad) AvFILLp(pad) #endif #if !HAVE_PERL_VERSION(5, 22, 0) # define CvPADLIST_set(cv, padlist) (CvPADLIST(cv) = padlist) # define newPADNAMEpvn(p,n) S_newPADNAMEpvn(aTHX_ p,n) static PADNAME *S_newPADNAMEpvn(pTHX_ const char *pv, STRLEN n) { PADNAME *pn = newSVpvn(pv, n); /* PADNAMEs need to be at least SVt_PVNV in order to store the COP_SEQ_* * fields */ sv_upgrade(pn, SVt_PVNV); return pn; } # define PadnameREFCNT_dec(pn) SvREFCNT_dec(pn) #endif #ifndef av_count # define av_count(av) (AvFILL(av) + 1) #endif #ifndef av_top_index # define av_top_index(av) AvFILL(av) #endif #ifndef block_end # define block_end(a,b) Perl_block_end(aTHX_ a,b) #endif #ifndef block_start # define block_start(a) Perl_block_start(aTHX_ a) #endif #ifndef cophh_exists_pvs # define cophh_exists_pvs(a,b,c) cBOOL(cophh_fetch_pvs(a,b,c)) #endif #ifndef cv_clone # define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif #ifndef intro_my # define intro_my() Perl_intro_my(aTHX) #endif #ifndef pad_alloc # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) #endif #ifndef CX_CUR # define CX_CUR() (&cxstack[cxstack_ix]) #endif #if HAVE_PERL_VERSION(5, 24, 0) # define OLDSAVEIX(cx) (cx->blk_oldsaveix) #else # define OLDSAVEIX(cx) (PL_scopestack[cx->blk_oldscopesp-1]) #endif #ifndef OpSIBLING # define OpSIBLING(op) ((op)->op_sibling) #endif #ifndef OpHAS_SIBLING # define OpHAS_SIBLING(op) (cBOOL(OpSIBLING(op))) #endif #ifndef OpMORESIB_set # define OpMORESIB_set(op,sib) ((op)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set /* older perls don't need to store this at all */ # define OpLASTSIB_set(op,parent) #endif #ifndef op_convert_list # define op_convert_list(type, flags, o) S_op_convert_list(aTHX_ type, flags, o) static OP *S_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) { /* A minimal recreation just for our purposes */ assert( /* A hardcoded list of the optypes we know this will work for */ type == OP_ENTERSUB || type == OP_JOIN || type == OP_PUSH || 0); o->op_type = type; o->op_flags |= flags; o->op_ppaddr = PL_ppaddr[type]; o = PL_check[type](aTHX_ o); /* op_std_init() */ if(PL_opargs[type] & OA_RETSCALAR) o = op_contextualize(o, G_SCALAR); if(PL_opargs[type] & OA_TARGET && !o->op_targ) o->op_targ = pad_alloc(type, SVs_PADTMP); return o; } #endif #ifndef newMETHOP_named # define newMETHOP_named(type, flags, name) newSVOP(type, flags, name) #endif #ifndef PARENT_PAD_INDEX_set # if HAVE_PERL_VERSION(5, 22, 0) # define PARENT_PAD_INDEX_set(pn,val) (PARENT_PAD_INDEX(pn) = val) # else /* stolen from perl-5.20.0's pad.c */ # define PARENT_PAD_INDEX_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END # endif #endif /* On Perl 5.14 this had a different name */ #ifndef pad_add_name_pvn #define pad_add_name_pvn(name, len, flags, typestash, ourstash) MY_pad_add_name(aTHX_ name, len, flags, typestash, ourstash) static PADOFFSET MY_pad_add_name(pTHX_ const char *name, STRLEN len, U32 flags, HV *typestash, HV *ourstash) { /* perl 5.14's Perl_pad_add_name requires a NUL-terminated name */ SV *namesv = sv_2mortal(newSVpvn(name, len)); return Perl_pad_add_name(aTHX_ SvPV_nolen(namesv), SvCUR(namesv), flags, typestash, ourstash); } #endif #if !HAVE_PERL_VERSION(5, 26, 0) # define isIDFIRST_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDFIRST_utf8(s)) # define isIDCONT_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDCONT_utf8(s)) #endif #ifndef CXp_EVALBLOCK /* before perl 5.34 this was called CXp_TRYBLOCK */ # define CXp_EVALBLOCK CXp_TRYBLOCK #endif #if !HAVE_PERL_VERSION(5, 26, 0) # define sv_set_undef(sv) sv_setsv(sv, &PL_sv_undef) #endif #ifndef newAVav # define newAVav(av) S_newAVav(aTHX_ av) static AV *S_newAVav(pTHX_ AV *av) { AV *ret = newAV(); U32 count = av_count(av); U32 i; for(i = 0; i < count; i++) av_push(ret, newSVsv(AvARRAY(av)[i])); return ret; } #endif #if !defined(sv_derived_from_hv) && HAVE_PERL_VERSION(5, 16, 0) # define sv_derived_from_hv(sv, hv) MY_sv_derived_from_hv(aTHX_ sv, hv) static bool MY_sv_derived_from_hv(pTHX_ SV *sv, HV *hv) { char *hvname = HvNAME(hv); if(!hvname) return FALSE; return sv_derived_from_pvn(sv, hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0); } #endif #ifndef xV_FROM_REF # ifdef PERL_USE_GCC_BRACE_GROUPS # define xV_FROM_REF(XV, ref) \ ({ SV *_ref = ref; assert(SvROK(_ref)); assert(SvTYPE(SvRV(_ref)) == SVt_PV ## XV); (XV *)(SvRV(_ref)); }) # else # define xV_FROM_REF(XV, ref) ((XV *)SvRV(ref)) # endif # define AV_FROM_REF(ref) xV_FROM_REF(AV, ref) # define CV_FROM_REF(ref) xV_FROM_REF(CV, ref) # define HV_FROM_REF(ref) xV_FROM_REF(HV, ref) #endif #ifndef newPADxVOP # define newPADxVOP(type, flags, padix) S_newPADxVOP(aTHX_ type, flags, padix) static OP *S_newPADxVOP(pTHX_ I32 type, I32 flags, PADOFFSET padix) { OP *op = newOP(type, flags); op->op_targ = padix; return op; } #endif Future-AsyncAwait-0.66/hax/save_clearpadrange.c.inc000444001750001750 76514476650556 21152 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef save_clearpadrange #define save_clearpadrange(padix, count) S_save_clearpadrange(aTHX_ padix, count) static void S_save_clearpadrange(pTHX_ PADOFFSET padix, U32 count) { /* Code stolen from PP(pp_padrange) in pp_hot.c */ const UV payload = (UV)( (padix << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)) | (count << SAVE_TIGHT_SHIFT) | SAVEt_CLEARPADRANGE); dSS_ADD; SS_ADD_UV(payload); SS_ADD_END(1); } #endif Future-AsyncAwait-0.66/lib000755001750001750 014476650556 14271 5ustar00leoleo000000000000Future-AsyncAwait-0.66/lib/Future000755001750001750 014476650556 15543 5ustar00leoleo000000000000Future-AsyncAwait-0.66/lib/Future/AsyncAwait.h000444001750001750 1636414476650556 20146 0ustar00leoleo000000000000#ifndef __FUTURE_ASYNCAWAIT_H__ #define __FUTURE_ASYNCAWAIT_H__ #include "perl.h" #define FUTURE_ASYNCAWAIT_ABI_VERSION 2 /* * The API contained in this file is even more experimental than the rest of * Future::AsyncAwait. It is primarily designed to allow suspend-aware dynamic * variables in Syntax::Keyword::Dynamically, but may be useful for other * tasks. * * There are no unit tests for these hooks inside this distribution, as testing * it would require more XS code. It is tested as a side-effect of the * integration with Syntax::Keyword::Dynamically. */ struct AsyncAwaitHookFuncs { U32 flags; /* currently unused but reserve the ABI space just in case */ void (*post_cv_copy)(pTHX_ CV *runcv, CV *cv, HV *modhookdata, void *hookdata); void (*pre_suspend) (pTHX_ CV *cv, HV *modhookdata, void *hookdata); void (*post_suspend)(pTHX_ CV *cv, HV *modhookdata, void *hookdata); void (*pre_resume) (pTHX_ CV *cv, HV *modhookdata, void *hookdata); void (*post_resume) (pTHX_ CV *cv, HV *modhookdata, void *hookdata); void (*free) (pTHX_ CV *cv, HV *modhookdata, void *hookdata); }; static void (*register_future_asyncawait_hook_func)(pTHX_ const struct AsyncAwaitHookFuncs *hookfuncs, void *hookdata); #define register_future_asyncawait_hook(hookfuncs, hookdata) S_register_future_asyncawait_hook(aTHX_ hookfuncs, hookdata) static void S_register_future_asyncawait_hook(pTHX_ const struct AsyncAwaitHookFuncs *hookfuncs, void *hookdata) { if(!register_future_asyncawait_hook_func) croak("Must call boot_future_asyncawait() first"); (*register_future_asyncawait_hook_func)(aTHX_ hookfuncs, hookdata); } #define future_asyncawait_on_activate(func, data) S_future_asyncawait_on_activate(aTHX_ func, data) static void S_future_asyncawait_on_activate(pTHX_ void (*func)(pTHX_ void *data), void *data) { SV **svp; if((svp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/loaded", FALSE)) && SvOK(*svp)) { (*func)(aTHX_ data); } else { AV *av; svp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/on_loaded", FALSE); if(svp) av = (AV *)*svp; else { av = newAV(); hv_stores(PL_modglobal, "Future::AsyncAwait/on_loaded", (SV *)av); } av_push(av, newSVuv(PTR2UV(func))); av_push(av, newSVuv(PTR2UV(data))); } } /* flags constants for future_asyncawait_get_modhookdata() */ enum { FAA_MODHOOK_CREATE = (1<<0), }; static HV *(*future_asyncawait_get_modhookdata_func)(pTHX_ CV *cv, U32 flags, PADOFFSET precreate_padix); #define future_asyncawait_get_modhookdata(cv, flags, precreate_padix) \ S_future_asyncawait_get_modhookdata(aTHX_ cv, flags, precreate_padix) static HV *S_future_asyncawait_get_modhookdata(pTHX_ CV *cv, U32 flags, PADOFFSET precreate_padix) { if(!future_asyncawait_get_modhookdata_func) croak("Must call boot_future_asyncawait() first"); return (*future_asyncawait_get_modhookdata_func)(aTHX_ cv, flags, precreate_padix); } static PADOFFSET (*future_asyncawait_make_precreate_padix_func)(pTHX); #define future_asyncawait_make_precreate_padix() S_future_asyncawait_make_precreate_padix(aTHX) PADOFFSET S_future_asyncawait_make_precreate_padix(pTHX) { if(!future_asyncawait_make_precreate_padix_func) croak("Must call boot_future_asyncawait() first"); return (*future_asyncawait_make_precreate_padix_func)(aTHX); } #define boot_future_asyncawait(ver) S_boot_future_asyncawait(aTHX_ ver) static void S_boot_future_asyncawait(pTHX_ double ver) { SV **svp; SV *versv = ver ? newSVnv(ver) : NULL; load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Future::AsyncAwait"), versv, NULL); svp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/ABIVERSION_MIN", 0); if(!svp) croak("Future::AsyncAwait ABI minimum version missing"); int abi_ver = SvIV(*svp); if(abi_ver > FUTURE_ASYNCAWAIT_ABI_VERSION) croak("Future::AsyncAwait ABI version mismatch - library supports >= %d, compiled for %d", abi_ver, FUTURE_ASYNCAWAIT_ABI_VERSION); svp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/ABIVERSION_MAX", 0); abi_ver = SvIV(*svp); if(abi_ver < FUTURE_ASYNCAWAIT_ABI_VERSION) croak("Future::AsyncAwait ABI version mismatch - library supports <= %d, compiled for %d", abi_ver, FUTURE_ASYNCAWAIT_ABI_VERSION); register_future_asyncawait_hook_func = INT2PTR(void (*)(pTHX_ const struct AsyncAwaitHookFuncs *, void *), SvUV(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/register()@2", 0))); future_asyncawait_get_modhookdata_func = INT2PTR(HV *(*)(pTHX_ CV *, U32, PADOFFSET), SvUV(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/get_modhookdata()@1", 0))); future_asyncawait_make_precreate_padix_func = INT2PTR(PADOFFSET (*)(pTHX), SvUV(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/make_precreate_padix()@1", 0))); } /************** * Legacy API * **************/ /* * This enum provides values for the `phase` hook parameter. */ enum { /* PRESUSPEND = 0x10, */ FAA_PHASE_POSTSUSPEND = 0x20, FAA_PHASE_PRERESUME = 0x30, /* POSTRESUME = 0x40, */ FAA_PHASE_FREE = 0xFF, }; /* * The type of suspend hook functions. * * `phase` indicates the point in the suspend/resume lifecycle, as one of * the values of the enum above. * `cv` points to the CV being suspended or resumed. This will be after it * has been cloned, if necessary. * `modhookdata` points to an HV associated with the CV state, and may be * used by modules as a scratchpad to store extra data relating to this * function. Callers should prefix keys with their own module name to * avoid collisions. */ typedef void SuspendHookFunc(pTHX_ U8 phase, CV *cv, HV *modhookdata); /* * Callers should use this function-like macro to set the value of the hook * function variable, by passing in the address of a new function and a pointer * to a variable to capture the previous value. * * static SuspendHookFunc *oldhook; * * future_asyncawait_wrap_suspendhook(&my_hook_func, &oldhook); * * The hook function itself should remember to chain to the oldhook function, * whose value will never be NULL; * * void my_hook_func(aTHX_ U8 phase, CV *cv, HV *modhookdata) * { * ... * (*oldhook)(phase, cv, modhookdata); * } */ static void S_null_suspendhook(pTHX_ U8 phase, CV *cv, HV *modhookdata) { /* empty */ } #ifndef OP_CHECK_MUTEX_LOCK /* < 5.15.8 */ # define OP_CHECK_MUTEX_LOCK ((void)0) # define OP_CHECK_MUTEX_UNLOCK ((void)0) #endif #define future_asyncawait_wrap_suspendhook(newfunc, oldhookp) S_future_asyncawait_wrap_suspendhook(aTHX_ newfunc, oldhookp) static void S_future_asyncawait_wrap_suspendhook(pTHX_ SuspendHookFunc *newfunc, SuspendHookFunc **oldhookp) { if(*oldhookp) return; warn("future_asyncawait_wrap_suspendhook() is now deprecated; use register_future_asyncawait_hook() instead"); /* Rather than define our own mutex for this very-rare usecase, we'll just * abuse core's opcheck mutex for it. At worst this leads to thread * contention at module load time for this very quick test */ OP_CHECK_MUTEX_LOCK; if(!*oldhookp) { SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", TRUE); if(hookp && SvOK(*hookp)) *oldhookp = INT2PTR(SuspendHookFunc *, SvUV(*hookp)); else *oldhookp = &S_null_suspendhook; sv_setuv(*hookp, PTR2UV(newfunc)); } OP_CHECK_MUTEX_UNLOCK; } #endif Future-AsyncAwait-0.66/lib/Future/AsyncAwait.pm000444001750001750 4370714476650556 20334 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2016-2021 -- leonerd@leonerd.org.uk package Future::AsyncAwait 0.66; use v5.14; use warnings; use Carp; require XSLoader; XSLoader::load( __PACKAGE__, our $VERSION ); require Future; Future->VERSION( '0.48' ); if( !Future->can( "AWAIT_WAIT" ) ) { no strict 'refs'; # Future 0.48 had this method; newer futures already provide AWAIT_WAIT *{"Future::AWAIT_WAIT"} = Future->can( "get" ); } =head1 NAME C - deferred subroutine syntax for futures =head1 SYNOPSIS use v5.14; use Future::AsyncAwait; async sub do_a_thing { my $first = await do_first_thing(); my $second = await do_second_thing(); return combine_things( $first, $second ); } do_a_thing()->get; =head1 DESCRIPTION This module provides syntax for deferring and resuming subroutines while waiting for Ls to complete. This syntax aims to make code that performs asynchronous operations using futures look neater and more expressive than simply using C chaining and other techniques on the futures themselves. It is also a similar syntax used by a number of other languages; notably C# 5, EcmaScript 6, Python 3, Dart, Rust, C++20. This module is still under active development. While it now seems relatively stable enough for most use-cases and has received a lot of "battle-testing" in a wide variety of scenarios, there may still be the occasional case of memory leak left in it, especially if still-pending futures are abandoned. The new syntax takes the form of two new keywords, C and C. =head2 C The C keyword should appear just before the C keyword that declares a new function. When present, this marks that the function performs its work in a I asynchronous fashion. This has two effects: it permits the body of the function to use the C expression, and it wraps the return value of the function in a L instance. async sub myfunc { return 123; } my $f = myfunc(); my $result = $f->get; As well as named function declarations it is also supported on anonymous function expressions. my $code = async sub { return 456 }; my $f = $code->(); my $result = $f->get; This C-declared function always returns a C instance when invoked. The returned future instance will eventually complete when the function returns, either by the C keyword or by falling off the end; the result of the future will be the return value from the function's code. Alternatively, if the function body throws an exception, this will cause the returned future to fail. If the final expression in the body of the function returns a C, don't forget to C it rather than simply returning it as it is, or else this return value will become double-wrapped - almost certainly not what you wanted. async sub otherfunc { ... } async sub myfunc { ... return await otherfunc(); } =head2 C The C keyword forms an expression which takes a C instance as an operand and yields the eventual result of it. Superficially it can be thought of similar to invoking the C method on the future. my $result = await $f; my $result = $f->get; However, the key difference (and indeed the entire reason for being a new syntax keyword) is the behaviour when the future is still pending and is not yet complete. Whereas the simple C method would block until the future is complete, the C keyword causes its entire containing function to become suspended, making it return a new (pending) future instance. It waits in this state until the future it was waiting on completes, at which point it wakes up and resumes execution from the point of the C expression. When the now-resumed function eventually finishes (either by returning a value or throwing an exception), this value is set as the result of the future it had returned earlier. C provides scalar context to its controlling expression. async sub func { # this function is invoked in scalar context } await func(); Because the C keyword may cause its containing function to suspend early, returning a pending future instance, it is only allowed inside C-marked subs. The converse is not true; just because a function is marked as C does not require it to make use of the C expression. It is still useful to turn the result of that function into a future, entirely without Cing on any itself. Any function that doesn't actually await anything, and just returns immediate futures can be neatened by this module too. Instead of writing sub imm { ... return Future->done( @result ); } you can now simply write async sub imm { ... return @result; } with the added side-benefit that any exceptions thrown by the elided code will be turned into an immediate-failed C rather than making the call itself propagate the exception, which is usually what you wanted when dealing with futures. =head2 await (toplevel) I An C expression is also permitted directly in the main script at toplevel, outside of C. This is implemented by simply invoking the C method on the future value. Thus, the following two lines are directly equivalent: await afunc(); afunc()->get; This is provided as a syntax convenience for unit tests, toplevel scripts, and so on. It allows code to be written in a style that can be easily moved into an C, and avoids encouraging "bad habits" of invoking the C method directly. =head2 C I The C keyword declares a block of code which will be run in the event that the future returned by the C is cancelled. async sub f { CANCEL { warn "This task was cancelled"; } await ... } f()->cancel; A C block is a self-contained syntax element, similar to perl constructions like C, and does not need a terminating semicolon. When a C block is encountered during execution of the C, the code in its block is stored for the case that the returned future is cancelled. Each will take effect as it is executed, possibly multiple times if it appears inside a loop, or not at all if it appears conditionally in a branch that was not executed. async sub g { if(0) { CANCEL { warn "This does not happen"; } } foreach my $x ( 1..3 ) { CANCEL { warn "This happens for x=$x"; } } await ... } g()->cancel; C blocks are only invoked if a still-pending future is cancelled. They are discarded without being executed if the function finishes; either successfully or if it throws an exception. =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 Future::AsyncAwait qw( :experimental(cancel) ); use Future::AsyncAwait qw( :experimental ); # all of the above =head1 SUPPORTED USES Most cases involving awaiting on still-pending futures should work fine: async sub foo { my ( $f ) = @_; BEFORE(); await $f; AFTER(); } async sub bar { my ( $f ) = @_; return 1 + await( $f ) + 3; } async sub splot { while( COND ) { await func(); } } async sub wibble { if( COND ) { await func(); } } async sub wobble { foreach my $var ( THINGs ) { await func(); } } async sub wubble { # on perl 5.35.5 and above foreach my ($k, $v) ( KVTHINGs ) { await func(); } } async sub quux { my $x = do { await func(); }; } async sub splat { eval { await func(); }; } Plain lexical variables are preserved across an C deferral: async sub quux { my $message = "Hello, world\n"; await func(); print $message; } On perl versions 5.26 and later C syntax supports the C feature if it is enabled: use v5.26; use feature 'signatures'; async sub quart($x, $y) { ... } I any exceptions thrown by signature validation (because of too few or too many arguments being passed) are thrown synchronously, and do not result in a failed Future instance. =head2 Cancellation Cancelled futures cause a suspended C to simply stop running. async sub fizz { await func(); say "This is never reached"; } my $f = fizz(); $f->cancel; Cancellation requests can propagate backwards into the future the C is currently waiting on. async sub floof { ... await $f1; } my $f2 = floof(); $f2->cancel; # $f1 will be cancelled too This behaviour is still more experimental than the rest of the logic. The following should be noted: =over 4 =item * Cancellation propagation is only implemented on Perl version 5.24 and above. An C in an earlier perl version will still stop executing if cancelled, but will not propagate the request backwards into the future that the C is currently waiting on. See L. =back =head1 SUBCLASSING Future By default when an C returns a result or fails immediately before awaiting, it will return a new completed instance of the L class. In order to allow code that wishes to use a different class to represent futures the module import method can be passed the name of a class to use instead. use Future::AsyncAwait future_class => "Subclass::Of::Future"; async sub func { ... } This has the usual lexically-scoped effect, applying only to Cs defined within the block; others are unaffected. use Future::AsyncAwait; { use Future::AsyncAwait future_class => "Different::Future"; async sub x { ... } } async sub y { ... } # returns a regular Future This will only affect immediate results. If the C keyword has to suspend the function and create a new pending future, it will do this by using the prototype constructor on the future it itself is waiting on, and the usual subclass-respecting semantics of L will remain in effect there. As such it is not usually necessary to use this feature just for wrapping event system modules or other similar situations. Such an alternative subclass should implement the API documented by L. =head1 WITH OTHER MODULES =head2 Syntax::Keyword::Try As of L 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"; } } As of L version 0.50, C blocks are invoked even during cancellation. =head2 Syntax::Keyword::Dynamically As of L version 0.32, cross-module integration tests assert that the C correctly works across an C boundary. use Future::AsyncAwait; use Syntax::Keyword::Dynamically; our $var; async sub trial { dynamically $var = "value"; await func(); say "Var is still $var"; } =head2 Syntax::Keyword::Defer As of L version 0.50, C blocks are invoked even during cancellation. use Future::AsyncAwait; use Syntax::Keyword::Defer; async sub perhaps { defer { say "Cleaning up now" } await $f1; } my $fouter = perhaps(); $fouter->cancel; =head2 Object::Pad As of L version 0.38 and L version 0.15, both modules now use L to parse blocks of code. Because of this the two modules can operate together and allow class methods to be written as async subs which await expressions: use Future::AsyncAwait; use Object::Pad; class Example { async method perform($block) { say "$self is performing code"; await $block->(); say "code finished"; } } =head2 Syntax::Keyword::MultiSub As of L version 0.55 and L version 0.02 a cross-module integration test asserts that the C modifier can be applied to C. use Future::AsyncAwait; use Syntax::Keyword::MultiSub; async multi sub f () { return "nothing"; } async multi sub f ($key) { return await get_thing($key); } =cut sub import { my $pkg = shift; my $caller = caller; $pkg->import_into( $caller, @_ ); } sub unimport { my $pkg = shift; my $caller = caller; $pkg->unimport_into( $caller, @_ ); } sub import_into { shift->apply( sub { $^H{ $_[0] }++ }, @_ ) } sub unimport_into { shift->apply( sub { delete $^H{ $_[0] } }, @_ ) } my @EXPERIMENTAL = qw( cancel ); sub apply { my $pkg = shift; my ( $cb, $caller, @syms ) = @_; $cb->( "Future::AsyncAwait/async" ); # Just always turn this on SYM: while( @syms ) { my $sym = shift @syms; $^H{"Future::AsyncAwait/future"} = shift @syms, next if $sym eq "future_class"; foreach ( @EXPERIMENTAL ) { $cb->( "Future::AsyncAwait/experimental($_)" ), next SYM if $sym eq ":experimental($_)"; } if( $sym eq ":experimental" ) { $cb->( "Future::AsyncAwait/experimental($_)" ) for @EXPERIMENTAL; next SYM; } croak "Unrecognised import symbol $sym"; } } =head1 SEE ALSO =over 4 =item * "Awaiting The Future" - TPC in Amsterdam 2017 L L<(slides)|https://docs.google.com/presentation/d/13x5l8Rohv_RjWJ0OTvbsWMXKoNEWREZ4GfKHVykqUvc/edit#slide=id.p> =back =head1 TODO =over 4 =item * Suspend and resume with some consideration for the savestack; i.e. the area used to implement C and similar. While in general C support has awkward questions about semantics, there are certain situations and cases where internally-implied localisation of variables would still be useful and can be supported without the semantic ambiguities of generic C. our $DEBUG = 0; async sub quark { local $DEBUG = 1; await func(); } Since C loops on non-lexical iterator variables (usually the C<$_> global variable) effectively imply a C-like behaviour, these are also disallowed. async sub splurt { foreach ( LIST ) { await ... } } Some notes on what makes the problem hard can be found at L =item * Currently this module requires perl version 5.16 or later. Additionally, threaded builds of perl earlier than 5.22 are not supported. L L =item * Implement cancel back-propagation for Perl versions earlier than 5.24. Currently this does not work due to some as-yet-unknown effects that installing the back-propagation has, causing future instances to be reclaimed too early. L =back =head1 KNOWN BUGS This is not a complete list of all known issues, but rather a summary of the most notable ones that currently prevent the module from working correctly in a variety of situations. For a complete list of known bugs, see the RT queue at L. =over 4 =item * C inside C or C blocks does not work. This is due to the difficulty of detecting the map or grep context from internal perl state at suspend time, sufficient to be able to restore it again when resuming. L As a workaround, consider converting a C expression to the equivalent form using C onto an accumulator array with a C loop: my @results = map { await func($_) } ITEMS; becomes my @results; foreach my $item ( ITEMS ) { push @results, await func($item); } with a similar transformation for C expressions. Alternatively, consider using the C family of functions from L to provide a concurrent version of the same code, which can keep multiple items running concurrently: use Future::Utils qw( fmap ); my @results = await fmap { func( shift ) } foreach => [ ITEMS ], concurrent => 5; =item * The default arguments array (C<@_>) is not saved and restored by an C call on perl versions before v5.24. On such older perls, the value seen in the C<@_> array after an await will not be the same as it was before. L As a workaround, make sure to unpack the values out of it into regular lexical variables early on, before the the first C. The values of these lexicals will be saved and restored as normal. async sub f { my ($vars, $go, @here) = @_; # do not make further use of @_ afterwards await thing(); # $vars, $go, @here are all fine for use } =back =cut =head1 ACKNOWLEDGEMENTS With thanks to C, C and others from C for assisting with trickier bits of XS logic. Thanks to C for project management and actually reminding me to write some code. Thanks to The Perl Foundation for sponsoring me to continue working on the implementation. =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.66/lib/Future/AsyncAwait.xs000444001750001750 20766314476650556 20375 0ustar00leoleo000000000000/* You may distribute under the terms of either the GNU General Public License * or the Artistic License (the same terms as Perl itself) * * (C) Paul Evans, 2016-2022 -- leonerd@leonerd.org.uk */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "AsyncAwait.h" #ifdef HAVE_DMD_HELPER # define WANT_DMD_API_044 # include "DMD_helper.h" #endif #include "XSParseKeyword.h" #include "XSParseSublike.h" #include "perl-backcompat.c.inc" #if !HAVE_PERL_VERSION(5, 24, 0) /* On perls before 5.24 we have to do some extra work to save the itervar * from being thrown away */ # define HAVE_ITERVAR #endif #if HAVE_PERL_VERSION(5, 24, 0) /* For unknown reasons, doing this on perls 5.20 or 5.22 massively breaks * everything. * https://rt.cpan.org/Ticket/Display.html?id=129202#txn-1843918 */ # define HAVE_FUTURE_CHAIN_CANCEL #endif #if HAVE_PERL_VERSION(5, 26, 0) # define HAVE_OP_ARGCHECK #endif #if HAVE_PERL_VERSION(5, 33, 7) /* perl 5.33.7 added CXp_TRY and the CxTRY macro for true try/catch semantics */ # define HAVE_CX_TRY #endif #ifdef SAVEt_CLEARPADRANGE # include "save_clearpadrange.c.inc" #endif #if !HAVE_PERL_VERSION(5, 24, 0) # include "cx_pushblock.c.inc" # include "cx_pusheval.c.inc" #endif #include "perl-additions.c.inc" #include "newOP_CUSTOM.c.inc" #include "cv_copy_flags.c.inc" /* Currently no version of perl makes this visible, so we always want it. Maybe * one day in the future we can make it version-dependent */ static void panic(char *fmt, ...); #ifndef NOT_REACHED # define NOT_REACHED STMT_START { panic("Unreachable\n"); } STMT_END #endif #include "docatch.c.inc" typedef struct SuspendedFrame SuspendedFrame; struct SuspendedFrame { SuspendedFrame *next; U8 type; U8 gimme; U32 stacklen; SV **stack; U32 marklen; I32 *marks; COP *oldcop; /* items from the save stack */ U32 savedlen; struct Saved { U8 type; union { struct { PADOFFSET padix; U32 count; } clearpad; /* for SAVEt_CLEARSV and SAVEt_CLEARPADRANGE */ struct { void (*func)(pTHX_ void *data); void *data; } dx; /* for SAVEt_DESTRUCTOR_X */ GV *gv; /* for SAVEt_SV + cur.sv, saved.sv */ int *iptr; /* for SAVEt_INT... */ STRLEN *lenptr; /* for SAVEt_STRLEN + cur.len, saved.len */ PADOFFSET padix; /* for SAVEt_PADSV_AND_MORTALIZE, SAVEt_SPTR */ SV *sv; /* for SAVEt_ITEM */ struct { SV *sv; U32 mask, set; } svflags; /* for SAVEt_SET_SVFLAGS */ } u; union { SV *sv; /* for SAVEt_SV, SAVEt_FREESV, SAVEt_ITEM */ void *ptr; /* for SAVEt_COMPPAD, */ int i; /* for SAVEt_INT... */ STRLEN len; /* for SAVEt_STRLEN */ } cur, /* the current value that *thing that we should restore to */ saved; /* the saved value we should push to the savestack on restore */ } *saved; union { struct { OP *retop; } eval; struct block_loop loop; } el; /* for debugging purposes */ SV *loop_list_first_item; #ifdef HAVE_ITERVAR SV *itervar; #endif U32 scopes; U32 mortallen; SV **mortals; }; typedef struct { SV *awaiting_future; /* the Future that 'await' is currently waiting for */ SV *returning_future; /* the Future that its contining CV will eventually return */ COP *curcop; /* value of PL_curcop at suspend time */ SuspendedFrame *frames; U32 padlen; SV **padslots; PMOP *curpm; /* value of PL_curpm at suspend time */ AV *defav; /* value of GvAV(PL_defgv) at suspend time */ HV *modhookdata; } SuspendedState; #ifdef DEBUG # define TRACEPRINT S_traceprint static void S_traceprint(char *fmt, ...) { /* TODO: make conditional */ va_list args; va_start(args, fmt); vfprintf(stderr, fmt, args); va_end(args); } #else # define TRACEPRINT(...) #endif static void vpanic(char *fmt, va_list args) { fprintf(stderr, "Future::AsyncAwait panic: "); vfprintf(stderr, fmt, args); raise(SIGABRT); } static void panic(char *fmt, ...) { va_list args; va_start(args, fmt); vpanic(fmt, args); } /* * Hook mechanism */ struct HookRegistration { const struct AsyncAwaitHookFuncs *funcs; void *data; }; struct HookRegistrations { struct HookRegistration *arr; size_t count, size; }; static struct HookRegistrations *S_registrations(pTHX_ bool add) { SV *regsv = *hv_fetchs(PL_modglobal, "Future::AsyncAwait/registrations", GV_ADD); if(!SvOK(regsv)) { if(!add) return NULL; struct HookRegistrations *registrations; Newx(registrations, 1, struct HookRegistrations); registrations->count = 0; registrations->size = 4; Newx(registrations->arr, registrations->size, struct HookRegistration); sv_setuv(regsv, PTR2UV(registrations)); } return INT2PTR(struct HookRegistrations *, SvUV(regsv)); } #define registrations(add) S_registrations(aTHX_ add) static void register_faa_hook(pTHX_ const struct AsyncAwaitHookFuncs *hookfuncs, void *hookdata) { /* Currently no flags are recognised; complain if the caller requested any */ if(hookfuncs->flags) croak("Unrecognised hookfuncs->flags value %08x", hookfuncs->flags); struct HookRegistrations *regs = registrations(TRUE); if(regs->count == regs->size) { regs->size *= 2; Renew(regs->arr, regs->size, struct HookRegistration); } regs->arr[regs->count].funcs = hookfuncs; regs->arr[regs->count].data = hookdata; regs->count++; } #define RUN_HOOKS_FWD(func, ...) \ { \ int _hooki = 0; \ while(_hooki < regs->count) { \ struct HookRegistration *reg = regs->arr + _hooki; \ if(reg->funcs->func) \ (*reg->funcs->func)(aTHX_ __VA_ARGS__, reg->data); \ _hooki++; \ } \ } #define RUN_HOOKS_REV(func, ...) \ { \ int _hooki = regs->count; \ while(_hooki > 0) { \ _hooki--; \ struct HookRegistration *reg = regs->arr + _hooki; \ if(reg->funcs->func) \ (*reg->funcs->func)(aTHX_ __VA_ARGS__, reg->data); \ } \ } /* * Magic that we attach to suspended CVs, that contains state required to restore * them */ static int suspendedstate_free(pTHX_ SV *sv, MAGIC *mg); static MGVTBL vtbl_suspendedstate = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ suspendedstate_free, }; #ifdef HAVE_DMD_HELPER static int dumpmagic_suspendedstate(pTHX_ DMDContext *ctx, const SV *sv, MAGIC *mg) { SuspendedState *state = (SuspendedState *)mg->mg_ptr; int ret = 0; ret += DMD_ANNOTATE_SV(sv, state->awaiting_future, "the awaiting Future"); ret += DMD_ANNOTATE_SV(sv, state->returning_future, "the returning Future"); SuspendedFrame *frame; for(frame = state->frames; frame; frame = frame->next) { int i; for(i = 0; i < frame->stacklen; i++) ret += DMD_ANNOTATE_SV(sv, frame->stack[i], "a suspended stack temporary"); for(i = 0; i < frame->mortallen; i++) ret += DMD_ANNOTATE_SV(sv, frame->mortals[i], "a suspended mortal"); #ifdef HAVE_ITERVAR if(frame->itervar) ret += DMD_ANNOTATE_SV(sv, frame->itervar, "a suspended loop iteration variable"); #endif switch(frame->type) { case CXt_BLOCK: case CXt_LOOP_PLAIN: break; case CXt_LOOP_LAZYSV: ret += DMD_ANNOTATE_SV(sv, frame->el.loop.state_u.lazysv.cur, "a suspended foreach LAZYSV loop iterator value"); ret += DMD_ANNOTATE_SV(sv, frame->el.loop.state_u.lazysv.end, "a suspended foreach LAZYSV loop stop value"); goto cxt_loop_common; #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_ARY: #else case CXt_LOOP_FOR: #endif if(frame->el.loop.state_u.ary.ary) ret += DMD_ANNOTATE_SV(sv, (SV *)frame->el.loop.state_u.ary.ary, "a suspended foreach ARY loop value array"); goto cxt_loop_common; case CXt_LOOP_LAZYIV: #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_LIST: #endif cxt_loop_common: #if !defined(HAVE_ITERVAR) ret += DMD_ANNOTATE_SV(sv, frame->el.loop.itersave, "a suspended loop saved iteration variable"); #endif break; } for(i = 0; i < frame->savedlen; i++) { struct Saved *saved = &frame->saved[i]; switch(saved->type) { #ifdef SAVEt_CLEARPADRANGE case SAVEt_CLEARPADRANGE: #endif case SAVEt_CLEARSV: case SAVEt_INT_SMALL: case SAVEt_DESTRUCTOR_X: #ifdef SAVEt_STRLEN case SAVEt_STRLEN: #endif case SAVEt_SET_SVFLAGS: /* Nothing interesting */ break; case SAVEt_FREEPV: /* This is interesting but a plain char* pointer so there's nothing * we can do with it in Devel::MAT */ break; case SAVEt_COMPPAD: ret += DMD_ANNOTATE_SV(sv, saved->cur.ptr, "a suspended SAVEt_COMPPAD"); break; case SAVEt_FREESV: ret += DMD_ANNOTATE_SV(sv, saved->saved.sv, "a suspended SAVEt_FREESV"); break; case SAVEt_SV: ret += DMD_ANNOTATE_SV(sv, (SV *)saved->u.gv, "a suspended SAVEt_SV target GV"); ret += DMD_ANNOTATE_SV(sv, saved->cur.sv, "a suspended SAVEt_SV current value"); ret += DMD_ANNOTATE_SV(sv, saved->saved.sv, "a suspended SAVEt_SV saved value"); break; case SAVEt_SPTR: ret += DMD_ANNOTATE_SV(sv, saved->cur.sv, "a suspended SAVEt_SPTR current value"); ret += DMD_ANNOTATE_SV(sv, saved->saved.sv, "a suspended SAVEt_SPTR saved value"); break; case SAVEt_PADSV_AND_MORTALIZE: ret += DMD_ANNOTATE_SV(sv, saved->cur.sv, "a suspended SAVEt_PADSV_AND_MORTALIZE current value"); ret += DMD_ANNOTATE_SV(sv, saved->saved.sv, "a suspended SAVEt_PADSV_AND_MORTALIZE saved value"); break; } } } if(state->padlen && state->padslots) { int i; for(i = 0; i < state->padlen - 1; i++) if(state->padslots[i]) ret += DMD_ANNOTATE_SV(sv, state->padslots[i], "a suspended pad slot"); } if(state->defav) ret += DMD_ANNOTATE_SV(sv, (SV *)state->defav, "the subroutine arguments AV"); if(state->modhookdata) ret += DMD_ANNOTATE_SV(sv, (SV *)state->modhookdata, "the module hook data HV"); return ret; } #endif #define suspendedstate_get(cv) MY_suspendedstate_get(aTHX_ cv) static SuspendedState *MY_suspendedstate_get(pTHX_ CV *cv) { MAGIC *magic; for(magic = mg_find((SV *)cv, PERL_MAGIC_ext); magic; magic = magic->mg_moremagic) if(magic->mg_type == PERL_MAGIC_ext && magic->mg_virtual == &vtbl_suspendedstate) return (SuspendedState *)magic->mg_ptr; return NULL; } #define suspendedstate_new(cv) MY_suspendedstate_new(aTHX_ cv) static SuspendedState *MY_suspendedstate_new(pTHX_ CV *cv) { SuspendedState *ret; Newx(ret, 1, SuspendedState); ret->awaiting_future = NULL; ret->returning_future = NULL; ret->frames = NULL; ret->padslots = NULL; ret->modhookdata = NULL; ret->defav = NULL; sv_magicext((SV *)cv, NULL, PERL_MAGIC_ext, &vtbl_suspendedstate, (char *)ret, 0); return ret; } static int suspendedstate_free(pTHX_ SV *sv, MAGIC *mg) { SuspendedState *state = (SuspendedState *)mg->mg_ptr; if(state->awaiting_future) { SvREFCNT_dec(state->awaiting_future); state->awaiting_future = NULL; } if(state->returning_future) { SvREFCNT_dec(state->returning_future); state->returning_future = NULL; } if(state->frames) { SuspendedFrame *frame, *next = state->frames; while((frame = next)) { next = frame->next; if(frame->stacklen) { /* The stack isn't refcounted, so we should not SvREFCNT_dec() these * items */ Safefree(frame->stack); } if(frame->marklen) { Safefree(frame->marks); } if(frame->saved) { int idx; for(idx = 0; idx < frame->savedlen; idx++) { struct Saved *saved = &frame->saved[idx]; switch(saved->type) { /* Saved types for which we've no cleanup needed */ #ifdef SAVEt_CLEARPADRANGE case SAVEt_CLEARPADRANGE: #endif case SAVEt_CLEARSV: case SAVEt_COMPPAD: case SAVEt_INT_SMALL: case SAVEt_DESTRUCTOR_X: #ifdef SAVEt_STRLEN case SAVEt_STRLEN: #endif case SAVEt_SET_SVFLAGS: break; case SAVEt_FREEPV: Safefree(saved->cur.ptr); break; case SAVEt_FREESV: SvREFCNT_dec(saved->saved.sv); break; case SAVEt_SV: SvREFCNT_dec(saved->u.gv); SvREFCNT_dec(saved->saved.sv); SvREFCNT_dec(saved->cur.sv); break; case SAVEt_PADSV_AND_MORTALIZE: SvREFCNT_dec(saved->saved.sv); SvREFCNT_dec(saved->cur.sv); break; case SAVEt_SPTR: SvREFCNT_dec(saved->saved.sv); /* saved->cur.sv does not account for an extra refcount */ break; default: { char *name = PL_savetype_name[saved->type]; if(name) fprintf(stderr, "TODO: free saved slot type SAVEt_%s=%d\n", name, saved->type); else fprintf(stderr, "TODO: free saved slot type UNKNOWN=%d\n", saved->type); break; } } } Safefree(frame->saved); } switch(frame->type) { case CXt_BLOCK: case CXt_LOOP_PLAIN: break; case CXt_LOOP_LAZYSV: SvREFCNT_dec(frame->el.loop.state_u.lazysv.cur); SvREFCNT_dec(frame->el.loop.state_u.lazysv.end); goto cxt_loop_common; #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_ARY: #else case CXt_LOOP_FOR: #endif if(frame->el.loop.state_u.ary.ary) SvREFCNT_dec(frame->el.loop.state_u.ary.ary); goto cxt_loop_common; case CXt_LOOP_LAZYIV: #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_LIST: #endif cxt_loop_common: #if !defined(HAVE_ITERVAR) SvREFCNT_dec(frame->el.loop.itersave); #endif break; } #ifdef HAVE_ITERVAR if(frame->itervar) { SvREFCNT_dec(frame->itervar); frame->itervar = NULL; } #endif if(frame->mortals) { int i; for(i = 0; i < frame->mortallen; i++) sv_2mortal(frame->mortals[i]); Safefree(frame->mortals); } Safefree(frame); } } if(state->padslots) { int i; for(i = 0; i < state->padlen - 1; i++) { if(state->padslots[i]) SvREFCNT_dec(state->padslots[i]); } Safefree(state->padslots); state->padslots = NULL; state->padlen = 0; } if(state->defav) { SvREFCNT_dec(state->defav); state->defav = NULL; } if(state->modhookdata) { struct HookRegistrations *regs = registrations(FALSE); /* New hooks first */ if(regs) RUN_HOOKS_REV(free, (CV *)sv, state->modhookdata); /* Legacy hooks after */ SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", FALSE); if(hookp && SvOK(*hookp) && SvUV(*hookp)) { warn("Invoking legacy Future::AsyncAwait suspendhook for FREE phase"); SuspendHookFunc *hook = INT2PTR(SuspendHookFunc *, SvUV(*hookp)); (*hook)(aTHX_ FAA_PHASE_FREE, (CV *)sv, state->modhookdata); } SvREFCNT_dec(state->modhookdata); } Safefree(state); return 1; } #define suspend_frame(frame, cx) MY_suspend_frame(aTHX_ frame, cx) static void MY_suspend_frame(pTHX_ SuspendedFrame *frame, PERL_CONTEXT *cx) { frame->stacklen = (I32)(PL_stack_sp - PL_stack_base) - cx->blk_oldsp; if(frame->stacklen) { SV **bp = PL_stack_base + cx->blk_oldsp + 1; I32 i; /* Steal SVs right off the stack */ Newx(frame->stack, frame->stacklen, SV *); for(i = 0; i < frame->stacklen; i++) { frame->stack[i] = bp[i]; bp[i] = NULL; } PL_stack_sp = PL_stack_base + cx->blk_oldsp; } frame->marklen = (I32)(PL_markstack_ptr - PL_markstack) - cx->blk_oldmarksp; if(frame->marklen) { I32 *markbase = PL_markstack + cx->blk_oldmarksp + 1; I32 i; Newx(frame->marks, frame->marklen, I32); for(i = 0; i < frame->marklen; i++) { /* Translate mark value relative to base */ I32 relmark = markbase[i] - cx->blk_oldsp; frame->marks[i] = relmark; } PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp; } frame->oldcop = cx->blk_oldcop; I32 old_saveix = OLDSAVEIX(cx); /* This is an over-estimate but it doesn't matter. We just waste a bit of RAM * temporarily */ I32 savedlen = PL_savestack_ix - old_saveix; if(savedlen) Newx(frame->saved, savedlen, struct Saved); else frame->saved = NULL; frame->savedlen = 0; /* we increment it as we fill it */ I32 oldtmpsfloor = -2; #if HAVE_PERL_VERSION(5, 24, 0) /* Perl 5.24 onwards has a PERL_CONTEXT slot for the old value of * PL_tmpsfloor. Older perls do not, and keep it in the save stack instead. * We'll keep an eye out for its saved value */ oldtmpsfloor = cx->blk_old_tmpsfloor; #endif while(PL_savestack_ix > old_saveix) { /* Useful references * scope.h * scope.c: Perl_leave_scope() */ UV uv = PL_savestack[PL_savestack_ix-1].any_uv; U8 type = (U8)uv & SAVE_MASK; struct Saved *saved = &frame->saved[frame->savedlen]; switch(type) { #ifdef SAVEt_CLEARPADRANGE case SAVEt_CLEARPADRANGE: { UV padix = uv >> (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT); I32 count = (uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK; PL_savestack_ix--; saved->type = count == 1 ? SAVEt_CLEARSV : SAVEt_CLEARPADRANGE; saved->u.clearpad.padix = padix; saved->u.clearpad.count = count; break; } #endif case SAVEt_CLEARSV: { UV padix = (uv >> SAVE_TIGHT_SHIFT); PL_savestack_ix--; saved->type = SAVEt_CLEARSV; saved->u.clearpad.padix = padix; break; } case SAVEt_COMPPAD: { /* This occurs as a side-effect of Perl_pad_new on 5.22 */ PL_savestack_ix -= 2; void *pad = PL_savestack[PL_savestack_ix].any_ptr; saved->type = SAVEt_COMPPAD; saved->saved.ptr = pad; saved->cur.ptr = PL_comppad; PL_comppad = pad; PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; break; } case SAVEt_FREEPV: { PL_savestack_ix -= 2; char *pv = PL_savestack[PL_savestack_ix].any_ptr; saved->type = SAVEt_FREEPV; saved->saved.ptr = pv; break; } case SAVEt_FREESV: { PL_savestack_ix -= 2; void *sv = PL_savestack[PL_savestack_ix].any_ptr; saved->type = SAVEt_FREESV; saved->saved.sv = sv; break; } case SAVEt_INT_SMALL: { PL_savestack_ix -= 2; int val = ((int)uv >> SAVE_TIGHT_SHIFT); int *var = PL_savestack[PL_savestack_ix].any_ptr; /* In general we don't want to support this; but specifically on perls * older than 5.20, this might be PL_tmps_floor */ if(var == (int *)&PL_tmps_floor) { /* Don't bother to save the old tmpsfloor as we'll SAVETMPS again * later if we need to */ oldtmpsfloor = val; goto nosave; } panic("TODO: Unsure how to handle a savestack entry of SAVEt_INT_SMALL with var != &PL_tmps_floor\n"); break; } case SAVEt_DESTRUCTOR_X: { /* This is only known to be used by Syntax::Keyword::Try to implement * finally blocks. It may be found elsewhere for which this code is * unsafe, but detecting such cases is generally impossible. Good luck. */ PL_savestack_ix -= 3; void (*func)(pTHX_ void *) = PL_savestack[PL_savestack_ix].any_dxptr; void *data = PL_savestack[PL_savestack_ix+1].any_ptr; saved->type = SAVEt_DESTRUCTOR_X; saved->u.dx.func = func; saved->u.dx.data = data; break; } case SAVEt_ITEM: { PL_savestack_ix -= 3; SV *var = PL_savestack[PL_savestack_ix].any_ptr; SV *val = PL_savestack[PL_savestack_ix+1].any_ptr; saved->type = SAVEt_ITEM; saved->u.sv = var; saved->cur.sv = newSVsv(var); saved->saved.sv = val; /* restore it for now */ sv_setsv(var, val); break; } case SAVEt_SPTR: { PL_savestack_ix -= 3; SV *val = PL_savestack[PL_savestack_ix].any_ptr; SV **var = PL_savestack[PL_savestack_ix+1].any_ptr; /* In general we don't support this; but specifically we will accept * it if we can convert var into a PAD index. This is to support * SAVESPTR(PAD_SVl(padix)), as may be used by Object::Pad or others */ if(var < PL_curpad || var > PL_curpad + AvFILL(PL_comppad)) panic("TODO: Unsure how to handle a savestack entry of SAVEt_SPTR with var not the current pad\n"); PADOFFSET padix = var - PL_curpad; saved->type = SAVEt_SPTR; saved->u.padix = padix; saved->cur.sv = PL_curpad[padix]; /* steal ownership */ saved->saved.sv = val; /* steal ownership */ /* restore it for now */ PL_curpad[padix] = SvREFCNT_inc(val); break; } #ifdef SAVEt_STRLEN case SAVEt_STRLEN: { PL_savestack_ix -= 3; STRLEN val = PL_savestack[PL_savestack_ix].any_iv; STRLEN *var = PL_savestack[PL_savestack_ix+1].any_ptr; /* In general we don't want to support this; but specifically on perls * older than 5.24, this might be PL_tmps_floor */ if(var == (STRLEN *)&PL_tmps_floor) { /* Don't bother to save the old tmpsfloor as we'll SAVETMPS again * later if we need to */ oldtmpsfloor = val; goto nosave; } panic("TODO: Unsure how to handle a savestack entry of SAVEt_STRLEN with var != &PL_tmps_floor\n"); break; } #endif case SAVEt_SV: { PL_savestack_ix -= 3; /* despite being called SAVEt_SV, the first field actually points at * the GV containing the local'ised SV */ GV *gv = PL_savestack[PL_savestack_ix ].any_ptr; SV *val = PL_savestack[PL_savestack_ix+1].any_ptr; /* In general we don't want to support local $VAR. However, a special * case of local $@ is allowable * See also https://rt.cpan.org/Ticket/Display.html?id=122793 */ if(gv != PL_errgv) { const char *name = GvNAME(gv); const char *stashname = HvNAME(GvSTASH(gv)); if(name && stashname) panic("TODO: Unsure how to handle a savestack entry of SAVEt_SV with gv != PL_errgv ($%s::%s)\n", stashname, name); else panic("TODO: Unsure how to handle a savestack entry of SAVEt_SV with gv != PL_errgv\n"); } saved->type = SAVEt_SV; saved->u.gv = gv; saved->cur.sv = GvSV(gv); /* steal ownership */ saved->saved.sv = val; /* steal ownership */ /* restore it for now */ GvSV(gv) = val; break; } case SAVEt_PADSV_AND_MORTALIZE: { PL_savestack_ix -= 4; SV *val = PL_savestack[PL_savestack_ix ].any_ptr; AV *padav = PL_savestack[PL_savestack_ix+1].any_ptr; PADOFFSET padix = PL_savestack[PL_savestack_ix+2].any_uv; if(padav != PL_comppad) panic("TODO: Unsure how to handle a savestack entry of SAVEt_PADSV_AND_MORTALIZE with padav != PL_comppad\n"); SvREFCNT_inc(PL_curpad[padix]); /* un-mortalize */ saved->type = SAVEt_PADSV_AND_MORTALIZE; saved->u.padix = padix; saved->cur.sv = PL_curpad[padix]; /* steal ownership */ saved->saved.sv = val; /* steal ownership */ AvARRAY(padav)[padix] = SvREFCNT_inc(val); break; } case SAVEt_SET_SVFLAGS: { PL_savestack_ix -= 4; SV *sv = PL_savestack[PL_savestack_ix ].any_ptr; U32 mask = (U32)PL_savestack[PL_savestack_ix+1].any_i32; U32 set = (U32)PL_savestack[PL_savestack_ix+2].any_i32; saved->type = SAVEt_SET_SVFLAGS; saved->u.svflags.sv = sv; saved->u.svflags.mask = mask; saved->u.svflags.set = set; break; } default: { char *name = PL_savetype_name[type]; if(name) panic("TODO: Unsure how to handle savestack entry of SAVEt_%s=%d\n", name, type); else panic("TODO: Unsure how to handle savestack entry of UNKNOWN=%d\n", type); } } frame->savedlen++; nosave: ; } if(OLDSAVEIX(cx) != PL_savestack_ix) panic("TODO: handle OLDSAVEIX\n"); frame->scopes = (PL_scopestack_ix - cx->blk_oldscopesp) + 1; if(frame->scopes) { /* We'll mutate PL_scopestack_ix but it doesn't matter as dounwind() will * put it right at the end. Do this unconditionally to avoid divergent * behaviour between -DDEBUGGING builds and non. */ PL_scopestack_ix -= frame->scopes; } /* ref: * https://perl5.git.perl.org/perl.git/blob/HEAD:/cop.h */ U8 type = CxTYPE(cx); switch(type) { case CXt_BLOCK: frame->type = CXt_BLOCK; frame->gimme = cx->blk_gimme; /* nothing else special */ break; case CXt_LOOP_PLAIN: frame->type = type; frame->el.loop = cx->blk_loop; frame->gimme = cx->blk_gimme; break; #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_ARY: case CXt_LOOP_LIST: #else case CXt_LOOP_FOR: #endif case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: if(!CxPADLOOP(cx)) /* non-lexical foreach will effectively work like 'local' and we * can't really support local */ croak("Cannot suspend a foreach loop on non-lexical iterator"); frame->type = type; frame->el.loop = cx->blk_loop; frame->gimme = cx->blk_gimme; #ifdef HAVE_ITERVAR # ifdef USE_ITHREADS if(cx->blk_loop.itervar_u.svp != (SV **)PL_comppad) panic("TODO: Unsure how to handle a foreach loop with itervar != PL_comppad\n"); # else if(cx->blk_loop.itervar_u.svp != &PAD_SVl(cx->blk_loop.my_op->op_targ)) panic("TODO: Unsure how to handle a foreach loop with itervar != PAD_SVl(op_targ))\n"); # endif frame->itervar = SvREFCNT_inc(*CxITERVAR(cx)); #else if(CxITERVAR(cx) != &PAD_SVl(cx->blk_loop.my_op->op_targ)) panic("TODO: Unsure how to handle a foreach loop with itervar != PAD_SVl(op_targ))\n"); SvREFCNT_inc(cx->blk_loop.itersave); #endif switch(type) { case CXt_LOOP_LAZYSV: /* these two fields are refcounted, so we need to save them from * dounwind() throwing them away */ SvREFCNT_inc(frame->el.loop.state_u.lazysv.cur); SvREFCNT_inc(frame->el.loop.state_u.lazysv.end); break; #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_ARY: #else case CXt_LOOP_FOR: /* The ix field stores an absolute stack height as offset from * PL_stack_base directly. When we get resumed the stack will * probably not be the same absolute height at this point, so we'll * have to store them relative to something fixed. */ if(!cx->blk_loop.state_u.ary.ary) { I32 height = PL_stack_sp - PL_stack_base; frame->el.loop.state_u.ary.ix = height - frame->el.loop.state_u.ary.ix; } #endif /* this field is also refcounted, so we need to save it too */ if(frame->el.loop.state_u.ary.ary) SvREFCNT_inc(frame->el.loop.state_u.ary.ary); break; #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_LIST: { /* The various fields in the context structure store absolute stack * heights as offsets from PL_stack_base directly. When we get * resumed the stack will probably not be the same absolute height * at this point, so we'll have to store them relative to something * fixed. * We'll adjust them to be upside-down, counting -backwards- from * the current stack height. */ I32 height = PL_stack_sp - PL_stack_base; if(cx->blk_oldsp != height) panic("ARGH suspending CXt_LOOP_LIST frame with blk_oldsp != stack height\n"); /* First item is at [1] oddly, not [0] */ frame->loop_list_first_item = PL_stack_base[cx->blk_loop.state_u.stack.basesp+1]; frame->el.loop.state_u.stack.basesp = height - frame->el.loop.state_u.stack.basesp; frame->el.loop.state_u.stack.ix = height - frame->el.loop.state_u.stack.ix; break; } #endif } break; case CXt_EVAL: { if(!(cx->cx_type & CXp_TRYBLOCK)) panic("TODO: handle CXt_EVAL without CXp_TRYBLOCK\n"); if(cx->blk_eval.old_namesv) panic("TODO: handle cx->blk_eval.old_namesv\n"); if(cx->blk_eval.cv) panic("TODO: handle cx->blk_eval.cv\n"); if(cx->blk_eval.cur_top_env != PL_top_env) panic("TODO: handle cx->blk_eval.cur_top_env\n"); /* * It seems we don't need to care about blk_eval.old_eval_root or * blk_eval.cur_text, and if we ignore these then it works fine via * string eval(). * https://rt.cpan.org/Ticket/Display.html?id=126036 */ frame->type = CXt_EVAL; frame->gimme = cx->blk_gimme; #ifdef HAVE_CX_TRY if(CxTRY(cx)) frame->type |= CXp_TRY; #endif frame->el.eval.retop = cx->blk_eval.retop; break; } default: panic("TODO: unsure how to handle a context frame of type %d\n", CxTYPE(cx)); } frame->mortallen = 0; frame->mortals = NULL; if(oldtmpsfloor == -2) { /* Don't worry about it; the next level down will save us */ } else { /* Save the mortals! */ SV **tmpsbase = PL_tmps_stack + PL_tmps_floor + 1; I32 i; frame->mortallen = (I32)(PL_tmps_ix - PL_tmps_floor); if(frame->mortallen) { Newx(frame->mortals, frame->mortallen, SV *); for(i = 0; i < frame->mortallen; i++) { frame->mortals[i] = tmpsbase[i]; tmpsbase[i] = NULL; } } PL_tmps_ix = PL_tmps_floor; PL_tmps_floor = oldtmpsfloor; } } #define suspendedstate_suspend(state, cv) MY_suspendedstate_suspend(aTHX_ state, cv) static void MY_suspendedstate_suspend(pTHX_ SuspendedState *state, CV *cv) { I32 cxix; PADOFFSET padnames_max, pad_max, i; PADLIST *plist; PADNAME **padnames; PAD *pad; SV **padsvs; state->frames = NULL; for(cxix = cxstack_ix; cxix; cxix--) { PERL_CONTEXT *cx = &cxstack[cxix]; if(CxTYPE(cx) == CXt_SUB) break; SuspendedFrame *frame; Newx(frame, 1, SuspendedFrame); frame->next = state->frames; state->frames = frame; #ifdef HAVE_ITERVAR frame->itervar = NULL; #endif suspend_frame(frame, cx); } /* Now steal the lexical SVs from the PAD */ plist = CvPADLIST(cv); padnames = PadnamelistARRAY(PadlistNAMES(plist)); padnames_max = PadnamelistMAX(PadlistNAMES(plist)); pad = PadlistARRAY(plist)[CvDEPTH(cv)]; pad_max = PadMAX(pad); padsvs = PadARRAY(pad); state->padlen = PadMAX(pad) + 1; Newx(state->padslots, state->padlen - 1, SV *); /* slot 0 is always the @_ AV */ for(i = 1; i <= pad_max; i++) { PADNAME *pname = (i <= padnames_max) ? padnames[i] : NULL; if(!padname_is_normal_lexical(pname)) { state->padslots[i-1] = NULL; continue; } if(PadnameIsSTATE(pname)) { state->padslots[i-1] = SvREFCNT_inc(padsvs[i]); } else { /* Don't fiddle refcount */ state->padslots[i-1] = padsvs[i]; switch(PadnamePV(pname)[0]) { case '@': padsvs[i] = MUTABLE_SV(newAV()); break; case '%': padsvs[i] = MUTABLE_SV(newHV()); break; case '$': padsvs[i] = newSV(0); break; default: panic("TODO: unsure how to steal and switch pad slot with pname %s\n", PadnamePV(pname)); } SvPADMY_on(padsvs[i]); } } if(PL_curpm) state->curpm = PL_curpm; else state->curpm = NULL; #if !HAVE_PERL_VERSION(5, 24, 0) /* perls before v5.24 will crash if we try to do this at all */ if(0) #elif HAVE_PERL_VERSION(5, 36, 0) /* perls 5.36 onwards have CvSIGNATURE; we don't need to bother doing this * inside signatured subs */ if(!CvSIGNATURE(cv)) #endif /* on perl versions between those, just do it unconditionally */ { state->defav = GvAV(PL_defgv); /* steal */ AV *av = GvAV(PL_defgv) = newAV(); AvREAL_off(av); if(PAD_SVl(0) == (SV *)state->defav) { /* Steal that one too */ SvREFCNT_dec(PAD_SVl(0)); PAD_SVl(0) = SvREFCNT_inc(av); } } dounwind(cxix); } #define resume_frame(frame, cx) MY_resume_frame(aTHX_ frame) static void MY_resume_frame(pTHX_ SuspendedFrame *frame) { I32 i; PERL_CONTEXT *cx; I32 was_scopestack_ix = PL_scopestack_ix; switch(frame->type) { case CXt_BLOCK: #if !HAVE_PERL_VERSION(5, 24, 0) ENTER_with_name("block"); SAVETMPS; #endif cx = cx_pushblock(CXt_BLOCK, frame->gimme, PL_stack_sp, PL_savestack_ix); /* nothing else special */ break; case CXt_LOOP_PLAIN: #if !HAVE_PERL_VERSION(5, 24, 0) ENTER_with_name("loop1"); SAVETMPS; ENTER_with_name("loop2"); #endif cx = cx_pushblock(frame->type, frame->gimme, PL_stack_sp, PL_savestack_ix); /* don't call cx_pushloop_plain() because it will get this wrong */ cx->blk_loop = frame->el.loop; break; #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_ARY: case CXt_LOOP_LIST: #else case CXt_LOOP_FOR: #endif case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: #if !HAVE_PERL_VERSION(5, 24, 0) ENTER_with_name("loop1"); SAVETMPS; ENTER_with_name("loop2"); #endif cx = cx_pushblock(frame->type, frame->gimme, PL_stack_sp, PL_savestack_ix); /* don't call cx_pushloop_plain() because it will get this wrong */ cx->blk_loop = frame->el.loop; #if HAVE_PERL_VERSION(5, 24, 0) cx->cx_type |= CXp_FOR_PAD; #endif #ifdef HAVE_ITERVAR # ifdef USE_ITHREADS cx->blk_loop.itervar_u.svp = (SV **)PL_comppad; # else cx->blk_loop.itervar_u.svp = &PAD_SVl(cx->blk_loop.my_op->op_targ); # endif SvREFCNT_dec(*CxITERVAR(cx)); *CxITERVAR(cx) = frame->itervar; frame->itervar = NULL; #else cx->blk_loop.itervar_u.svp = &PAD_SVl(cx->blk_loop.my_op->op_targ); #endif break; case CXt_EVAL: if(CATCH_GET) panic("Too late to docatch()\n"); #if !HAVE_PERL_VERSION(5, 24, 0) ENTER_with_name("eval_scope"); SAVETMPS; #endif cx = cx_pushblock(CXt_EVAL|CXp_TRYBLOCK, frame->gimme, PL_stack_sp, PL_savestack_ix); cx_pusheval(cx, frame->el.eval.retop, NULL); PL_in_eval = EVAL_INEVAL; CLEAR_ERRSV(); break; #ifdef HAVE_CX_TRY case CXt_EVAL|CXp_TRY: if(CATCH_GET) panic("Too late to docatch()\n"); cx = cx_pushblock(CXt_EVAL|CXp_EVALBLOCK|CXp_TRY, frame->gimme, PL_stack_sp, PL_savestack_ix); cx_pushtry(cx, frame->el.eval.retop); PL_in_eval = EVAL_INEVAL; CLEAR_ERRSV(); break; #endif default: panic("TODO: Unsure how to restore a %d frame\n", frame->type); } if(frame->stacklen) { dSP; EXTEND(SP, frame->stacklen); for(i = 0; i < frame->stacklen; i++) { PUSHs(frame->stack[i]); } Safefree(frame->stack); PUTBACK; } if(frame->marklen) { for(i = 0; i < frame->marklen; i++) { I32 absmark = frame->marks[i] + cx->blk_oldsp; PUSHMARK(PL_stack_base + absmark); } Safefree(frame->marks); } cx->blk_oldcop = frame->oldcop; for(i = frame->savedlen - 1; i >= 0; i--) { struct Saved *saved = &frame->saved[i]; switch(saved->type) { case SAVEt_CLEARSV: save_clearsv(PL_curpad + saved->u.clearpad.padix); break; #ifdef SAVEt_CLEARPADRANGE case SAVEt_CLEARPADRANGE: save_clearpadrange(saved->u.clearpad.padix, saved->u.clearpad.count); break; #endif case SAVEt_DESTRUCTOR_X: save_pushptrptr(saved->u.dx.func, saved->u.dx.data, saved->type); break; case SAVEt_COMPPAD: PL_comppad = saved->saved.ptr; save_pushptr(PL_comppad, saved->type); PL_comppad = saved->cur.ptr; PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; break; case SAVEt_FREEPV: save_freepv(saved->saved.ptr); break; case SAVEt_FREESV: save_freesv(saved->saved.sv); break; case SAVEt_INT: *(saved->u.iptr) = saved->saved.i; save_int(saved->u.iptr); *(saved->u.iptr) = saved->cur.i; break; case SAVEt_SV: save_pushptrptr(saved->u.gv, SvREFCNT_inc(saved->saved.sv), SAVEt_SV); SvREFCNT_dec(GvSV(saved->u.gv)); GvSV(saved->u.gv) = saved->cur.sv; break; case SAVEt_ITEM: save_pushptrptr(saved->u.sv, saved->saved.sv, SAVEt_ITEM); sv_setsv(saved->u.sv, saved->cur.sv); SvREFCNT_dec(saved->cur.sv); break; case SAVEt_SPTR: PL_curpad[saved->u.padix] = saved->saved.sv; SAVESPTR(PL_curpad[saved->u.padix]); SvREFCNT_dec(PL_curpad[saved->u.padix]); PL_curpad[saved->u.padix] = saved->cur.sv; break; #ifdef SAVEt_STRLEN case SAVEt_STRLEN: *(saved->u.lenptr) = saved->saved.len; Perl_save_strlen(aTHX_ saved->u.lenptr); *(saved->u.lenptr) = saved->cur.len; break; #endif case SAVEt_PADSV_AND_MORTALIZE: PL_curpad[saved->u.padix] = saved->saved.sv; save_padsv_and_mortalize(saved->u.padix); SvREFCNT_dec(PL_curpad[saved->u.padix]); PL_curpad[saved->u.padix] = saved->cur.sv; break; case SAVEt_SET_SVFLAGS: /* save_set_svflags(saved->u.svflags.sv, saved->u.svflags.mask, saved->u.svflags.set); */ break; default: panic("TODO: Unsure how to restore a %d savestack entry\n", saved->type); } } if(frame->saved) Safefree(frame->saved); if(frame->scopes) { #ifdef DEBUG if(PL_scopestack_ix - was_scopestack_ix < frame->scopes) { fprintf(stderr, "TODO ARG still more scopes to ENTER\n"); } #endif } if(frame->mortallen) { for(i = 0; i < frame->mortallen; i++) { sv_2mortal(frame->mortals[i]); } Safefree(frame->mortals); frame->mortals = NULL; } switch(frame->type) { #if !HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_FOR: if(!cx->blk_loop.state_u.ary.ary) { I32 height = PL_stack_sp - PL_stack_base - frame->stacklen; cx->blk_loop.state_u.ary.ix = height - cx->blk_loop.state_u.ary.ix; } break; #endif #if HAVE_PERL_VERSION(5, 24, 0) case CXt_LOOP_LIST: { I32 height = PL_stack_sp - PL_stack_base - frame->stacklen; cx->blk_loop.state_u.stack.basesp = height - cx->blk_loop.state_u.stack.basesp; cx->blk_loop.state_u.stack.ix = height - cx->blk_loop.state_u.stack.ix; /* For consistency; check that the first SV in the list is in the right * place. If so we presume the others are */ if(PL_stack_base[cx->blk_loop.state_u.stack.basesp+1] == frame->loop_list_first_item) break; /* First item is at [1] oddly, not [0] */ #ifdef debug_sv_summary fprintf(stderr, "F:AA: consistency check resume LOOP_LIST with first=%p:", frame->loop_list_first_item); debug_sv_summary(frame->loop_list_first_item); fprintf(stderr, " stackitem=%p:", PL_stack_base[frame->el.loop.state_u.stack.basesp + 1]); debug_sv_summary(PL_stack_base[frame->el.loop.state_u.stack.basesp]); fprintf(stderr, "\n"); #endif panic("ARGH CXt_LOOP_LIST consistency check failed\n"); break; } #endif } } #define suspendedstate_resume(state, cv) MY_suspendedstate_resume(aTHX_ state, cv) static void MY_suspendedstate_resume(pTHX_ SuspendedState *state, CV *cv) { I32 i; if(state->padlen) { PAD *pad = PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)]; PADOFFSET i; /* slot 0 is always the @_ AV */ for(i = 1; i < state->padlen; i++) { if(!state->padslots[i-1]) continue; SvREFCNT_dec(PadARRAY(pad)[i]); PadARRAY(pad)[i] = state->padslots[i-1]; } Safefree(state->padslots); state->padslots = NULL; state->padlen = 0; } SuspendedFrame *frame, *next; for(frame = state->frames; frame; frame = next) { next = frame->next; resume_frame(frame, cx); Safefree(frame); } state->frames = NULL; if(state->curpm) PL_curpm = state->curpm; if(state->defav) { SvREFCNT_dec(GvAV(PL_defgv)); SvREFCNT_dec(PAD_SVl(0)); GvAV(PL_defgv) = state->defav; PAD_SVl(0) = SvREFCNT_inc((SV *)state->defav); state->defav = NULL; } } #define suspendedstate_cancel(state) MY_suspendedstate_cancel(aTHX_ state) static void MY_suspendedstate_cancel(pTHX_ SuspendedState *state) { SuspendedFrame *frame; for(frame = state->frames; frame; frame = frame->next) { I32 i; for(i = frame->savedlen - 1; i >= 0; i--) { struct Saved *saved = &frame->saved[i]; switch(saved->type) { case SAVEt_DESTRUCTOR_X: /* We have to run destructors to ensure that defer {} and try/finally * work correctly * https://rt.cpan.org/Ticket/Display.html?id=135351 */ (*saved->u.dx.func)(aTHX_ saved->u.dx.data); break; } } } } /* * Pre-creation assistance */ enum { PRECREATE_CANCEL, PRECREATE_MODHOOKDATA, }; #define get_precreate_padix() S_get_precreate_padix(aTHX) PADOFFSET S_get_precreate_padix(pTHX) { return SvUV(SvRV(*hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/*precreate_padix", 0))); } #define get_or_create_precreate_padix() S_get_or_create_precreate_padix(aTHX) PADOFFSET S_get_or_create_precreate_padix(pTHX) { SV *sv; PADOFFSET padix = SvUV(sv = SvRV(*hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/*precreate_padix", 0))); if(!padix) { padix = pad_add_name_pvs("@(Future::AsyncAwait/precancel)", 0, NULL, NULL); sv_setuv(sv, padix); PADOFFSET p2 = pad_add_name_pvs("%(Future::AsyncAwait/premodhookdata)", 0, NULL, NULL); assert(p2 == padix + PRECREATE_MODHOOKDATA); } return padix; } /* * Some Future class helper functions */ #define future_classname() MY_future_classname(aTHX) static SV *MY_future_classname(pTHX) { /* cop_hints_fetch_* return a mortal copy so this is fine */ SV *class = cop_hints_fetch_pvs(PL_curcop, "Future::AsyncAwait/future", 0); if(class == &PL_sv_placeholder) class = sv_2mortal(newSVpvn("Future", 6)); return class; } #define future_done_from_stack(f, mark) MY_future_done_from_stack(aTHX_ f, mark) static SV *MY_future_done_from_stack(pTHX_ SV *f, SV **mark) { dSP; SV **svp; EXTEND(SP, 1); ENTER_with_name("future_done_from_stack"); SAVETMPS; PUSHMARK(mark); SV **bottom = mark + 1; const char *method; /* splice the class name 'Future' in to the start of the stack */ for (svp = SP; svp >= bottom; svp--) { *(svp+1) = *svp; } if(f) { assert(SvROK(f)); *bottom = f; method = "AWAIT_DONE"; } else { *bottom = future_classname(); method = "AWAIT_NEW_DONE"; } SP++; PUTBACK; call_method(method, G_SCALAR); SPAGAIN; SV *ret = SvREFCNT_inc(POPs); FREETMPS; LEAVE_with_name("future_done_from_stack"); return ret; } #define future_fail(f, failure) MY_future_fail(aTHX_ f, failure) static SV *MY_future_fail(pTHX_ SV *f, SV *failure) { dSP; ENTER_with_name("future_fail"); SAVETMPS; const char *method; PUSHMARK(SP); if(f) { assert(SvROK(f)); PUSHs(f); method = "AWAIT_FAIL"; } else { PUSHs(future_classname()); method = "AWAIT_NEW_FAIL"; } mPUSHs(newSVsv(failure)); PUTBACK; call_method(method, G_SCALAR); SPAGAIN; SV *ret = SvREFCNT_inc(POPs); FREETMPS; LEAVE_with_name("future_fail"); return ret; } #define future_new_from_proto(proto) MY_future_new_from_proto(aTHX_ proto) static SV *MY_future_new_from_proto(pTHX_ SV *proto) { assert(SvROK(proto)); dSP; ENTER_with_name("future_new_from_proto"); SAVETMPS; PUSHMARK(SP); PUSHs(proto); PUTBACK; call_method("AWAIT_CLONE", G_SCALAR); SPAGAIN; SV *f = SvREFCNT_inc(POPs); FREETMPS; LEAVE_with_name("future_new_from_proto"); if(!SvROK(f)) croak("Expected Future->new to yield a new reference"); assert(SvREFCNT(f) == 1); assert(SvREFCNT(SvRV(f)) == 1); return f; } #define future_is_ready(f) MY_future_check(aTHX_ f, "AWAIT_IS_READY") #define future_is_cancelled(f) MY_future_check(aTHX_ f, "AWAIT_IS_CANCELLED") static bool MY_future_check(pTHX_ SV *f, const char *method) { dSP; if(!f || !SvOK(f)) panic("ARGH future_check() on undefined value\n"); if(!SvROK(f)) panic("ARGH future_check() on non-reference\n"); ENTER_with_name("future_check"); SAVETMPS; PUSHMARK(SP); EXTEND(SP, 1); PUSHs(f); PUTBACK; call_method(method, G_SCALAR); SPAGAIN; bool ret = SvTRUEx(POPs); PUTBACK; FREETMPS; LEAVE_with_name("future_check"); return ret; } #define future_get_to_stack(f, gimme) MY_future_get_to_stack(aTHX_ f, gimme) static void MY_future_get_to_stack(pTHX_ SV *f, I32 gimme) { dSP; ENTER_with_name("future_get_to_stack"); PUSHMARK(SP); EXTEND(SP, 1); PUSHs(f); PUTBACK; call_method("AWAIT_GET", gimme); LEAVE_with_name("future_get_to_stack"); } #define future_on_ready(f, code) MY_future_on_ready(aTHX_ f, code) static void MY_future_on_ready(pTHX_ SV *f, CV *code) { dSP; ENTER_with_name("future_on_ready"); SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(f); mPUSHs(newRV_inc((SV *)code)); PUTBACK; call_method("AWAIT_ON_READY", G_VOID); FREETMPS; LEAVE_with_name("future_on_ready"); } #define future_on_cancel(f, code) MY_future_on_cancel(aTHX_ f, code) static void MY_future_on_cancel(pTHX_ SV *f, SV *code) { dSP; ENTER_with_name("future_on_cancel"); SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(f); mPUSHs(code); PUTBACK; call_method("AWAIT_ON_CANCEL", G_VOID); FREETMPS; LEAVE_with_name("future_on_cancel"); } #define future_chain_on_cancel(f1, f2) MY_future_chain_on_cancel(aTHX_ f1, f2) static void MY_future_chain_on_cancel(pTHX_ SV *f1, SV *f2) { dSP; ENTER_with_name("future_chain_on_cancel"); SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(f1); PUSHs(f2); PUTBACK; call_method("AWAIT_CHAIN_CANCEL", G_VOID); FREETMPS; LEAVE_with_name("future_chain_on_cancel"); } #define future_await_toplevel(f) MY_future_await_toplevel(aTHX_ f) static void MY_future_await_toplevel(pTHX_ SV *f) { dSP; ENTER_with_name("future_await_toplevel"); PUSHMARK(SP); EXTEND(SP, 1); PUSHs(f); PUTBACK; call_method("AWAIT_WAIT", GIMME_V); LEAVE_with_name("future_await_toplevel"); } /* * API functions */ static HV *get_modhookdata(pTHX_ CV *cv, U32 flags, PADOFFSET precreate_padix) { SuspendedState *state = suspendedstate_get(cv); if(!state) { if(!precreate_padix) return NULL; if(!(flags & FAA_MODHOOK_CREATE)) return NULL; return (HV *)PAD_SVl(precreate_padix + PRECREATE_MODHOOKDATA); } if((flags & FAA_MODHOOK_CREATE) && !state->modhookdata) state->modhookdata = newHV(); return state->modhookdata; } /* * Custom ops */ static XOP xop_enterasync; static OP *pp_enterasync(pTHX) { PADOFFSET precreate_padix = PL_op->op_targ; if(precreate_padix) { save_clearsv(&PAD_SVl(precreate_padix + PRECREATE_CANCEL)); save_clearsv(&PAD_SVl(precreate_padix + PRECREATE_MODHOOKDATA)); } return PL_op->op_next; } static XOP xop_leaveasync; static OP *pp_leaveasync(pTHX) { dSP; dMARK; SV *f = NULL; SV *ret = NULL; SuspendedState *state = suspendedstate_get(find_runcv(0)); if(state && state->returning_future) { f = state->returning_future; state->returning_future = NULL; } if(f && !SvROK(f)) { /* async sub was abandoned. We just have to tidy up a bit and finish */ if(SvTRUE(ERRSV)) { /* This error will otherwise go unreported; best we can do is warn() it */ CV *curcv = find_runcv(0); GV *gv = CvGV(curcv); if(!CvANON(curcv)) warn("Abandoned async sub %s::%s failed: %" SVf, HvNAME(GvSTASH(gv)), GvNAME(gv), SVfARG(ERRSV)); else warn("Abandoned async sub CODE(0x%p) in package %s failed: %" SVf, curcv, HvNAME(GvSTASH(gv)), SVfARG(ERRSV)); } goto abort; } if(SvTRUE(ERRSV)) { ret = future_fail(f, ERRSV); } else { ret = future_done_from_stack(f, mark); } SPAGAIN; abort: ; /* statement to keep C compilers happy */ PERL_CONTEXT *cx = CX_CUR(); SV **oldsp = PL_stack_base + cx->blk_oldsp; /* Pop extraneous stack items */ while(SP > oldsp) POPs; if(ret) { EXTEND(SP, 1); mPUSHs(ret); PUTBACK; } if(f) SvREFCNT_dec(f); return PL_op->op_next; } static XOP xop_await; static OP *pp_await(pTHX) { /* We arrive here in either of two cases: * 1) Normal code flow has executed an 'await F' expression * 2) A previous await operation is resuming * Distinguish which by inspecting the state (if any) of the suspended context * magic on the containing CV */ dSP; SV *f; CV *curcv = find_runcv(0); CV *origcv = curcv; bool defer_mortal_curcv = FALSE; PADOFFSET precreate_padix = PL_op->op_targ; /* Must fetch precancel AV now, before any pad fiddling or cv copy */ AV *precancel = precreate_padix ? (AV *)PAD_SVl(precreate_padix + PRECREATE_CANCEL) : NULL; SuspendedState *state = suspendedstate_get(curcv); if(state && state->awaiting_future && CATCH_GET) { /* If we don't do this we get all the mess that is * https://rt.cpan.org/Ticket/Display.html?id=126037 */ return docatch(pp_await); } struct HookRegistrations *regs = registrations(FALSE); if(state && state->curcop) PL_curcop = state->curcop; TRACEPRINT("ENTER await curcv=%p [%s:%d]\n", curcv, CopFILE(PL_curcop), CopLINE(PL_curcop)); if(state) TRACEPRINT(" (state=%p/{awaiting_future=%p, returning_future=%p})\n", state, state->awaiting_future, state->returning_future); else TRACEPRINT(" (no state)\n"); if(state) { if(!SvROK(state->returning_future) || future_is_cancelled(state->returning_future)) { if(!SvROK(state->returning_future)) { GV *gv = CvGV(curcv); if(!CvANON(curcv)) warn("Suspended async sub %s::%s lost its returning future", HvNAME(GvSTASH(gv)), GvNAME(gv)); else warn("Suspended async sub CODE(0x%p) in package %s lost its returning future", curcv, HvNAME(GvSTASH(gv))); } TRACEPRINT(" CANCELLED\n"); suspendedstate_cancel(state); PUSHMARK(SP); PUTBACK; return PL_ppaddr[OP_RETURN](aTHX); } } if(state && state->awaiting_future) { I32 orig_height; TRACEPRINT(" RESUME\n"); f = state->awaiting_future; sv_2mortal(state->awaiting_future); state->awaiting_future = NULL; /* Before we restore the stack we first need to POP the caller's * arguments, as we don't care about those */ orig_height = CX_CUR()->blk_oldsp; while(sp > PL_stack_base + orig_height) POPs; PUTBACK; /* We also need to clean up the markstack and insert a new mark at the * beginning */ orig_height = CX_CUR()->blk_oldmarksp; while(PL_markstack_ptr > PL_markstack + orig_height) POPMARK; PUSHMARK(SP); /* Legacy ones first */ { SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", FALSE); if(hookp && SvOK(*hookp) && SvUV(*hookp)) { warn("Invoking legacy Future::AsyncAwait suspendhook for PRERESUME phase"); SuspendHookFunc *hook = INT2PTR(SuspendHookFunc *, SvUV(*hookp)); if(!state->modhookdata) state->modhookdata = newHV(); (*hook)(aTHX_ FAA_PHASE_PRERESUME, curcv, state->modhookdata); } } /* New ones after */ if(regs) RUN_HOOKS_REV(pre_resume, curcv, state->modhookdata); suspendedstate_resume(state, curcv); if(regs) RUN_HOOKS_FWD(post_resume, curcv, state->modhookdata); #ifdef DEBUG_SHOW_STACKS debug_showstack("Stack after resume"); #endif } else { f = POPs; PUTBACK; } if(!sv_isobject(f)) croak("Expected a blessed object reference to await"); if(PL_op->op_flags & OPf_SPECIAL) { future_await_toplevel(f); return PL_op->op_next; } if(future_is_ready(f)) { assert(CvDEPTH(curcv) > 0); TRACEPRINT(" READY\n"); if(state) state->curcop = NULL; /* This might throw */ future_get_to_stack(f, GIMME_V); TRACEPRINT("LEAVE await curcv=%p [%s:%d]\n", curcv, CopFILE(PL_curcop), CopLINE(PL_curcop)); return PL_op->op_next; } #ifdef DEBUG_SHOW_STACKS debug_showstack("Stack before suspend"); #endif if(!state) { /* Clone the CV and then attach suspendedstate magic to it */ /* No point copying a normal lexical slot because the suspend logic is * about to capture all the pad slots from the running CV (orig) and * they'll be restored into this new one later by resume. */ CV *runcv = curcv; curcv = cv_copy_flags(runcv, CV_COPY_NULL_LEXICALS); state = suspendedstate_new(curcv); HV *premodhookdata = precreate_padix ? (HV *)PAD_SVl(precreate_padix + PRECREATE_MODHOOKDATA) : NULL; if(premodhookdata) { state->modhookdata = premodhookdata; PAD_SVl(precreate_padix + PRECREATE_MODHOOKDATA) = NULL; /* steal it */ } if(regs) { if(!state->modhookdata) state->modhookdata = newHV(); RUN_HOOKS_FWD(post_cv_copy, runcv, curcv, state->modhookdata); } TRACEPRINT(" SUSPEND cloned CV->%p\n", curcv); defer_mortal_curcv = TRUE; } else { TRACEPRINT(" SUSPEND reuse CV\n"); } state->curcop = PL_curcop; if(regs) RUN_HOOKS_REV(pre_suspend, curcv, state->modhookdata); suspendedstate_suspend(state, origcv); /* New ones first */ if(regs) RUN_HOOKS_FWD(post_suspend, curcv, state->modhookdata); /* Legacy ones after */ { SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", FALSE); if(hookp && SvOK(*hookp) && SvUV(*hookp)) { warn("Invoking legacy Future::AsyncAwait suspendhook for POSTSUSPEND phase"); SuspendHookFunc *hook = INT2PTR(SuspendHookFunc *, SvUV(*hookp)); if(!state->modhookdata) state->modhookdata = newHV(); (*hook)(aTHX_ FAA_PHASE_POSTSUSPEND, curcv, state->modhookdata); } } CvSTART(curcv) = PL_op; /* resume from here */ future_on_ready(f, curcv); /* If the Future implementation's ->AWAIT_ON_READY failed to capture this CV * then we'll segfault later after SvREFCNT_dec() on it. We can at least * detect that here */ if(SvREFCNT(curcv) < 2) { croak("AWAIT_ON_READY failed to capture the CV"); } state->awaiting_future = newSVsv(f); sv_rvweaken(state->awaiting_future); if(!state->returning_future) { state->returning_future = future_new_from_proto(f); if(precancel) { I32 i; for(i = 0; i < av_count(precancel); i++) future_on_cancel(state->returning_future, AvARRAY(precancel)[i]); AvFILLp(precancel) = -1; } #ifndef HAVE_FUTURE_CHAIN_CANCEL /* We can't chain the cancellation but we do need a different way to * invoke the defer and finally blocks */ future_on_cancel(state->returning_future, newRV_inc((SV *)curcv)); #endif } if(defer_mortal_curcv) SvREFCNT_dec((SV *)curcv); PUSHMARK(SP); mPUSHs(newSVsv(state->returning_future)); PUTBACK; if(!SvWEAKREF(state->returning_future)) sv_rvweaken(state->returning_future); if(!SvROK(state->returning_future)) panic("ARGH we lost state->returning_future for curcv=%p\n", curcv); #ifdef HAVE_FUTURE_CHAIN_CANCEL future_chain_on_cancel(state->returning_future, state->awaiting_future); if(!SvROK(state->returning_future)) panic("ARGH we lost state->returning_future for curcv=%p\n", curcv); #endif if(!SvROK(state->awaiting_future)) panic("ARGH we lost state->awaiting_future for curcv=%p\n", curcv); TRACEPRINT("LEAVE await curcv=%p [%s:%d]\n", curcv, CopFILE(PL_curcop), CopLINE(PL_curcop)); return PL_ppaddr[OP_RETURN](aTHX); } static XOP xop_pushcancel; static OP *pp_pushcancel(pTHX) { SuspendedState *state = suspendedstate_get(find_runcv(0)); CV *on_cancel = cv_clone((CV *)cSVOP->op_sv); if(state && state->returning_future) { future_on_cancel(state->returning_future, newRV_noinc((SV *)on_cancel)); } else { PADOFFSET precreate_padix = PL_op->op_targ; AV *precancel = (AV *)PAD_SVl(precreate_padix + PRECREATE_CANCEL); av_push(precancel, newRV_noinc((SV *)on_cancel)); } return PL_op->op_next; } enum { NO_FORBID, FORBID_FOREACH_NONLEXICAL, FORBID_MAP, FORBID_GREP, }; static void check_optree(pTHX_ OP *op, int forbid, COP **last_cop); static void check_optree(pTHX_ OP *op, int forbid, COP **last_cop) { OP *op_first; OP *kid = NULL; if(OP_CLASS(op) == OA_COP) *last_cop = (COP *)op; switch(op->op_type) { case OP_LEAVELOOP: if((op_first = cUNOPx(op)->op_first)->op_type != OP_ENTERITER) break; /* This is a foreach loop of some kind. If it's not using a lexical * iterator variable, disallow await inside the body. * Check the first child, then apply forbid to the remainder of the body */ check_optree(aTHX_ op_first, forbid, last_cop); kid = OpSIBLING(op_first); if(!op_first->op_targ) forbid = FORBID_FOREACH_NONLEXICAL; break; case OP_MAPSTART: case OP_GREPSTART: /* children are: PUSHMARK, BODY, ITEMS... */ if((op_first = cUNOPx(op)->op_first)->op_type != OP_PUSHMARK) break; kid = OpSIBLING(op_first); check_optree(aTHX_ kid, op->op_type == OP_MAPSTART ? FORBID_MAP : FORBID_GREP, last_cop); kid = OpSIBLING(kid); break; case OP_CUSTOM: if(op->op_ppaddr != &pp_await) break; if(!forbid) /* await is allowed here */ break; char *reason; switch(forbid) { case FORBID_FOREACH_NONLEXICAL: reason = "foreach on non-lexical iterator variable"; break; case FORBID_MAP: reason = "map"; break; case FORBID_GREP: reason = "grep"; break; } croak("await is not allowed inside %s at %s line %d.\n", reason, CopFILE(*last_cop), CopLINE(*last_cop)); break; } if(op->op_flags & OPf_KIDS) { if(!kid) kid = cUNOPx(op)->op_first; for(; kid; kid = OpSIBLING(kid)) check_optree(aTHX_ kid, forbid, last_cop); } } /* * Keyword plugins */ static void parse_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { /* Save the identity of the currently-compiling sub so that * await_keyword_plugin() can check */ hv_stores(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", newSVuv(PTR2UV(PL_compcv))); hv_stores(GvHV(PL_hintgv), "Future::AsyncAwait/*precreate_padix", newRV_noinc(newSVuv(0))); } static void parse_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { /* body might be NULL if an error happened; we check that below so for now * just be defensive */ if(ctx->body) { COP *last_cop = PL_curcop; check_optree(aTHX_ ctx->body, NO_FORBID, &last_cop); } #ifdef HAVE_OP_ARGCHECK /* If the sub body is using signatures, we want to pull the OP_ARGCHECK * outside the try block. This has two advantages: * 1. arity checks appear synchronous from the perspective of the caller; * immediate exceptions rather than failed Futures * 2. it makes Syntax::Keyword::MultiSub able to handle `async multi sub` */ OP *argcheckop = NULL; if(ctx->body->op_type == OP_LINESEQ) { OP *lineseq = ctx->body; OP *o = cLISTOPx(lineseq)->op_first; /* OP_ARGCHECK is often found inside a second inner nested OP_LINESEQ that * was op_null'ed out */ if(o->op_type == OP_NULL && o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type == OP_LINESEQ) { lineseq = cUNOPo->op_first; o = cLISTOPx(lineseq)->op_first; } if(o->op_type == OP_NEXTSTATE && OpSIBLING(o)->op_type == OP_ARGCHECK) { /* Splice out the NEXTSTATE+ARGCHECK ops */ argcheckop = o; /* technically actually the NEXTSTATE before it */ o = OpSIBLING(OpSIBLING(o)); OpMORESIB_set(OpSIBLING(argcheckop), NULL); cLISTOPx(lineseq)->op_first = o; } } #endif /* turn block into * NEXTSTATE; PUSHMARK; eval { BLOCK }; LEAVEASYNC */ OP *body = newSTATEOP(0, NULL, NULL); PADOFFSET precreate_padix = get_precreate_padix(); if(precreate_padix) { OP *enterasync; body = op_append_elem(OP_LINESEQ, body, enterasync = newOP_CUSTOM(&pp_enterasync, 0)); enterasync->op_targ = precreate_padix; } body = op_append_elem(OP_LINESEQ, body, newOP(OP_PUSHMARK, 0)); OP *try; body = op_append_elem(OP_LINESEQ, body, try = newUNOP(OP_ENTERTRY, 0, ctx->body)); op_contextualize(try, G_ARRAY); body = op_append_elem(OP_LINESEQ, body, newOP_CUSTOM(&pp_leaveasync, OPf_WANT_SCALAR)); #ifdef HAVE_OP_ARGCHECK if(argcheckop) { assert(body->op_type == OP_LINESEQ); /* Splice the argcheckop back into the start of the lineseq */ OP *o = argcheckop; while(OpSIBLING(o)) o = OpSIBLING(o); OpMORESIB_set(o, cLISTOPx(body)->op_first); cLISTOPx(body)->op_first = argcheckop; } #endif ctx->body = body; } static void parse_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { if(CvLVALUE(ctx->cv)) warn("Pointless use of :lvalue on async sub"); } static struct XSParseSublikeHooks hooks_async = { .permit_hintkey = "Future::AsyncAwait/async", .flags = XS_PARSE_SUBLIKE_FLAG_PREFIX, .post_blockstart = parse_post_blockstart, .pre_blockend = parse_pre_blockend, .post_newcv = parse_post_newcv, }; static void check_await(pTHX_ void *hookdata) { SV **asynccvp = hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", 0); if(asynccvp && SvUV(*asynccvp) == PTR2UV(PL_compcv)) ; /* await inside regular `async sub` */ else if(PL_compcv == PL_main_cv) ; /* toplevel await */ else croak(CvEVAL(PL_compcv) ? "await is not allowed inside string eval" : "Cannot 'await' outside of an 'async sub'"); } static int build_await(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { OP *expr = arg0->op; if(PL_compcv == PL_main_cv) *out = newUNOP_CUSTOM(&pp_await, OPf_SPECIAL, expr); else { *out = newUNOP_CUSTOM(&pp_await, 0, expr); (*out)->op_targ = get_precreate_padix(); } return KEYWORD_PLUGIN_EXPR; } static struct XSParseKeywordHooks hooks_await = { .permit_hintkey = "Future::AsyncAwait/async", .check = &check_await, .piece1 = XPK_TERMEXPR_SCALARCTX, .build1 = &build_await, }; static void check_cancel(pTHX_ void *hookdata) { SV **asynccvp = hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", 0); if(!asynccvp || SvUV(*asynccvp) != PTR2UV(PL_compcv)) croak(CvEVAL(PL_compcv) ? "CANCEL is not allowed inside string eval" : "Cannot 'CANCEL' outside of an 'async sub'"); #ifdef WARN_EXPERIMENTAL if(!hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/experimental(cancel)", 0)) { Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "CANCEL block syntax is experimental and may be changed or removed without notice"); } #endif } static int build_cancel(pTHX_ OP **out, XSParseKeywordPiece *arg0, void *hookdata) { CV *on_cancel = arg0->cv; OP *pushcancel; *out = op_prepend_elem(OP_LINESEQ, (pushcancel = newSVOP_CUSTOM(&pp_pushcancel, 0, (SV *)on_cancel)), NULL); pushcancel->op_targ = get_or_create_precreate_padix(); return KEYWORD_PLUGIN_STMT; } static struct XSParseKeywordHooks hooks_cancel = { .permit_hintkey = "Future::AsyncAwait/async", .check = &check_cancel, .piece1 = XPK_ANONSUB, .build1 = &build_cancel, }; /* * Back-compat support */ struct AsyncAwaitHookFuncs_v1 { U32 flags; void (*post_cv_copy)(pTHX_ CV *runcv, CV *cv, HV *modhookdata, void *hookdata); /* no pre_suspend */ void (*post_suspend)(pTHX_ CV *cv, HV *modhookdata, void *hookdata); void (*pre_resume) (pTHX_ CV *cv, HV *modhookdata, void *hookdata); /* no post_resume */ void (*free) (pTHX_ CV *cv, HV *modhookdata, void *hookdata); }; static void register_faa_hook_v1(pTHX_ const struct AsyncAwaitHookFuncs_v1 *hookfuncs_v1, void *hookdata) { /* No flags are recognised; complain if the caller requested any */ if(hookfuncs_v1->flags) croak("Unrecognised hookfuncs->flags value %08x", hookfuncs_v1->flags); struct AsyncAwaitHookFuncs *hookfuncs; Newx(hookfuncs, 1, struct AsyncAwaitHookFuncs); hookfuncs->flags = 0; hookfuncs->post_cv_copy = hookfuncs_v1->post_cv_copy; hookfuncs->pre_suspend = NULL; hookfuncs->post_suspend = hookfuncs_v1->post_suspend; hookfuncs->pre_resume = hookfuncs_v1->pre_resume; hookfuncs->post_resume = NULL; hookfuncs->free = hookfuncs_v1->free; register_faa_hook(aTHX_ hookfuncs, hookdata); } MODULE = Future::AsyncAwait PACKAGE = Future::AsyncAwait int __cxstack_ix() CODE: RETVAL = cxstack_ix; OUTPUT: RETVAL BOOT: XopENTRY_set(&xop_enterasync, xop_name, "enterasync"); XopENTRY_set(&xop_enterasync, xop_desc, "enterasync()"); XopENTRY_set(&xop_enterasync, xop_class, OA_BASEOP); Perl_custom_op_register(aTHX_ &pp_enterasync, &xop_enterasync); XopENTRY_set(&xop_leaveasync, xop_name, "leaveasync"); XopENTRY_set(&xop_leaveasync, xop_desc, "leaveasync()"); XopENTRY_set(&xop_leaveasync, xop_class, OA_UNOP); Perl_custom_op_register(aTHX_ &pp_leaveasync, &xop_leaveasync); XopENTRY_set(&xop_await, xop_name, "await"); XopENTRY_set(&xop_await, xop_desc, "await()"); XopENTRY_set(&xop_await, xop_class, OA_UNOP); Perl_custom_op_register(aTHX_ &pp_await, &xop_await); XopENTRY_set(&xop_pushcancel, xop_name, "pushcancel"); XopENTRY_set(&xop_pushcancel, xop_desc, "pushcancel()"); XopENTRY_set(&xop_pushcancel, xop_class, OA_SVOP); Perl_custom_op_register(aTHX_ &pp_pushcancel, &xop_pushcancel); boot_xs_parse_keyword(0.13); boot_xs_parse_sublike(0.14); register_xs_parse_sublike("async", &hooks_async, NULL); register_xs_parse_keyword("await", &hooks_await, NULL); register_xs_parse_keyword("CANCEL", &hooks_cancel, NULL); #ifdef HAVE_DMD_HELPER DMD_SET_MAGIC_HELPER(&vtbl_suspendedstate, dumpmagic_suspendedstate); #endif sv_setiv(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/ABIVERSION_MIN", 1), 1); sv_setiv(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/ABIVERSION_MAX", 1), FUTURE_ASYNCAWAIT_ABI_VERSION); sv_setiv(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/register()@2", 1), PTR2UV(®ister_faa_hook)); sv_setiv(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/register()@1", 1), PTR2UV(®ister_faa_hook_v1)); sv_setiv(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/get_modhookdata()@1", 1), PTR2UV(&get_modhookdata)); sv_setiv(*hv_fetchs(PL_modglobal, "Future::AsyncAwait/make_precreate_padix()@1", 1), PTR2UV(&S_get_or_create_precreate_padix)); { AV *run_on_loaded = NULL; SV **svp; if(svp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/on_loaded", FALSE)) { run_on_loaded = (AV *)SvREFCNT_inc(*svp); hv_deletes(PL_modglobal, "Future::AsyncAwait/on_loaded", 0); } hv_stores(PL_modglobal, "Future::AsyncAwait/loaded", &PL_sv_yes); if(run_on_loaded) { svp = AvARRAY(run_on_loaded); int i; for(i = 0; i < AvFILL(run_on_loaded); i += 2) { void (*func)(pTHX_ void *data) = INT2PTR(void *, SvUV(svp[i ])); void *data = INT2PTR(void *, SvUV(svp[i+1])); (*func)(aTHX_ data); } SvREFCNT_dec(run_on_loaded); } } Future-AsyncAwait-0.66/lib/Future/AsyncAwait000755001750001750 014476650556 17606 5ustar00leoleo000000000000Future-AsyncAwait-0.66/lib/Future/AsyncAwait/Awaitable.pm000444001750001750 1330714476650556 22216 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2019-2022 -- leonerd@leonerd.org.uk package Future::AsyncAwait::Awaitable 0.66; use v5.14; use warnings; =head1 NAME C - the interface required by C =head1 DESCRIPTION This module documents the method interface required by C to operate on future instances returned by expressions invoked by the C keyword, and returned by functions declared by C. This information is largely of relevance to implementors of other module integrations, event systems, or similar. It is not necessary to make regular use of the syntax provided by the module when working with existing event systems. The methods required by this interface are all capitalised and prefixed with C, ensuring they are unlikely to clash with existing methods on a class which may have differing semantics. =head2 Role::Tiny If L is available, this module declares itself to be a role that requires the following named methods. The role supplies no code to the applied class, but can be useful for checking that you have in fact implemented all of the required methods. =head2 Conformance Test To assist implementors of alternative future-like classes, an API conformance test suite is provided by L. You may find this useful to check that your implementation is suitable. =cut if( defined eval { require Role::Tiny } ) { Role::Tiny->import; requires( qw( AWAIT_CLONE AWAIT_NEW_DONE AWAIT_NEW_FAIL AWAIT_DONE AWAIT_FAIL AWAIT_GET AWAIT_IS_READY AWAIT_ON_READY AWAIT_IS_CANCELLED AWAIT_ON_CANCEL AWAIT_WAIT ) ); } =head1 CONSTRUCTORS The following methods are expected to create new future instances. They make use of the class set by the prevailing C import argument, if set, or default to C if not. =head2 AWAIT_NEW_DONE Generate a new immediate future that is successful. The future will already be ready and have the list of values set as its result. $f = $CLASS->AWAIT_NEW_DONE( @results ) # $f->AWAIT_IS_READY will be true # $f->AWAIT_GET will return @results =head2 AWAIT_NEW_FAIL Generate a new immediate future that is failed. The future will already be ready and invoking the L method will throw the given exception. $f = $CLASS->AWAIT_NEW_FAIL( $message ) # $f->AWAIT_IS_READY will be true # $f->AWAIT_GET will throw $message =head1 INSTANCE METHODS =head2 AWAIT_CLONE Generate a new pending future of the same type as an existing one, which is not modified by doing so. It will only be invoked on instances that are currently pending. $new_f = $f->AWAIT_CLONE If the instance has any fields that are required for successful operation (such as application-wide context or event system components) these ought to be copied. The method should not otherwise copy any per-instance state such as pending callbacks or partial results. =head2 AWAIT_DONE Sets the success result of an existing still-pending future. It will only be invoked on future instances that are currently pending. $f->AWAIT_DONE( @results ) # $f->AWAIT_IS_READY will now be true # $f->AWAIT_GET will now return @results =head2 AWAIT_FAIL Sets the failure result of an existing still-pending future. It will only be invoked on future instances that are currently pending. $f->AWAIT_FAIL( $message ) # $f->AWAIT_IS_READY will now be true # $f->AWAIT_GET will now throw $message =head2 AWAIT_IS_READY Returns true if a future is ready (successful, failed or cancelled); false if still pending. $bool = $f->AWAIT_IS_READY =head2 AWAIT_IS_CANCELLED Returns true is a future has already been cancelled; false if still pending, successful or failed. $bool = $f->AWAIT_IS_CANCELLED An implementation that does not support cancellation can simply return a constant false here: sub AWAIT_IS_CANCELLED { 0 } =head2 AWAIT_GET Yields the result of a successful future (or just the first value if called in scalar context). Throws the failure message as an exception if called on a a failed one. Will not be invoked on a pending or cancelled future. @result = $f->AWAIT_GET $result = $f->AWAIT_GET $f->AWAIT_GET =head2 AWAIT_ON_READY Attach a new CODE reference to be invoked when the future becomes ready (by success or failure). The arguments and context that C<$code> is invoked with are unspecified. $f->AWAIT_ON_READY( $code ) =head2 AWAIT_CHAIN_CANCEL Attach a future instance to be cancelled when another one is cancelled. $f1->AWAIT_CHAIN_CANCEL( $f2 ) When C<$f1> is cancelled, then C<$f2> is cancelled. There is no link from C<$f2> back to C<$f1> - whenever C<$f2> changes state here, nothing special happens to C<$f1>. An implementation that does not support cancellation can simply ignore this method. sub AWAIT_CHAIN_CANCEL { } An older version of this API specification named this C, but that name will be repurposed for attaching code blocks in a later version. =head2 AWAIT_ON_CANCEL Attach a new CODE reference to be invoked when the future is cancelled. $f->AWAIT_ON_CANCEL( $code ) An implementation that does not support cancellation can simply ignore this method. sub AWAIT_ON_CANCEL { } =head2 AWAIT_WAIT Called by the toplevel C expression in order to run the event system and wait for the instance to be ready. It should return results or throw an exception in the same manner as L. @result = $f->AWAIT_WAIT $result = $f->AWAIT_WAIT $f->AWAIT_WAIT =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.66/lib/Future/AsyncAwait/ExtensionBuilder.pm000444001750001750 461314476650556 23570 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2022 -- leonerd@leonerd.org.uk package Future::AsyncAwait::ExtensionBuilder 0.66; use v5.14; use warnings; =head1 NAME C - build-time support for extensions to C =head1 SYNOPSIS In F: use Future::AsyncAwait::ExtensionBuilder; my $build = Module::Build->new( ..., configure_requires => { ... 'Future::AsyncAwait::ExtensionBuilder' => 0, } ); Future::AsyncAwait::ExtensionBuilder->extend_module_build( $build ); ... =head1 DESCRIPTION This module provides a build-time helper to assist authors writing XS modules that provide extensions to L. It prepares a L-using distribution to be able to make use of the C extension API. =cut require Future::AsyncAwait::ExtensionBuilder_data; =head1 FUNCTIONS =cut =head2 write_AsyncAwait_h Future::AsyncAwait::ExtensionBuilder->write_AsyncAwait_h Writes the F file to the current working directory. To cause the compiler to actually find this file, see L. =cut sub write_AsyncAwait_h { shift; open my $out, ">", "AsyncAwait.h" or die "Cannot open AsyncAwait.h for writing - $!\n"; $out->print( Future::AsyncAwait::ExtensionBuilder_data->ASYNCAWAIT_H ); } =head2 extra_compiler_flags @flags = Future::AsyncAwait::ExtensionBuilder->extra_compiler_flags Returns a list of extra flags that the build scripts should add to the compiler invocation. This enables the C compiler to find the F file. =cut sub extra_compiler_flags { shift; return "-I."; } =head2 extend_module_build Future::AsyncAwait::ExtensionBuilder->extend_module_build( $build ) A convenient shortcut for performing all the tasks necessary to make a L-based distribution use the helper. =cut sub extend_module_build { my $self = shift; my ( $build ) = @_; eval { $self->write_AsyncAwait_h } or do { warn $@; return; }; # preserve existing flags my @flags = @{ $build->extra_compiler_flags }; push @flags, $self->extra_compiler_flags; $build->extra_compiler_flags( @flags ); } =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.66/lib/Future/AsyncAwait/ExtensionBuilder_data.pm.PL000444001750001750 132514476650556 25070 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2022 -- leonerd@leonerd.org.uk use v5.14; use warnings; open my $outh, ">", $ARGV[0] or die "Cannot write $ARGV[0] - $!\n"; local $/; $outh->print( scalar do { } ); $outh->print( scalar do { open my $in_h, "<", "lib/Future/AsyncAwait.h" or die "Cannot open AsyncAwait.h - $!"; <$in_h> } ); __DATA__ package Future::AsyncAwait::ExtensionBuilder_data 0.66; use v5.14; use warnings; # The contents of the "AsyncAwait.h" file my $AsyncAwait_h = do { local $/; readline DATA; }; sub ASYNCAWAIT_H() { $AsyncAwait_h } 0x55AA; __DATA__ Future-AsyncAwait-0.66/lib/Test000755001750001750 014476650556 15210 5ustar00leoleo000000000000Future-AsyncAwait-0.66/lib/Test/Future000755001750001750 014476650556 16462 5ustar00leoleo000000000000Future-AsyncAwait-0.66/lib/Test/Future/AsyncAwait000755001750001750 014476650556 20525 5ustar00leoleo000000000000Future-AsyncAwait-0.66/lib/Test/Future/AsyncAwait/Awaitable.pm000444001750001750 1505314476650556 23135 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020-2023 -- leonerd@leonerd.org.uk package Test::Future::AsyncAwait::Awaitable 0.66; use v5.14; use warnings; use Test2::V0; use Exporter 'import'; our @EXPORT_OK = qw( test_awaitable ); =head1 NAME C - conformance tests for awaitable role API =head1 SYNOPSIS use Test::More; use Test::Future::AsyncAwait::Awaitable; use My::Future::Subclass; test_awaitable "My subclass of Future", class => "My::Future::Subclass"; done_testing; =head1 DESCRIPTION This module provides a single test function, which runs a suite of subtests to check that a given class provides a useable implementation of the L role. It runs tests that simulate various ways in which L will try to use an instance of this class, to check that the implementation is valid. =cut =head1 FUNCTIONS =cut =head2 test_awaitable test_awaitable( $title, %args ) Runs the API conformance tests. C<$title> is printed in the test description output so should be some human-friendly string. Takes the following named arguments: =over 4 =item class => STRING Gives the name of the class. This is the class on which the C and C methods will be invoked. =item new => CODE Optional. Gives a callback function to invoke to construct a new pending instance; used by the tests to create pending instances that would be passed into the C keyword. As this is not part of the API as such, the test code does not rely on being able to directly perform it via the API. This argument is optional; if not provided the tests will simply try to invoke the regular C constructor on the given class name. For most implementations this should be sufficient. $f = $new->() =item cancel => CODE Optional. Gives a callback function to invoke to cancel a pending instance, if the implementation provides cancellation semantics. If this callback is provided then an extra subtest suite is run to check the API around cancellation. $cancel->( $f ) =item force => CODE Optional. Gives a callback function to invoke to wait for a promise to invoke its on-ready callbacks. Some future-like implementations will run these immediately when the future is marked as done or failed, and so this callback will not be required. Other implementations will defer these invocations, perhaps until the next tick of an event loop or similar. In the latter case, these implementations should provide a way for the test to wait for this to happen. $force->( $f ) =back =cut my $FILE = __FILE__; my %FIXED_MODULE_VERSIONS = ( 'Future::PP' => '0.50', 'Future::XS' => '0.09', ); sub _complain_package_version { my ( $pkg ) = @_; # Drill down to the most base class that isn't Future::_base { no strict 'refs'; $pkg = ${"${pkg}::ISA"}[0] while @{"${pkg}::ISA"} and ${"${pkg}::ISA"}[0] ne "Future::_base"; } my $pkgver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; my $wantver = $FIXED_MODULE_VERSIONS{$pkg}; if( defined $wantver && $pkgver < $wantver ) { diag( "$pkg VERSION is only $pkgver; this might be fixed by updating to version $wantver" ); } else { diag( "$pkg VERSION is $pkgver; maybe a later version fixes it?" ); } } sub test_awaitable { my ( $title, %args ) = @_; my $class = $args{class}; my $new = $args{new} || sub { return $class->new() }; my $cancel = $args{cancel}; my $force = $args{force}; subtest "$title immediate done" => sub { ok( my $f = $class->AWAIT_NEW_DONE( "result" ), "AWAIT_NEW_DONE yields object" ); ok( $f->AWAIT_IS_READY, 'AWAIT_IS_READY true' ); ok( !$f->AWAIT_IS_CANCELLED, 'AWAIT_IS_CANCELLED false' ); is( [ $f->AWAIT_GET ], [ "result" ], 'AWAIT_GET in list context' ); is( scalar $f->AWAIT_GET, "result", 'AWAIT_GET in scalar context' ); ok( defined eval { $f->AWAIT_GET; 1 }, 'AWAIT_GET in void context' ); }; subtest "$title immediate fail" => sub { ok( my $f = $class->AWAIT_NEW_FAIL( "Oopsie" ), "AWAIT_NEW_FAIL yields object" ); ok( $f->AWAIT_IS_READY, 'AWAIT_IS_READY true' ); ok( !$f->AWAIT_IS_CANCELLED, 'AWAIT_IS_CANCELLED false' ); my $LINE = __LINE__+1; ok( !defined eval { $f->AWAIT_GET; 1 }, 'AWAIT_GET in void context' ); is( $@, "Oopsie at $FILE line $LINE.\n", 'AWAIT_GET throws exception' ) or _complain_package_version( ref $f ); }; my $fproto = $new->() or BAIL_OUT( "new did not yield an instance" ); subtest "$title deferred done" => sub { ok( my $f = $fproto->AWAIT_CLONE, 'AWAIT_CLONE yields object' ); ok( !$f->AWAIT_IS_READY, 'AWAIT_IS_READY false' ); $f->AWAIT_DONE( "Late result" ); ok( $f->AWAIT_IS_READY, 'AWAIT_IS_READY true' ); is( scalar $f->AWAIT_GET, "Late result", 'AWAIT_GET in scalar context' ); }; subtest "$title deferred fail" => sub { ok( my $f = $fproto->AWAIT_CLONE, 'AWAIT_CLONE yields object' ); ok( !$f->AWAIT_IS_READY, 'AWAIT_IS_READY false' ); $f->AWAIT_FAIL( "Late oopsie" ); ok( $f->AWAIT_IS_READY, 'AWAIT_IS_READY true' ); my $LINE = __LINE__+1; ok( !defined eval { $f->AWAIT_GET; 1 }, 'AWAIT_GET in void context' ); is( $@, "Late oopsie at $FILE line $LINE.\n", 'AWAIT_GET throws exception' ) or _complain_package_version( ref $f ); }; subtest "$title on-ready" => sub { my $f = $new->() or BAIL_OUT( "new did not yield an instance" ); my $called; $f->AWAIT_ON_READY( sub { $called++ } ); ok( !$called, 'AWAIT_ON_READY CB not yet invoked' ); $f->AWAIT_DONE( "ping" ); $force->( $f ) if $force; ok( $called, 'AWAIT_ON_READY CB now invoked' ); }; $cancel and subtest "$title cancellation" => sub { my $f1 = $new->() or BAIL_OUT( "new did not yield an instance" ); my $f2 = $f1->AWAIT_CLONE; $f1->AWAIT_CHAIN_CANCEL( $f2 ); ok( !$f2->AWAIT_IS_CANCELLED, 'AWAIT_IS_CANCELLED false before cancellation' ); $cancel->( $f1 ); ok( $f2->AWAIT_IS_CANCELLED, 'AWAIT_IS_CANCELLED true after AWAIT_ON_CANCEL propagation' ); my $f3 = $new->() or BAIL_OUT( "new did not yield an instance" ); my $cancelled; $f3->AWAIT_ON_CANCEL( sub { $cancelled++ } ); $cancel->( $f3 ); ok( $cancelled, 'AWAIT_ON_CANCEL invoked callback' ); }; } =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.66/t000755001750001750 014476650556 13766 5ustar00leoleo000000000000Future-AsyncAwait-0.66/t/00use.t000444001750001750 17514476650556 15227 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; require Future::AsyncAwait; pass "Modules loaded"; done_testing; Future-AsyncAwait-0.66/t/01async-immediate.t000444001750001750 315014476650556 17521 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # immediate done ANON scalar { my $want; my $func = async sub { $want = wantarray ? "list" : defined wantarray ? "scalar" : "void"; return 5; }; my $f = $func->(); isa_ok( $f, [ "Future" ], '$f' ); is( $want, "list", 'func saw list context' ); ok( $f->is_ready, '$f is immediate' ); is( scalar $f->get, 5, '$f->get' ); } # immediate done named scalar { async sub func_10 { return 10; }; my $f = func_10(); isa_ok( $f, [ "Future" ], '$f' ); ok( $f->is_ready, '$f is immediate' ); is( scalar $f->get, 10, '$f->get' ); } # immediate done list { async sub func_list { return 1 .. 5 }; my $f = func_list(); isa_ok( $f, [ "Future" ], '$f' ); ok( $f->is_ready, '$f is immediate' ); is( [ $f->get ], [ 1 .. 5 ], '$f->get' ); } # immediate fail { async sub func_die { die "Failure\n"; } my $f = func_die(); isa_ok( $f, [ "Future" ], '$f' ); ok( $f->is_ready, '$f is immediate' ); is( scalar $f->failure, "Failure\n", '$f->failure' ); } # immediate done list in list context { my @ret = (async sub { return 1, 2, 3 })->( 4, 5, 6 ); is( scalar @ret, 1, 'async sub returns 1 value in list context' ) or diag( "async sub returned <@ret>" ); isa_ok( shift @ret, [ "Future" ], 'Single result was a Future' ); } # unimport { no Future::AsyncAwait; sub async { return "normal function" } is( async, "normal function", 'async() parses as a normal function call' ); } done_testing; Future-AsyncAwait-0.66/t/02await-immediate.t000444001750001750 235214476650556 17515 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; async sub identity { await $_[0]; } # scalar { my $f1 = Future->done( "result" ); my $fret = identity( $f1 ); isa_ok( $fret, [ "Future" ], 'identity() returns a Future' ); ok( $fret->is_ready, '$fret is immediate for done scalar' ); is( scalar $fret->get, "result", '$fret->get for done scalar' ); } # list { my $f1 = Future->done( list => "goes", "here" ); my $fret = identity( $f1 ); isa_ok( $fret, [ "Future" ], 'identity() returns a Future' ); ok( $fret->is_ready, '$fret is immediate for done list' ); is( [ $fret->get ], [qw( list goes here )], '$fret->get for done list' ); } # stack discipline test { my $f1 = Future->done( 4, 5 ); my $fret = (async sub { 1, 2, [ 3, await $f1, 6 ], 7, 8 })->(); is( [ $fret->get ], [ 1, 2, [ 3, 4, 5, 6 ], 7, 8 ], 'async/await respects stack discipline' ); } # failure { my $f1 = Future->fail( "It failed\n" ); my $fret = identity( $f1 ); isa_ok( $fret, [ "Future" ], 'identity() returns a Future' ); ok( $fret->is_ready, '$fret is immediate for fail' ); is( $fret->failure, "It failed\n", '$fret->failure for fail' ); } done_testing; Future-AsyncAwait-0.66/t/03await.t000444001750001750 714714476650556 15571 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; my $before; my $after; async sub identity { await $_[0]; } # scalar { my $f1 = Future->new; my $fret = identity( $f1 ); isa_ok( $fret, [ "Future" ], 'identity() returns a Future' ) and do { ok( !$fret->is_ready, '$fret is not immediate for pending scalar' ); }; $f1->done( "result" ); is( scalar $fret->get, "result", '$fret->get for scalar' ); } # list { my $f1 = Future->new; my $fret = identity( $f1 ); isa_ok( $fret, [ "Future" ], 'identity() returns a Future' ); $f1->done( list => "goes", "here" ); is( [ $fret->get ], [qw( list goes here )], '$fret->get for list' ); } async sub makelist { 1, 2, [ 3, await $_[0], 6 ], 7, 8 } # stack discipline test { my $f1 = Future->new; my $fret = makelist( $f1 ); $f1->done( 4, 5 ); is( [ $fret->get ], [ 1, 2, [ 3, 4, 5, 6 ], 7, 8 ], 'async/await respects stack discipline' ); } # await twice from function { my @futures; sub another_f { push @futures, my $f = Future->new; return $f; } async sub wait_twice { await another_f(); await another_f(); } my $fret = wait_twice; ok( my $f1 = shift @futures, '$f1 created' ); $f1->done; ok( my $f2 = shift @futures, '$f2 created' ); $f2->done( "result" ); is( scalar $fret->get, "result", '$fret->get from double await by func' ); } # await twice from pad { async sub wait_for_both { my ( $f1, $f2 ) = @_; return await( $f1 ) + await( $f2 ); } my $f1 = Future->new; my $f2 = Future->new; my $fret = wait_for_both( $f1, $f2 ); $f1->done( 12 ); $f2->done( 34 ); is( scalar $fret->get, 46, '$fret->get from double await by pad' ); } # failure { my $f1 = Future->new; my $fret = identity( $f1 ); isa_ok( $fret, [ "Future" ], 'identity() returns a Future' ); $f1->fail( "It failed\n" ); is( $fret->failure, "It failed\n", '$fret->failure for fail' ); } # die { my $f1 = Future->new; async sub f_dies { await $f1; die "Oopsie\n"; } my $fret = f_dies(); $f1->done; is( $fret->failure, "Oopsie\n", '$fret->failure for f_dies' ); } # ANON sub { my $func = async sub { return await $_[0]; }; my $f1 = Future->new; my $fret = $func->( $f1 ); ok( !$fret->is_ready, '$fret is not immediate for pending ANON' ); $f1->done( "later" ); is( scalar $fret->get, "later", '$fret->get for ANON' ); } # ANON sub closure { my $f1 = Future->new; my $func = async sub { return await $f1; }; my $fret = $func->( $f1 ); ok( !$fret->is_ready, '$fret is not immediate for pending ANON closure' ); $f1->done( "later" ); is( scalar $fret->get, "later", '$fret->get for ANON closure' ); } # await EXPR puts EXPR in scalar context { my $f1 = Future->new; sub yieldcontext { return Future->done( wantarray ); } my $func = async sub { return await yieldcontext(); }; my $fret = $func->(); is( $fret->get, '', 'await EXPR provides scalar context' ); } # await in non-async sub is forbidden { my $ok = !eval 'sub { await $_[0] }'; my $e = $@; ok( $ok, 'await in non-async sub fails to compile' ); $ok and like( $e, qr/Cannot 'await' outside of an 'async sub' at /, '' ); } { my $ok = !eval 'async sub { my $c = sub { await $_[0] } }'; ok( $ok, 'await in non-async sub inside async sub fails to compile' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/04await-toplevel.t000444001750001750 133014476650556 17406 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Test::Future::Deferred; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; # Await immediate { my $f = Future->done( "imm" ); is( await $f, "imm", 'toplevel await immediate yields result' ); } # Await deferred { # We can't easily `await` a pending future, then complete it in the usual # way, because we get suspended. But a deferred version will work fine my $f = Test::Future::Deferred->done_later( "later" ); is( await $f, "later", 'toplevel await deferred yields result' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/05await-expr.t000444001750001750 102214476650556 16531 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; { async sub await_within_expr { return 1 + await( $_[0] ) + 3; } my $f1 = Future->new; my $fret = await_within_expr( $f1 ); $f1->done( 2 ); is( scalar $fret->get, 6, '$fret yields correct result for mid-expression await' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/06await-nested.t000444001750001750 351714476650556 17051 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; my $f; my $failure; async sub inner { my $ret = await $f; die $failure if defined $failure; return $ret; } async sub outer { await inner(); } # await through two nested async sub calls # See also RT123062 { $f = Future->new; my $fret = outer(); $f->done( "value" ); is( scalar $fret->get, "value", '$fret->get through two nested async subs' ); } # die after double await # See also RT126037 { $f = Future->new; my $fret = outer(); $failure = "Oopsie\n"; $f->done( "result" ); is( scalar $fret->failure, "Oopsie\n", '$fret->failure through two nested async subs' ); } # await through two nested async method calls { my $f = Future->new; package TestObj { async sub inner { await $f; } async sub outer { my $mth = "inner"; await shift->$mth; } } my $fret = TestObj->outer(); $f->done( "value" ); is( scalar $fret->get, "value", '$fret->get through two nested async methods' ); } # await twice nested { my @f; async sub f2 { await $f[0]; } async sub f1 { await f2(); await f2(); } @f = map { Future->new } 1 .. 2; my $fret = f1(); ( shift @f )->done( "result" ) while @f; is( scalar $fret->get, "result", '$fret->get through nested double wait' ); } # nested failure { my $f = Future->new; async sub func_fail { await $f; } async sub func_fail_wrap { await func_fail(); } my $fret = func_fail_wrap(); $f->fail("aiee\n"); is( $fret->failure, "aiee\n", "nested fail" ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/07await-label.t000444001750001750 115514476650556 16643 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; my $before; my $after; # next LABEL { async sub with_next_label { my $f = shift; LABEL: foreach my $tmp (1) { await $f; next LABEL; fail( "unreachable" ); } return "OK"; } my $f = Future->new; my $fret = with_next_label( $f ); $f->done; ok( $fret->get, 'next LABEL' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/08await-cancel.t000444001750001750 153114476650556 17010 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; # ->cancel stops execution { my $called; my $f1 = Future->new; my $f2 = (async sub { await $f1; $called++; })->(); $f2->cancel; $f1->done; ok( !$called, 'async sub stops execution after ->cancel' ); } # ->cancel propagates SKIP: { # See # https://rt.cpan.org/Ticket/Display.html?id=129202#txn-1843918 skip "Cancel propagation is not implemented before perl 5.24", 1 if $] < 5.024; my $f1 = Future->new; my $f2 = (async sub { await $f1 })->(); $f2->cancel; ok( $f1->is_cancelled, 'async sub propagates cancel' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/09await-cancel-block.t000444001750001750 317314476650556 20105 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait qw( :experimental(cancel) ); my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; # CANCEL before await { my $cancelled; my $f1 = Future->new; my $fret = (async sub { CANCEL { $cancelled++; } await $f1; })->(); $fret->get if $fret->is_failed; # report errors $fret->cancel; $f1->done; ok( $cancelled, 'cancelled async sub invokes CANCEL blocks' ); } # CANCEL after await { my $cancelled; my $f1 = Future->new; my $f2 = Future->new; my $fret = (async sub { await $f1; CANCEL { $cancelled++; } await $f2; })->(); $f1->done; $fret->get if $fret->is_failed; # report errors $fret->cancel; $f2->done; ok( $cancelled, 'cancelled async sub invokes CANCEL blocks after first await' ); } # Not cancelled for done { my $cancelled; my $f1 = Future->new; my $fret = (async sub { CANCEL { $cancelled++; } await $f1; return "OK"; })->(); $fret->get if $fret->is_failed; # report errors $f1->done; $fret->get; ok( !$cancelled, 'no CANCEL block for done sub' ); } # Not cancelled for failure { my $cancelled; my $f1 = Future->new; my $fret = (async sub { CANCEL { $cancelled++; } await $f1; die "Oops!\n"; })->(); $fret->get if $fret->is_failed; # report errors $f1->done; ok( $fret->is_failed, '$fret failed' ); ok( !$cancelled, 'no CANCEL block for failed sub' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/10pad.t000444001750001750 405514476650556 15221 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; use List::Util qw( sum ); # single scalar { async sub with_scalar { my $scalar = "true"; await $_[0]; return $scalar; } my $f1 = Future->new; my $fret = with_scalar( $f1 ); ok( !$fret->is_ready, '$fret is not immediate with_scalar' ); $f1->done; is( scalar $fret->get, "true", '$fret now ready after done' ); } # single array { async sub with_array { my @array = (1, 2, 3); await $_[0]; return sum @array; } my $f1 = Future->new; my $fret = with_array( $f1 ); ok( !$fret->is_ready, '$fret is not immediate with_array' ); $f1->done; is( scalar $fret->get, 6, '$fret now ready after done' ); } # Captured outside { { # Ensure the captured lexical lives in its own scope that is ended before # the tests run my $capture = "outer"; async sub inner { await $_[0]; return $capture; } } my $f1 = Future->new; my $fret = inner( $f1 ); ok( !$fret->is_ready, '$fret is not immediate with capture' ); $f1->done; is( scalar $fret->get, "outer", '$fret now ready after done' ); } # Closure with outside # Make sure to test this twice because of pad lexical sharing - see RT124026 { my $capture = "outer"; my $closure = async sub { $capture .= "X"; await $_[0]; return $capture; }; my $f1 = Future->new; my $f2 = Future->new; my $fret = Future->needs_all( $closure->( $f1 ), $closure->( $f2 ), ); $f1->done; $f2->done; is( [ $fret->get ], [ "outerXX", "outerXX" ], '$fret now ready after done for closure' ); } # Closure with `our` capture (RT132945) { our $capture = "outer"; my $closure = async sub { $capture .= "X"; await $_[0]; return $capture; }; my $f1 = Future->new; my $fret = $closure->( $f1 ); $f1->done; is( $fret->get, "outerX", '$fret now ready after done for closure with our capture' ); } done_testing; Future-AsyncAwait-0.66/t/11contexts.t000444001750001750 307214476650556 16323 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # if await in cond { async sub with_if_cond { if( await $_[0] ) { return "true"; } else { return "false"; } } my $f1 = Future->new; my $fret = with_if_cond( $f1 ); ok( !$fret->is_ready, '$fret not immediate with_if_cond' ); $f1->done( 1 ); is( scalar $fret->get, "true", '$fret now ready after done' ); } # if await in body { async sub with_if_body { if( $_[0] ) { return await $_[1]; } else { return "immediate"; } } my $f1 = Future->new; my $fret = with_if_body( 1, $f1 ); $f1->done( "defer" ); is( scalar $fret->get, "defer", '$fret now ready after done in if body' ); $fret = with_if_body( 0, undef ); is( scalar $fret->get, "immediate", '$fret now ready after done in if body immediate' ); } # do await in body { async sub with_do_body { return 1 + do { my $f = $_[0]; await $f; }; } my $f1 = Future->new; my $fret = with_do_body( $f1 ); $f1->done( 10 ); is( scalar $fret->get, 11, '$fret now ready after done in do body' ); } # await in eval{} { async sub with_eval { my $f = shift; local $@; my $ret = eval { await $f; return "tried"; } or die $@; return "($ret)"; } my $f1 = Future->new; my $fret = with_eval( $f1 ); $f1->done; is( scalar $fret->get, "(tried)", '$fret now ready after done in eval' ); } done_testing; Future-AsyncAwait-0.66/t/12closure.t000444001750001750 153614476650556 16134 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # creating a closure inside an async sub # before await { my $f1 = Future->new; my $sub; async sub closure_before { my $x = 44; # just to create a real closure $sub = sub { $x++; 123 }; $sub->(); await $f1; return $x; } my $f = closure_before(); $f1->done; is( $f->get, 45, 'result of async sub' ); is( $sub->(), 123, 'result of closure before' ); } # after await { my $f1 = Future->new; my $sub; async sub closure_after { await $f1; my $x = 44; $sub = sub { $x++; 123 }; $sub->(); return $x; } my $f = closure_after(); $f1->done; is( $f->get, 45, 'result of async sub' ); is( $sub->(), 123, 'result of closure after' ); } done_testing; Future-AsyncAwait-0.66/t/13regexp.t000444001750001750 136514476650556 15753 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # Try to trigger SAVEt_FREEPV { my $f1 = Future->new; my $fret = (async sub { my $bytes = "abcdefghijklmnopq"; my $maxchunk = 6; my @chunks = $bytes =~ m/(.{1,$maxchunk})/gs; my $ret = ""; await $f1; return scalar @chunks; })->(); $f1->done; is( scalar $fret->get, 3, 'chunks' ); } # await over regexp (RT129321) { my $f1 = Future->new; my $fret = (async sub { my $string = "Hello, world"; $string =~ m/^(.*),/; await $f1; return $1, $-[1], $+[1]; })->(); $f1->done; is( [ $fret->get ], [ "Hello", 0, 5 ], 'await restores regexp context' ); } done_testing; Future-AsyncAwait-0.66/t/14packagevar.t000444001750001750 65414476650556 16546 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # single scalar { our $VAR = "some variable"; async sub with_pkgvar { my $copy = "VAR is $VAR"; await $_[0]; return "<$VAR>"; } my $f1 = Future->new; my $fret = with_pkgvar( $f1 ); $f1->done; is( scalar $fret->get, "", '$fret now ready after done' ); } done_testing; Future-AsyncAwait-0.66/t/15local-errsv.t000444001750001750 307714476650556 16716 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; my $errgv_ref = \*@; # $@ can be localized # For some odd reason, SvREFCNT(PL_errgv) increases by 1 the first time # this code is run, but is stable thereafter. So only test it the second # time. Perhaps something somewhere needs to get lazily created? foreach my $idx ( 1, 2 ) { my $errsv_refcount = refcount(\$@); my $errgv_refcount = refcount($errgv_ref); my $f1 = Future->new; my $fret = (async sub { local $@ = "inside"; await $f1; return $@; })->(); $@ = "OUTSIDE"; $f1->done; is( scalar $fret->get, "inside", 'result from async sub with local $@' ); is_refcount( \$@, $errsv_refcount, '$@ refcount preserved' ); is_refcount( $errgv_ref, $errgv_refcount, '*@ refcount preserved' ) if $idx > 1; } # localised $@ plays nicely with eval{} { my $errsv_refcount = refcount(\$@); my $errgv_refcount = refcount($errgv_ref); my $f1 = Future->new; my $fret = (async sub { local $@ = "inside"; await $f1; eval { die "oopsie\n"; }; return $@; })->(); $@ = "OUTSIDE"; $f1->done; is( scalar $fret->get, "oopsie\n", 'result from eval { die }' ); is_refcount( \$@, $errsv_refcount, '$@ refcount preserved' ); is_refcount( $errgv_ref, $errgv_refcount, '*@ refcount preserved' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/16state.t000444001750001750 162014476650556 15576 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # sequential { async sub with_state { state $var = 5; await $_[0]; return "<$var>"; } my $f1 = Future->new; my $fret1 = with_state( $f1 ); $f1->done; is( scalar $fret1->get, "<5>", '$fret now ready after done' ); my $f2 = Future->new; my $fret2 = with_state( $f2 ); $f2->done; is( scalar $fret2->get, "<5>", '$fret now ready after done a second time' ); } # concurrent (RT139821) { async sub with_state2 { state $var = 10; await $_[0]; return "<$var>"; } my @f = map { Future->new } 1 .. 2; my @fret = map { with_state2 $_ } @f; $f[0]->done; $f[1]->done; is( scalar $fret[0]->get, '<10>', 'Result of first invocation' ); is( scalar $fret[1]->get, '<10>', 'Result of second invocation' ); } done_testing; Future-AsyncAwait-0.66/t/17snail.t000444001750001750 112414476650556 15564 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; $^V ge v5.24.0 or plan skip_all => "This test requires perl 5.24.0"; use Future; use Future::AsyncAwait; # RT130683 { my @waitf; async sub do_wait { push @waitf, my $f = Future->new; await $f; } async sub check_args { await do_wait; is( scalar @_, 9, 'Snail still has 9 values in it' ) or diag( "Snail is: <@_>" ); } async sub run { my @args = 1 .. 9; await check_args @args; } my $f = run(); ( shift @waitf )->done; $f->get; } done_testing; Future-AsyncAwait-0.66/t/20context-block.t000444001750001750 224014476650556 17224 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; sub Destructor::DESTROY { ${ shift->[0] }++ } # block with CLEARSV { my $destroyed; async sub with_block { my ( $f ) = @_; my $cond = 1; if( $cond ) { my $x = bless [ \$destroyed ], "Destructor"; await $f; } return "result"; } my $f1 = Future->new; my $fret = with_block( $f1 ); ok( !$fret->is_ready, '$fret not immediate with_block' ); ok( !$destroyed, '$x not yet destroyed' ); $f1->done; is( scalar $fret->get, "result", '$fret now ready after done' ); ok( $destroyed, '$x was destroyed' ); } # block with CLEARPADRANGE { my $destroyed; async sub with_block_padrange { my ( $f ) = @_; my $cond = 1; if( $cond ) { my ( $x, $y, $z ) = ( 1, 2, bless [ \$destroyed ], "Destructor" ); await $f; } return "done"; } my $f1 = Future->new; my $fret = with_block_padrange( $f1 ); $f1->done; is( scalar $fret->get, "done", '$fret now ready after done with padrange' ); ok( $destroyed, '$z was destroyed' ); } done_testing; Future-AsyncAwait-0.66/t/21context-while.t000444001750001750 310614476650556 17245 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # while await in body { my @F = map { Future->new } 1 .. 3; async sub with_while_body { while( @F ) { await $F[0]; shift @F; } return "end while"; } my $fret = with_while_body(); $F[0]->done; $F[0]->done; $F[0]->done; is( scalar $fret->get, "end while", '$fret now ready after while loop with body finishes' ); } # while await in condition { my @F = map { Future->new } 1 .. 3; async sub with_while_cond { while( await $F[0] ) { shift @F; } return "end while"; } my $fret = with_while_cond(); $F[0]->done( 1 ); $F[0]->done( 1 ); $F[0]->done( 0 ); is( scalar $fret->get, "end while", '$fret now ready after while loop with cond finishes' ); } # last inside while await { my $f1 = Future->new; async sub with_while_last { while( 1 ) { await $f1; last; } return "end while"; } my $fret = with_while_last(); $f1->done; is( scalar $fret->get, "end while", '$fret now ready after while loop with last' ); } # next inside while await { my $f1 = Future->new; async sub with_while_next { my $continue = 1; while( $continue ) { await $f1; $continue = 0; next; die "Unreachable"; } return "end while"; } my $fret = with_while_next(); $f1->done; is( scalar $fret->get, "end while", '$fret now ready after while loop with next' ); } done_testing; Future-AsyncAwait-0.66/t/22context-foreach.t000444001750001750 1064514476650556 17573 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # foreach(ARRAY) await { my @F = map { Future->new } 1 .. 3; async sub with_foreach_array { foreach my $f ( @F ) { defined $f or die "ARGH: expected a Future"; await $f; } return "end foreach"; } my $fret = with_foreach_array(); $F[0]->done; $F[1]->done; $F[2]->done; is( scalar $fret->get, "end foreach", '$fret now ready after foreach(ARRAY) loop' ); } # foreach(LIST) await { my @F = map { Future->new } 1 .. 3; async sub with_foreach_list { foreach my $f ( $F[0], $F[1], $F[2] ) { defined $f or die "ARGH: expected a Future"; await $f; } return "end foreach"; } my $fret = with_foreach_list(); $F[0]->done; $F[1]->done; $F[2]->done; is( scalar $fret->get, "end foreach", '$fret now ready after foreach(LIST) loop' ); } # foreach(LAZY IV) await { my @F = map { Future->new } 1 .. 3; async sub with_foreach_lazy_iv { foreach my $idx ( 0 .. 2 ) { defined $idx or die "ARGH: Expected an integer index"; await $F[$idx]; } return "end foreach"; } my $fret = with_foreach_lazy_iv(); $F[0]->done; $F[1]->done; $F[2]->done; is( scalar $fret->get, "end foreach", '$fret now ready after foreach(LAZY IV) loop' ); } # foreach(LAZY SV) await { my %F = map { $_ => Future->new } 'a' .. 'c'; async sub with_foreach_lazy_sv { foreach my $key ( 'a' .. 'c' ) { defined $key or die "ARGH: Expected a string key"; await $F{$key}; } return "end foreach"; } my $fret = with_foreach_lazy_sv(); $F{a}->done; $F{b}->done; $F{c}->done; is( scalar $fret->get, "end foreach", '$fret now ready after foreach(LAZY SV) loop' ); } # RT#124144 { my $f1 = Future->new; my $f2 = Future->new; async sub with_foreach_await_twice { foreach my $x ( 0 ) { await $f1; await $f2; } return "awaited twice"; } my $fret = with_foreach_await_twice(); $f1->done; $f2->done; is( scalar $fret->get, "awaited twice", '$fret now ready after foreach with two awaits' ); } # RT#129215 { my @F = map { Future->new } 0, 1, 2; my $fret = (async sub { foreach my $idx ( 0, 1, 2 ) { await $F[$idx]; } return "OK"; })->(); # Arrange for the stack to be at different heights on each resume my $tmp = do { 1 + ( $F[0]->done // 0 ) }; $tmp = [ 2, 3, [ $F[1]->done ] ]; $tmp = 4 * ( 6 + ( $F[2]->done // 0 ) ); is( scalar $fret->get, "OK", '$fret now ready after differing stack resumes' ); } # RT#129319 - foreach(LIST) with extra values { my @F = map { Future->new } 0, 1, 2; my $fret = (async sub { my $ret = ""; foreach my $idx ( 0, 1, 2 ) { # $ret will appear on the stack after the foreach-LIST items $ret .= await $F[$idx]; } return $ret; })->(); $F[0]->done( "A" ); $F[1]->done( "B" ); $F[2]->done( "C" ); is( scalar $fret->get, "ABC", '$fret now ready after await with stack items before LIST' ); } # RT#129319 - foreach(LIST) with extra marks { my @F = map { Future->new } 0, 1, 2; my $fret = (async sub { my @values; foreach my $idx ( 0, 1, 2 ) { # push list creates an extra mark push @values, "(", await $F[$idx], ")"; } return join "", @values; })->(); $F[0]->done( "A" ); $F[1]->done( "B" ); $F[2]->done( "C" ); is( scalar $fret->get, "(A)(B)(C)", '$fret now ready after await with stack marks before LIST' ); } SKIP: { skip "IO::Async::Loop not available", 1 unless eval { require IO::Async::Loop; }; my $loop = IO::Async::Loop->new; my $out = ""; (async sub { foreach my $k (qw( one two three four )) { $out .= "$k\n"; await $loop->delay_future(after => 0.01); $out .= "$k\n"; } })->()->get; is( $out, "one\none\ntwo\ntwo\nthree\nthree\nfour\nfour\n", 'Output from sleepy foreach(LIST)' ); } { our $VAR; my $f1; my $ok = !eval q{ async sub foreach_pkgvar { foreach $VAR ( 1 .. 3 ) { await $f1; } } }; my $e = $@; ok( $ok, 'await in non-lexical foreach loop fails to compile' ); $ok and like( $e, qr/^await is not allowed inside foreach on non-lexical iterator variable /, '' ); } done_testing; Future-AsyncAwait-0.66/t/23context-map.t000444001750001750 124214476650556 16713 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # await inside map { my $ok = !eval q{ async sub with_map { map { await $_[0]; } 1 .. 3 } }; my $e = $@; ok( $ok, 'await in map fails to compile' ); $ok and like( $e, qr/^await is not allowed inside map /, '' ); } # await inside grep { my $ok = !eval q{ async sub with_grep { grep { await $_[0]; } 1 .. 3 } }; my $e = $@; ok( $ok, 'await in grep fails to compile' ); $ok and like( $e, qr/^await is not allowed inside grep /, '' ); } done_testing; Future-AsyncAwait-0.66/t/24context-foreach-list.t000444001750001750 264614476650556 20530 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "This test requires perl 5.35.5" unless $] >= 5.035005 } use experimental 'for_list'; use Future; use Future::AsyncAwait; # foreach(ARRAY) await { my @idxF = map { $_ => Future->new } 1 .. 3; my @result; async sub with_foreach_list_array { foreach my ( $idx, $f ) ( @idxF ) { defined $f or die "ARGH: expected a Future at idx $idx"; await $f; push @result, ( $idx, $f ); } return "end foreach"; } my $fret = with_foreach_list_array(); $idxF[1]->done; $idxF[3]->done; $idxF[5]->done; is( scalar $fret->get, "end foreach", '$fret now ready after foreach(ARRAY) loop' ); is( \@result, \@idxF, '@result after foreach(ARRAY) loop' ); } # foreach(LIST) await { my @F = map { Future->new } 1 .. 3; my @result; async sub with_foreach_list_list { foreach my ( $idx, $f ) ( 0 => $F[0], 1 => $F[1], 2 => $F[2] ) { defined $f or die "ARGH: expected a Future at idx $idx"; await $f; push @result, ( $idx, $f ); } return "end foreach"; } my $fret = with_foreach_list_list(); $F[0]->done; $F[1]->done; $F[2]->done; is( scalar $fret->get, "end foreach", '$fret now ready after foreach(LIST) loop' ); is( \@result, [ 0 => $F[0], 1, => $F[1], 2 => $F[2] ], '@result after foreach(LIST) loop' ); } done_testing; Future-AsyncAwait-0.66/t/30stringeval.t000444001750001750 147214476650556 16635 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; async sub identity { await $_[0]; } # invoking async/await entirely from within a string eval { ok eval q{ my $f1 = Future->new; my $f2 = identity( $f1 ); $f1->done( 1 ); $f2->get; }, 'async/await from within string eval'; } # await at string-eval level should be forbidden (RT126035) { my $ok; my $e; (async sub { $ok = !eval q{await $_[0]}; $e = $@; })->(); ok( $ok, 'await in string eval fails to compile' ); $ok and like( $e, qr/^await is not allowed inside string eval /, '' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/31destroy.t000444001750001750 235514476650556 16152 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_oneref use Scalar::Util qw( reftype ); use Future; use Future::AsyncAwait; { async sub identity { await $_[0]; } my $f1 = Future->new; my $fret = identity( $f1 ); # At this point we want to grab the generated CV that's now been pushed as # a callback of $f1. # This code is probably going to be very fragile, so we'll silently skip it # if it fails to work my $generated_cv; if( reftype $f1 eq "HASH" and $f1->{callbacks} and @{ $f1->{callbacks} } and $f1->{callbacks}[0] and ref $f1->{callbacks}[0][1] eq "CODE" ) { $generated_cv = $f1->{callbacks}[0][1]; } my $destroyed; sub Destructor::DESTROY { $destroyed++ } $f1->done( bless [], "Destructor" ); is_oneref( $f1, '$f1 should have one ref' ); undef $f1; ok( !$destroyed, 'Not destroyed before $fret->get' ); $fret->get; ok( !$destroyed, 'Not destroyed after $fret->get' ); is_oneref( $fret, '$fret should have one ref' ); undef $fret; ok( $destroyed, 'Destroyed by dropping $fret' ); $generated_cv and is_oneref( $generated_cv, '$generated_cv should have one ref' ); undef $generated_cv; } done_testing; Future-AsyncAwait-0.66/t/32compile-errors.t000444001750001750 373014476650556 17422 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future::AsyncAwait; use constant HAVE_XPK_0_09 => ( $XS::Parse::Keyword::VERSION >= 0.09 ); # All of these should fail to compile but not SEGV. If we get to the end of # the script without segfaulting, we've passed. # RT129987 ok( !defined eval q' async sub foo { ', 'RT129987 test case 1 does not segfault' ); SKIP: { eval { require Syntax::Keyword::Try } or skip "No Syntax::Keyword::Try", 1; ok( !defined eval q' use Syntax::Keyword::Try; my $pending = Future->new; my $pending2 = Future->new; my $final = (async sub { my ($f) = @_; try { await $f; my $nested = async sub { await shift; })->($pending2); return await $nested; } catch { } })->($pending); ', 'RT129987 test case 2 does not segfault' ); } # RT129987 ok( !defined eval q' (async sub { my $x = async sub { await 1; }) ', 'RT129987 test case 3 does not segfault' ); # RT130417 { local $@; ok( !defined eval q' package segfault; use strict; use warnings; use Future::AsyncAwait; async sub example { $x } ', 'RT130417 strict-failing code fails to compile' ); like( "$@", qr/^Global symbol "\$x" requires explicit package name/, 'Failure message complains about undeclared $x' ); } # RT131487 { local $@; my $err = HAVE_XPK_0_09 ? qr/^parse failed--compilation aborted / : qr/^Global symbol "\$api" requires explicit package name/; ok( !defined eval q' package segfault; use strict; use warnings; use Future::AsyncAwait; (async sub { for my $i (1..5) { await $api->method; } })->()->get; ', 'RT131487 strict-failing code fails to compile' ); like( "$@", $err, 'Failure message complains about undeclared $api' ); } done_testing; Future-AsyncAwait-0.66/t/40croak.t000444001750001750 57714476650556 15544 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; { my $f1 = Future->new; async sub with_failure { await $f1; Carp::confess "message here"; } my $fret = with_failure(); $f1->done; like( $fret->failure, qr/main::with_failure/, '$fret->failure message contains function name' ); } done_testing; Future-AsyncAwait-0.66/t/41end.t000444001750001750 43214476650556 15202 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my $f1 = Future->new; async sub func { await $f1 } # RT126036 END { my $f2 = func(); $f1->done( 1 ); ok scalar $f2->get, "async/await works at END time"; done_testing; } Future-AsyncAwait-0.66/t/42unresolved.t000444001750001750 627614476650556 16657 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; my $file = quotemeta __FILE__; my $errgv_ref = \*@; async sub identity { return await $_[0]; } async sub func { my ( $f, @vals ) = @_; my $pad = "foo" . ref($f); my $x = 123; $x + 1 + [ "a", await identity $f ]; } # abandoned chain { my $f1 = Future->new; my $fret = func( $f1, 1, 2 ); undef $fret; pass( 'abandoned chain does not crash' ); } # abandoned subsequent (RT129303) { my $f1 = Future->new; my $fret = func( $f1, 3, 4 ); undef $fret; my $warnings = ""; { local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; $f1->done; } pass( 'abandoned subsequent does not crash' ); like( $warnings, qr/^Suspended async sub main::func lost its returning future at $file line \d+/, 'warning from attempted resume' ); } # abandoned by code itself while not awaiting { my $fret; async sub abandon { my ( $f1, $f2 ) = @_; await $f1; undef $fret; await $f2; } $fret = abandon( my $f1 = Future->new, my $f2 = Future->new ); my $warnings = ""; { local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; $f1->done; } pass( 'abandoned by non-await code does not crash' ); like( $warnings, qr/^Suspended async sub main::abandon lost its returning future at $file line \d+/, 'warning from attempted resume' ); $f2->cancel; } # abandoned by code itself that throws { my $fret; async sub abandon_and_die { my ( $f1 ) = @_; await $f1; undef $fret; die "Oopsie\n"; } $fret = abandon_and_die( my $f1 = Future->new ); my $warnings = ""; { local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; $f1->done; } pass( 'abandoned by non-await code does not crash' ); like( $warnings, qr/^Abandoned async sub main::abandon_and_die failed: Oopsie$/m, 'warning from attempted resume' ); } # abandoned subsequent on anon sub { my $f1 = Future->new; my $fret = (async sub { await $f1 })->(); undef $fret; my $warnings = ""; { local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; $f1->done; } pass( 'abandoned subsequent does not crash' ); like( $warnings, qr/^Suspended async sub CODE\(0x[0-9a-f]+\) in package main lost its returning future at $file line \d+/, 'warning from attempted resume' ); } # abandoned foreach loop (RT129320) { my $f1 = Future->new; my $fret = (async sub { foreach my $f ($f1) { await $f } })->(); undef $fret; pass( "abandoned foreach loop does not crash" ); } # abandoned local $@ { my $errsv_refcount = refcount(\$@); my $errgv_refcount = refcount($errgv_ref); my $f1 = Future->new; my $fret = (async sub { local $@; await $f1 })->(); undef $fret; undef $f1; pass( "abandoned local \$@ does not crash" ); is_refcount( \$@, $errsv_refcount, '$@ refcount preserved' ); is_refcount( $errgv_ref, $errgv_refcount, '*@ refcount preserved' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.66/t/43failure.t000444001750001750 333414476650556 16111 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; async sub identity { return await $_[0]; } # die in async is transparent to thrown objects { my $fret = (async sub { die bless [qw( a b c )], "TestException"; })->(); ok( $fret->is_failed, '$fret failed after die in async' ); is( ref $fret->failure, "TestException", 'die in async preserves object' ); is( [ @{ $fret->failure } ], [qw( a b c )], 'die in async preserves object contents' ); } # await is transparent to thrown objects { my $f1 = Future->new; my $fret = (async sub { eval { await $f1 } or return $@; })->(); $f1->fail( bless [qw( d e f )], "TestException" ); is( ref $fret->get, "TestException", 'await failure preserves object' ); is( [ @{ $fret->get } ], [qw( d e f )], 'await failure preserves object contents' ); } # async/await is transparent to thrown objects { my $f1 = Future->new; my $fret = identity( $f1 ); $f1->fail( bless [qw( g h i )], "TestException" ); ok( $fret->is_failed, '$fret failed after die in async/await' ); is( ref $fret->failure, "TestException", 'die in async/await preserves object' ); is( [ @{ $fret->failure } ], [qw( g h i )], 'die in async/await preserves object contents' ); } # async/await is transparent to failures SKIP: { skip "This test requires Future version 0.40", 1 unless $Future::VERSION >= 0.40; my $f1 = Future->new; my $fret = identity( $f1 ); $f1->fail( "message\n", category => qw( details here ) ); ok( $fret->is_failed, '$fret failed after ->fail' ); is( [ $fret->failure ], [ "message\n", category => qw( details here ) ], '$fret->failure after ->fail' ); } done_testing; Future-AsyncAwait-0.66/t/44sub-attrs.t000444001750001750 215414476650556 16406 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use attributes; use Future::AsyncAwait; # :method { async sub is_method :method { } my $cvf_method = grep { m/^method$/ } attributes::get( \&is_method ); ok( $cvf_method, '&is_method has :method' ); } # :lvalue - accepted but should warn { my $warning; BEGIN { $SIG{__WARN__} = sub { $warning++ } } async sub is_lvalue :lvalue { } my $cvf_lvalue = grep { m/^lvalue$/ } attributes::get( \&is_lvalue ); ok( $cvf_lvalue, '&is_lvalue has :lvalue' ); ok( $warning, 'async sub :lvalue produces a warning' ); BEGIN { undef $SIG{__WARN__} } } # :const happens to break currently, but it would be meaningless anyway # some custom ones { package TestCustomAttrs; my $modify_invoked; sub MODIFY_CODE_ATTRIBUTES { my ( $pkg, $sub, $attr ) = @_; $modify_invoked++; ::is( $attr, "MyCustomAttribute(value here)", 'MODIFY_CODE_ATTRIBUTES takes attr' ); return (); } async sub is_attributed :MyCustomAttribute(value here) { } ::ok( $modify_invoked, 'MODIFY_CODE_ATTRIBUTES invoked' ); } done_testing; Future-AsyncAwait-0.66/t/45sub-signatures.t000444001750001750 342714476650556 17442 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } use feature 'signatures'; no warnings 'experimental'; use Future::AsyncAwait; { async sub add ( $x, $y ) { return $x + $y; } my $f = add( 2, 3 ); is( $f->get, 5, 'add(2,3)' ); } # return in argument default still Future-wraps { async sub identity ( $x, $y = return $x ) { } my $f = identity( 123 ); isa_ok( $f, [ "Future" ], '$f' ); is( $f->get, 123, '$f->get on return in arg default' ); } # argcount exceptions are thrown synchronously { async sub one_arg ( $x ) { return $x; } like( dies { my $f = one_arg() }, qr/^Too few arguments for subroutine 'main::one_arg'/, 'argcheck failure happens synchronously' ); like( dies { my $f = one_arg( 1, 2 ) }, qr/^Too many arguments for subroutine 'main::one_arg'/, 'argcheck failure happens synchronously' ); } # The following are additional tests that our pre-5.31.3 backported # parse_subsignature() works correctly { async sub sum ( @x ) { my $ret = 0; $ret += $_ for @x; return $ret; } my $f = sum( 10, 20, 30 ); is( $f->get, 60, 'parsed slurpy parameter' ); async sub firstandthird($x, $, $z) { return $x . $z; } $f = firstandthird(qw( a b c )); is( $f->get, "ac", 'parsed unnamed parameter' ); async sub withdefault ( $one = 1, $two = 2 ) { return $one + $two; } $f = withdefault(); is( $f->get, 3, 'parsed parameters with default expr' ); } # RT131571 { ok( defined eval q{ use experimental 'signatures'; async sub func :method ( $self, @args ) { } 1; }, 'signatures do not leak into attributes (RT131571)' ) or diag( "Error was $@" ); } done_testing; Future-AsyncAwait-0.66/t/50future-subclass.t000444001750001750 111314476650556 17600 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; package SubclassOfFuture { use base qw( Future ); } { use Future::AsyncAwait future_class => "SubclassOfFuture"; BEGIN { # gutwrenching ok( defined $^H{"Future::AsyncAwait/future"}, '%^H is set inside block' ); } async sub func { return 123 } } # Is %^H well-behaved? { ok( !defined $^H{"Future::AsyncAwait/future"}, '%^H restored outside block' ); } { my $f = func(); isa_ok( $f, [ "SubclassOfFuture" ], 'result of async sub func' ); is( $f->get, 123, '$f->get' ); } done_testing; Future-AsyncAwait-0.66/t/51awaitable-role.t000444001750001750 116014476650556 17344 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; eval { require Role::Tiny; 1 } or plan skip_all => "No Role::Tiny"; use Future::AsyncAwait::Awaitable; pass( "doesn't crash" ); package Test::NotAwaitable { require Role::Tiny::With; Role::Tiny::With->import; ::ok( !eval { with( "Future::AsyncAwait::Awaitable" ); }, 'Test package is not Future::AsyncAwait::Awaitable' ); # Possibly a fragile test, in case of changes of error message text ::like( $@, qr/^Can't apply Future::AsyncAwait::Awaitable to Test::NotAwaitable /, 'exception from unapplicable role' ); } done_testing; Future-AsyncAwait-0.66/t/52awaitable-future.t000444001750001750 43514476650556 17702 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Test::Future::AsyncAwait::Awaitable qw( test_awaitable ); use Future; use Future::AsyncAwait; # for the back-compat shim test_awaitable "Future", class => "Future", cancel => sub { shift->cancel }; done_testing; Future-AsyncAwait-0.66/t/70await+feature-class.t000444001750001750 350714476650556 20323 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_oneref BEGIN { plan skip_all => "Future >= 0.49 is not available" unless eval { require Future; Future->VERSION( '0.49' ) }; plan skip_all => "Future::AsyncAwait >= 0.45 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.45' ) }; # version 5.37.10 added the ability to start_subparse() with CVf_IsMETHOD, # which we need plan skip_all => "feature 'class' is not available" unless $^V ge v5.37.10; plan skip_all => "XS::Parse::Sublike >= 0.17 is not in use" unless $XS::Parse::Sublike::VERSION >= 0.17; # If Future::XS is installed, then check it's at least 0.08; earlier # versions will crash if( eval { require Future::XS } ) { plan skip_all => "Future::XS is installed but it is older than 0.08" unless eval { Future::AsyncAwait->VERSION( '0.08' ); }; } diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "core perl version $^V" ); } use Future::AsyncAwait; use feature 'class'; no warnings 'experimental::class'; # async method { class Thunker { field $_times_thunked = 0; method count { $_times_thunked } async method thunk { my ( $f ) = @_; await $f; $_times_thunked++; return "result"; } } my $thunker = Thunker->new; is_oneref( $thunker, 'after ->new' ); my $f1 = Future->new; my $fret = $thunker->thunk( $f1 ); is_refcount( $thunker, 2, 'during async sub' ); is( $thunker->count, 0, 'count is 0 before $f1->done' ); $f1->done; is_oneref( $thunker, 'after ->done' ); is( $thunker->count, 1, 'count is 1 after $f1->done' ); is( $fret->get, "result", '$fret for await in async method' ); } done_testing; Future-AsyncAwait-0.66/t/70await+feature-try.t000444001750001750 457514476650556 20042 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.10 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.10' ) }; plan skip_all => "feature 'try' is not available" unless $] >= 5.033007; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "core perl version $^V" ); } use Future::AsyncAwait; use feature 'try'; no warnings 'experimental::try'; # 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 toplevel try { try { is( await Future->done( "success" ), "success", 'await in toplevel try' ); } catch ($e) { 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; Future-AsyncAwait-0.66/t/80async-method.t000444001750001750 461314476650556 17057 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount BEGIN { plan skip_all => "Future >= 0.49 is not available" unless eval { require Future; Future->VERSION( '0.49' ) }; plan skip_all => "Future::AsyncAwait >= 0.45 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.45' ) }; plan skip_all => "Object::Pad >= 0.800 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.800' ) }; # If Future::XS is installed, then check it's at least 0.08; earlier # versions will crash if( eval { require Future::XS } ) { plan skip_all => "Future::XS is installed but it is older than 0.08" unless eval { Future::AsyncAwait->VERSION( '0.08' ); }; } Future::AsyncAwait->import; Object::Pad->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Object::Pad $Object::Pad::VERSION" ); } # async method { class Thunker { field $_times_thunked = 0; method count { $_times_thunked } async method thunk { my ( $f ) = @_; await $f; $_times_thunked++; return "result"; } } my $thunker = Thunker->new; is_oneref( $thunker, 'after ->new' ); my $f1 = Future->new; my $fret = $thunker->thunk( $f1 ); is_refcount( $thunker, 3, 'during async sub' ); # +1 because $self, +1 because of @(Object::Pad/slots) pseudolexical is( $thunker->count, 0, 'count is 0 before $f1->done' ); $f1->done; is_oneref( $thunker, 'after ->done' ); is( $thunker->count, 1, 'count is 1 after $f1->done' ); is( $fret->get, "result", '$fret for await in async method' ); } # RT133564 { # Hard to test this one but running the test itself shouldn't produce any # warnings of "Attempt to free unreferenced scalar ..." my $thunker = Thunker->new; eval { my $f = $thunker->thunk( Future->new ); die "Oopsie\n"; }; ok( 1, "No segfault for RT133564 test" ); } # RT137649 { my $waitf; role Role { async method m { await $waitf = Future->new } } class Class :does(Role) {} my $obj = Class->new; my $f1 = $obj->m; $waitf->done( "first" ); is( await $f1, "first", 'First call OK' ); my $f2 = $obj->m; $waitf->done( "second" ); is( await $f2, "second", 'Second call OK' ); } done_testing; Future-AsyncAwait-0.66/t/80async-multi-sub.t000444001750001750 237014476650556 17516 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "signatures are not availble" unless $] >= 5.026; } use feature 'signatures'; no warnings 'experimental::signatures'; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.55 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.55' ) }; plan skip_all => "Syntax::Keyword::MultiSub >= 0.01 is not available" unless eval { require Syntax::Keyword::MultiSub; Syntax::Keyword::MultiSub->VERSION( '0.01' ) }; Future::AsyncAwait->import; Syntax::Keyword::MultiSub->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Syntax::Keyword::MultiSub $Syntax::Keyword::MultiSub::VERSION" ); } async multi sub f () { return "null"; } async multi sub f ( $x ) { return "un($x)"; } is( await f(), "null", 'f() on zero args' ); is( await f( 1 ), "un(1)", 'f() on one arg' ); # Ordering shouldn't matter multi async sub g () { return "also-null"; } multi async sub g ( $x ) { return "also-un($x)"; } is( await g(), "also-null", 'g() on zero args' ); done_testing; Future-AsyncAwait-0.66/t/80await+SKT.t000444001750001750 626214476650556 16230 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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; Future-AsyncAwait-0.66/t/80await+defer.t000444001750001750 317214476650556 16651 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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::Defer >= 0.02 is not available" unless eval { require Syntax::Keyword::Defer; Syntax::Keyword::Defer->VERSION( '0.02' ) }; Future::AsyncAwait->import; Syntax::Keyword::Defer->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Syntax::Keyword::Defer $Syntax::Keyword::Defer::VERSION" ); } # defer before await { my $ok; my $f1 = Future->new; my $fret = (async sub { defer { $ok = "1" } await $f1; return "result"; })->(); ok( !defined $ok, '$ok not yet defined' ); $f1->done; is( await $fret, "result", '$fret yields result' ); is( $ok, "1", '$ok after ->done' ); } # defer after await { my $ok; my $f1 = Future->new; my $fret = (async sub { await $f1; defer { $ok = "2" } return "result"; })->(); ok( !defined $ok, '$ok not yet defined' ); $f1->done; is( await $fret, "result", '$fret yields result' ); is( $ok, "2", '$ok after ->done' ); } # defer still runs for cancel (RT135351) { my $ok; my $f1 = Future->new; my $fret = (async sub { defer { $ok++ } await $f1; })->(); ok( !$ok, 'defer {} not run before ->cancel' ); $fret->cancel; ok( $ok, 'defer {} was run after ->cancel' ); } done_testing; Future-AsyncAwait-0.66/t/80await+dynamically.t000444001750001750 1165614476650556 20120 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.31_002 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.31_002' ) }; plan skip_all => "Syntax::Keyword::Dynamically >= 0.02 is not available" unless eval { require Syntax::Keyword::Dynamically; Syntax::Keyword::Dynamically->VERSION( '0.02' ) }; Future::AsyncAwait->import; Syntax::Keyword::Dynamically->import(qw( -async )); diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Syntax::Keyword::Dynamically $Syntax::Keyword::Dynamically::VERSION" ); } { my $var = 1; async sub with_dynamically { my $f = shift; dynamically $var = 2; is( $var, 2, '$var is 2 before await' ); await $f; is( $var, 2, '$var is 2 after await' ); return "result"; } my $f1 = Future->new; my $fret = with_dynamically( $f1 ); is( $var, 1, '$var is 1 while suspended' ); $f1->done; is( scalar $fret->get, "result", '$fret for dynamically in async sub' ); is( $var, 1, '$var is 1 after finish' ); } # multiple nested scopes { my $var = 1; my @f; sub tick { push @f, my $f = Future->new; return $f } async sub with_dynamically_nested { dynamically $var = 2; { dynamically $var = 3; await tick(); is( $var, 3, '$var is 3 in inner scope' ); } is( $var, 2, '$var is 2 in outer scope' ); await tick(); is( $var, 2, '$var is still 2 in outer scope' ); } my $fret = with_dynamically_nested(); is( $var, 1, '$var is 1 while suspended' ); while( @f ) { ( shift @f )->done; is( $var, 1, '$var is still 1' ); } $fret->get; is( $var, 1, '$var is 1 after finish' ); } # OP_HELEM_DYN is totally different in async mode { my %hash = my %orig = ( key => "old", delkey => "gone", ); async sub with_dynamically_helem { my $f = shift; dynamically $hash{key} = "new"; dynamically $hash{newkey} = "added"; dynamically $hash{delkey} = "begone!"; delete $hash{delkey}; await $f; is( \%hash, { key => "new", newkey => "added" }, '%hash after await' ); return "result"; } my $f1 = Future->new; my $fret = with_dynamically_helem( $f1 ); is( \%hash, \%orig, '%hash while suspended '); $f1->done; is( scalar $fret->get, "result", '$fret for dynamically helem in async sub' ); is( \%hash, \%orig, '%hash after finish' ); } # dynamically set variables in outer scopes during await { my $var = 1; async sub outer { dynamically $var = 2; await inner(); is( $var, 2, '$var is 2 after await in outer()' ); } my $f1 = Future->new; async sub inner { is( $var, 2, '$var is 2 before await in inner()' ); await $f1; is( $var, 2, '$var is 2 after await in inner()' ); } my $fret = outer(); is( $var, 1, '$var is 1 while suspended' ); $f1->done; $fret->get; is( $var, 1, '$var is 1 after finish' ); } # captured outer dynamic can be re-captured by later async sub { my $var = 1; my %hash = ( key => 3 ); my $f1 = Future->new; my $f2 = Future->new; my $fret = do { dynamically $var = 2; dynamically $hash{key} = 4; (async sub { await $f1; is( $var, 2, '$var is 2 before later await' ); is( $hash{key}, 4, '$var is 4 before later await' ); await +(async sub { await $f2; is( $var, 2, '$var is 2 inside inner async sub' ); is( $hash{key}, 4, '$var is 4 inside inner async sub' ); })->(); })->(); }; is( $var, 1, '$var is 1 before $f1->done' ); is( $hash{key}, 3, '$hash{key} is 3 before $f1->done' ); $f1->done; is( $var, 1, '$var is 1 before $f2->done' ); is( $hash{key}, 3, '$hash{key} is 3 before $f2->done' ); $f2->done; is( $var, 1, '$var is 1 after $f2->done' ); is( $hash{key}, 3, '$hash{key} is 3 after $f2->done' ); $fret->get; } # destroy test { my %state; package DestroyChecker { sub new { my $class = shift; my $self = bless [ @_ ], $class; $state{$self->[0]} = "LIVE"; return $self; } sub DESTROY { my $self = shift; $state{$self->[0]} = "DEAD"; } } dynamically my $var = DestroyChecker->new( "orig" ); my $f1 = Future->new; my $fret = (async sub { dynamically $var = DestroyChecker->new( "new" ); await $f1; })->(); is( \%state, { orig => "LIVE", new => "LIVE" }, '%state initially' ); $f1->done; $fret->get; is( \%state, { orig => "LIVE", new => "DEAD" }, '%state after done' ); undef $var; is( \%state, { orig => "DEAD", new => "DEAD" }, '%state finally' ); } done_testing; Future-AsyncAwait-0.66/t/80await+matchcase.t000444001750001750 210514476650556 17507 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.10 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.10' ) }; plan skip_all => "Syntax::Keyword::Match is not available" unless eval { require Syntax::Keyword::Match; }; Future::AsyncAwait->import; Syntax::Keyword::Match->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Syntax::Keyword::Match $Syntax::Keyword::Match::VERSION" ); } # await in match/case { async sub with_matchcase { my $f = shift; match( ref $f : eq ) { case( "Future" ) { await $f; } default { die "await case did not run"; } } return "result"; } my $f1 = Future->new; my $fret = with_matchcase( $f1 ); $f1->done; is( scalar $fret->get, "result", '$fret for await in sswitch/case' ); } done_testing; Future-AsyncAwait-0.66/t/81async-method+dynamically.t000444001750001750 336414476650556 21364 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.40 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.40' ) }; plan skip_all => "Object::Pad >= 0.800 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.800' ) }; plan skip_all => "Syntax::Keyword::Dynamically >= 0.04 is not available" unless eval { require Syntax::Keyword::Dynamically; Syntax::Keyword::Dynamically->VERSION( '0.04' ) }; Future::AsyncAwait->import; Object::Pad->import; Syntax::Keyword::Dynamically->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Object::Pad $Object::Pad::VERSION, " . "Syntax::Keyword::Dynamically $Syntax::Keyword::Dynamically::VERSION" ); } # dynamically inside an async method { my $after_level; class Logger { field $_level = 1; method level { $_level } async method verbosely { my ( $code ) = @_; dynamically $_level = $_level + 1; await $code->(); $after_level = $_level; } } my $logger = Logger->new; is( $logger->level, 1, '$logger->level initially' ); my $during_level; my $f1 = Future->new; my $fret = $logger->verbosely(async sub { $during_level = $logger->level; await $f1; }); is( $logger->level, 1, '$logger->level while verbosely suspended' ); is( $during_level, 2, '$during_level' ); $f1->done; is( $after_level, 2, '$after_level' ); is( $logger->level, 1, '$logger->level finally' ); } done_testing; Future-AsyncAwait-0.66/t/81memory-growth.t000444001750001750 237414476650556 17307 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { eval { require Test::MemoryGrowth; } or plan skip_all => "No Test::MemoryGrowth"; } use Test::MemoryGrowth; use Future; use Future::AsyncAwait qw( :experimental(cancel) ); async sub identity { await $_[0]; } sub code { my $f1 = Future->new; my $fret = identity( $f1 ); $f1->done; $fret->get; } no_growth \&code, calls => 10000, 'async/await does not grow memory'; sub abandoned { my $f1 = Future->new; my $fret = (async sub { local $@; foreach my $i ( 1, 2, 3 ) { await $f1; } })->(); undef $fret; undef $f1; } no_growth \&abandoned, calls => 10000, 'abandoned async sub does not grow memory'; sub precancelled { my $f1 = Future->new; my $fret = (async sub { CANCEL { } await $f1; })->(); $f1->done; $fret->get; } no_growth \&precancelled, calls => 10000, 'precancellation does not grow memory'; # RT142222 { my $ftick; my $floop = (async sub { while(1) { await ( $ftick = Future->new ); } })->(); no_growth sub { my $f = $ftick; undef $ftick; $f->done; }, calls => 10000, 'loop later does not grow memory'; } done_testing; Future-AsyncAwait-0.66/t/82devel-mat-dumper-helper.t000444001750001750 72014476650556 21066 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { eval { require Devel::MAT; } or plan skip_all => "No Devel::MAT"; require Devel::MAT::Dumper; } use Future; use Future::AsyncAwait; my $f1 = Future->new; my $fret = (async sub { local $@; await $f1 })->(); ( my $file = __FILE__ ) =~ s/\.t$/.pmat/; Devel::MAT::Dumper::dump( $file ); END { unlink $file if -f $file } $f1->done; $fret->get; pass( "did not crash" ); done_testing; Future-AsyncAwait-0.66/t/90rt128176.t000444001750001750 125214476650556 15577 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; my @f; sub set_dc { push @f, my $f = Future->new; return $f; } sub readwrite { Future->done( $_[0] ) } # Inspired by Device::Chip::SSD1306::SPI4::send_cmd async sub send_cmd { my $self = shift; my @vals = @_; await set_dc(); await readwrite( join "", map { chr } @vals ); } # Inspired by Device::Chip::SSD1306::init async sub init { my $self = shift; await $self->send_cmd( 1, 2 ); await $self->send_cmd( 3, 4 ); } { my $f = __PACKAGE__->init; # Pump Futures ( shift @f )->done() while @f; is( $f->get, "\x03\x04", 'result' ); } done_testing; Future-AsyncAwait-0.66/t/90rt129836.t000444001750001750 41014476650556 15556 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future::AsyncAwait; async sub outer { my $inner = async sub { return "inner"; }; return await $inner->(); } is( outer()->get, "inner", 'result of anon inside named' ); done_testing; Future-AsyncAwait-0.66/t/90rt142468.t000444001750001750 154114476650556 15600 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Future; use Future::AsyncAwait; # Check that folded constants stored on the pad with the SvPADTMP flag set are # still copied successfully by cv_copy_flags(). # # https://rt.cpan.org/Ticket/Display.html?id=142468 use constant { REG_LUXH => 0x03, REG_LUXL => 0x04, }; my @written; my $ftick; sub write_then_read { my ( $bytes, $len ) = @_; push @written, [ $bytes, $len ]; return $ftick = Future->new; } async sub read_lux { return unpack "S>", join "", await write_then_read( ( pack "C", REG_LUXH ), 1 ), await write_then_read( ( pack "C", REG_LUXL ), 1 ); } { my $fret = read_lux; do { my $f = $ftick; undef $ftick; $f->done } while $ftick; is( \@written, [ [ "\x03", 1 ], [ "\x04", 1 ], ], 'arguments to ->write_then_read' ); } done_testing; Future-AsyncAwait-0.66/t/99pod.t000444001750001750 25514476650556 15236 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok();