Future-AsyncAwait-0.36000755001750001750 013610147343 13500 5ustar00leoleo000000000000Future-AsyncAwait-0.36/Build.PL000444001750001750 264713610147343 15142 0ustar00leoleo000000000000use strict; use warnings; use Config; use Module::Build; my @extra_compiler_flags = qw( -std=c89 -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, 'perl' => '5.016', # PL_keyword_plugin, pad_new(), CvDYNFILE, many tests fail on 5.14 }, test_requires => { 'Test::More' => '0.88', # done_testing 'Test::Refcount' => '0.09', }, configure_requires => { 'Module::Build' => '0.4004', # test_requires }, 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, ); if( eval { require Devel::MAT::Dumper::Helper } ) { Devel::MAT::Dumper::Helper->extend_module_build( $build ); } $build->create_build_script; Future-AsyncAwait-0.36/Changes000444001750001750 2450513610147343 15156 0ustar00leoleo000000000000Revision history for Future-AsyncAwait 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.36/LICENSE000444001750001750 4376213610147343 14676 0ustar00leoleo000000000000This software is copyright (c) 2020 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) 2020 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) 2020 by Paul Evans . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Future-AsyncAwait-0.36/MANIFEST000444001750001750 230713610147343 14770 0ustar00leoleo000000000000Build.PL Changes hax/block_end.c.inc hax/block_start.c.inc hax/COP_SEQ_RANGE_HIGH_set.c.inc hax/cx_pushblock.c.inc hax/cx_pusheval.c.inc hax/docatch.c.inc hax/lexer-additions.c.inc hax/pad_block_start.c.inc hax/pad_leavemy.c.inc hax/parse_subsignature.c.inc hax/README hax/save_clearpadrange.c.inc hax/scalarseq.c.inc hax/wrap_keyword_plugin.c.inc lib/Future/AsyncAwait.h lib/Future/AsyncAwait.pm lib/Future/AsyncAwait.xs lib/Future/AsyncAwait/Awaitable.pm 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-twice.t t/05await-expr.t t/06await-nested.t t/07await-label.t t/08await-cancel.t t/10pad.t t/11contexts.t t/12closure.t t/13regexp.t t/14packagevar.t t/15local-errsv.t t/20context-block.t t/21context-while.t t/22context-foreach.t t/23context-map.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/80await+dynamically.t t/80await+try.t t/81memory-growth.t t/82devel-mat-dumper-helper.t t/90rt128176.t t/90rt129836.t t/99pod.t Future-AsyncAwait-0.36/META.json000444001750001750 300313610147343 15252 0ustar00leoleo000000000000{ "abstract" : "deferred subroutine syntax for futures", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4224", "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" } }, "runtime" : { "requires" : { "Future" : "0", "perl" : "5.016" } }, "test" : { "requires" : { "Test::More" : "0.88", "Test::Refcount" : "0.09" } } }, "provides" : { "Future::AsyncAwait" : { "file" : "lib/Future/AsyncAwait.pm", "version" : "0.36" }, "Future::AsyncAwait::Awaitable" : { "file" : "lib/Future/AsyncAwait/Awaitable.pm", "version" : "0.36" }, "Test::Future::AsyncAwait::Awaitable" : { "file" : "lib/Test/Future/AsyncAwait/Awaitable.pm", "version" : "0.36" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "x_IRC" : "irc://irc.perl.org/#io-async" }, "version" : "0.36", "x_serialization_backend" : "JSON::PP version 4.04" } Future-AsyncAwait-0.36/META.yml000444001750001750 170713610147343 15113 0ustar00leoleo000000000000--- abstract: 'deferred subroutine syntax for futures' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test::More: '0.88' Test::Refcount: '0.09' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4224, 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.36' Future::AsyncAwait::Awaitable: file: lib/Future/AsyncAwait/Awaitable.pm version: '0.36' Test::Future::AsyncAwait::Awaitable: file: lib/Test/Future/AsyncAwait/Awaitable.pm version: '0.36' requires: Future: '0' perl: '5.016' resources: IRC: irc://irc.perl.org/#io-async license: http://dev.perl.org/licenses/ version: '0.36' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Future-AsyncAwait-0.36/README000444001750001750 3236113610147343 14542 0ustar00leoleo000000000000NAME Future::AsyncAwait - deferred subroutine syntax for futures SYNOPSIS 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 is considering adding it. 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; 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. STABILITY WARNING This module is still relatively new and under active development. While it now seems relatively stable enough for most use-cases, there may still be a number of memory leaks left in it, especially if still-pending futures are abandoned. While it seems stable enough for small-scale development and experimental testing, take care when using this module in production, as some growth in memory over time may be observed. Careful use of monitoring and periodic restarts of long-running processes may be a wise precaution. That said, using this module in places like unit-tests and short-term scripts does appear to be quite stable, so do try experimenting with it in this sort of situation, and let me know what does and doesn't work. 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 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 5.026; use feature 'signatures'; async sub quart($x, $y) { ... } 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: * There is currently no way to perform the equivalent of "on_cancel" in Future to add a cancellation callback to a future chain. * 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"; } } 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"; } 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; 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.36/hax000755001750001750 013610147343 14260 5ustar00leoleo000000000000Future-AsyncAwait-0.36/hax/COP_SEQ_RANGE_HIGH_set.c.inc000444001750001750 30013610147343 21021 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef COP_SEQ_RANGE_HIGH_set #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \ STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END #endif Future-AsyncAwait-0.36/hax/README000444001750001750 71213610147343 15255 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.36/hax/block_end.c.inc000444001750001750 216413610147343 17254 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef block_end #include "scalarseq.c.inc" #include "pad_leavemy.c.inc" #define block_end(A, B) S_block_end(aTHX_ A, B) static OP *S_block_end(pTHX_ I32 floor, OP *seq) { dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP *retval = scalarseq(seq); OP *o; CALL_BLOCK_HOOKS(bhk_pre_end, &retval); LEAVE_SCOPE(floor); #if !HAVE_PERL_VERSION(5, 19, 3) CopHINTS_set(&PL_compiling, PL_hints); #endif if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ o = pad_leavemy(); if (o) { #if HAVE_PERL_VERSION(5, 17, 4) OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; OP *const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; for (;; kid = kid->op_sibling) { OP *newkid = newOP(OP_CLONECV, 0); newkid->op_targ = kid->op_targ; o = op_append_elem(OP_LINESEQ, o, newkid); if (kid == last) break; } retval = op_prepend_elem(OP_LINESEQ, o, retval); #endif } CALL_BLOCK_HOOKS(bhk_post_end, &retval); return retval; } #endif Future-AsyncAwait-0.36/hax/block_start.c.inc000444001750001750 73113610147343 17621 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef block_start #include "pad_block_start.c.inc" #define block_start(A) S_block_start(aTHX_ A) static int S_block_start(pTHX_ int full) { dVAR; const int retval = PL_savestack_ix; pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); CALL_BLOCK_HOOKS(bhk_start, full); return retval; } #endif Future-AsyncAwait-0.36/hax/cx_pushblock.c.inc000444001750001750 50413610147343 17774 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.36/hax/cx_pusheval.c.inc000444001750001750 46213610147343 17634 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.36/hax/docatch.c.inc000444001750001750 137013610147343 16737 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: 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.36/hax/lexer-additions.c.inc000444001750001750 1251113610147343 20444 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ /* Perls before 5.18 lack isIDCONT_uni, but baring minor differences of weird * Unicode characters, isALNUM_uni is close enough */ #ifndef isIDCONT_uni #define isIDCONT_uni(c) isALNUM_uni(c) #endif #define sv_cat_c(sv, c) MY_sv_cat_c(aTHX_ sv, c) static void MY_sv_cat_c(pTHX_ SV *sv, U32 c) { char ds[UTF8_MAXBYTES + 1], *d; d = (char *)uvchr_to_utf8((U8 *)ds, c); if (d - ds > 1) { sv_utf8_upgrade(sv); } sv_catpvn(sv, ds, d - ds); } #define lex_consume(s) MY_lex_consume(aTHX_ s) static int MY_lex_consume(pTHX_ char *s) { /* I want strprefix() */ size_t i; for(i = 0; s[i]; i++) { if(s[i] != PL_parser->bufptr[i]) return 0; } lex_read_to(PL_parser->bufptr + i); return i; } enum { LEX_IDENT_PACKAGENAME = (1<<0), }; #define lex_scan_ident( ) MY_lex_scan_ident(aTHX_ 0) #define lex_scan_packagename() MY_lex_scan_ident(aTHX_ LEX_IDENT_PACKAGENAME) static SV *MY_lex_scan_ident(pTHX_ int flags) { I32 c; bool at_start = TRUE; char *ident = PL_parser->bufptr; while((c = lex_peek_unichar(0))) { if(at_start ? isIDFIRST_uni(c) : isALNUM_uni(c)) at_start = FALSE; /* TODO: This sucks in the case of a false Foo:Bar match */ else if((flags & LEX_IDENT_PACKAGENAME) && (c == ':')) { lex_read_unichar(0); if(lex_read_unichar(0) != ':') croak("Expected colon to be followed by another in package name"); } else break; lex_read_unichar(0); } STRLEN len = PL_parser->bufptr - ident; if(!len) return NULL; SV *ret = newSVpvn(ident, len); if(lex_bufutf8()) SvUTF8_on(ret); return ret; } #define lex_scan_attr() MY_lex_scan_attr(aTHX) static SV *MY_lex_scan_attr(pTHX) { SV *ret = lex_scan_ident(); if(!ret) return ret; lex_read_space(0); if(lex_peek_unichar(0) != '(') return ret; sv_cat_c(ret, lex_read_unichar(0)); int count = 1; I32 c = lex_peek_unichar(0); while(count && c != -1) { if(c == '(') count++; if(c == ')') count--; if(c == '\\') { /* The next char does not bump count even if it is ( or ); * the \\ is still captured */ sv_cat_c(ret, lex_read_unichar(0)); c = lex_peek_unichar(0); if(c == -1) goto unterminated; } sv_cat_c(ret, lex_read_unichar(0)); c = lex_peek_unichar(0); } if(c != -1) return ret; unterminated: croak("Unterminated attribute parameter in attribute list"); } #define lex_scan_attrs(compcv) MY_lex_scan_attrs(aTHX_ compcv) static OP *MY_lex_scan_attrs(pTHX_ CV *compcv) { /* Attributes are supplied to newATTRSUB() as an OP_LIST containing * OP_CONSTs, one attribute in each as a plain SV. Note that we don't have * to parse inside the contents of the parens; that is handled by the * attribute handlers themselves */ OP *attrs = NULL; SV *attr; lex_read_space(0); while((attr = lex_scan_attr())) { lex_read_space(0); if(compcv && strEQ(SvPV_nolen(attr), "lvalue")) { CvLVALUE_on(compcv); } if(!attrs) attrs = newLISTOP(OP_LIST, 0, NULL, NULL); attrs = op_append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, attr)); } return attrs; } #define lex_scan_lexvar() MY_lex_scan_lexvar(aTHX) static SV *MY_lex_scan_lexvar(pTHX) { int sigil = lex_peek_unichar(0); switch(sigil) { case '$': case '@': case '%': lex_read_unichar(0); break; default: croak("Expected a lexical variable"); } SV *ret = lex_scan_ident(); if(!ret) return NULL; /* prepend sigil - which we know to be a single byte */ SvGROW(ret, SvCUR(ret) + 1); Move(SvPVX(ret), SvPVX(ret) + 1, SvCUR(ret), char); SvPVX(ret)[0] = sigil; SvCUR(ret)++; SvPVX(ret)[SvCUR(ret)] = 0; return ret; } #define lex_scan_parenthesized() MY_lex_scan_parenthesized(aTHX) static SV *MY_lex_scan_parenthesized(pTHX) { I32 c; int parencount = 0; SV *ret = newSVpvs(""); if(lex_bufutf8()) SvUTF8_on(ret); c = lex_peek_unichar(0); while(c != -1) { sv_cat_c(ret, lex_read_unichar(0)); switch(c) { case '(': parencount++; break; case ')': parencount--; break; } if(!parencount) break; c = lex_peek_unichar(0); } if(SvCUR(ret)) return ret; SvREFCNT_dec(ret); return NULL; } #define lex_scan_version(flags) MY_lex_scan_version(aTHX_ flags) static SV *MY_lex_scan_version(pTHX_ int flags) { const char *err = NULL; const char *endp = prescan_version(PL_parser->bufptr, FALSE, &err, NULL, NULL, NULL, NULL); if(endp == PL_parser->bufptr && (flags & PARSE_OPTIONAL)) return NULL; SV *ret = newSV(0); endp = scan_version(PL_parser->bufptr, ret, FALSE); lex_read_to((char *)endp); return ret; } #define parse_lexvar() MY_parse_lexvar(aTHX) static PADOFFSET MY_parse_lexvar(pTHX) { /* TODO: Rewrite this in terms of using lex_scan_lexvar() */ char *lexname = PL_parser->bufptr; if(lex_read_unichar(0) != '$') croak("Expected a lexical scalar at %s", lexname); if(!isIDFIRST_uni(lex_peek_unichar(0))) croak("Expected a lexical scalar at %s", lexname); lex_read_unichar(0); while(isIDCONT_uni(lex_peek_unichar(0))) lex_read_unichar(0); /* Forbid $_ */ if(PL_parser->bufptr - lexname == 2 && lexname[1] == '_') croak("Can't use global $_ in \"my\""); return pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL); } Future-AsyncAwait-0.36/hax/pad_block_start.c.inc000444001750001750 124513610147343 20466 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef pad_block_start #define pad_block_start(A) S_pad_block_start(aTHX_ A) static void S_pad_block_start(pTHX_ int full) { dVAR; ASSERT_CURPAD_ACTIVE("pad_block_start"); SAVEI32(PL_comppad_name_floor); PL_comppad_name_floor = AvFILLp(PL_comppad_name); if (full) PL_comppad_name_fill = PL_comppad_name_floor; if (PL_comppad_name_floor < 0) PL_comppad_name_floor = 0; SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); PL_min_intro_pending = 0; SAVEI32(PL_comppad_name_fill); SAVEI32(PL_padix_floor); PL_padix_floor = PL_padix; PL_pad_reset_pending = FALSE; } #endif Future-AsyncAwait-0.36/hax/pad_leavemy.c.inc000444001750001750 436213610147343 17624 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef pad_leavemy #include "COP_SEQ_RANGE_HIGH_set.c.inc" #define pad_leavemy() S_pad_leavemy(aTHX) #if HAVE_PERL_VERSION(5, 19, 3) #define IF_HAVE_PERL_5_19_3(YES, NO) YES #else #define IF_HAVE_PERL_5_19_3(YES, NO) NO #endif static OP *S_pad_leavemy(pTHX) { dVAR; I32 off; OP *o = NULL; SV * const * const svp = AvARRAY(PL_comppad_name); PL_pad_reset_pending = FALSE; ASSERT_CURPAD_ACTIVE("pad_leavemy"); if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { const SV * const sv = svp[off]; if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv)) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "%"SVf" never introduced", SVfARG(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { SV * const sv = svp[off]; if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) { COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", (long)off, SvPVX_const(sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); #if HAVE_PERL_VERSION(5, 17, 4) if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { OP *kid = newOP(OP_INTROCV, 0); kid->op_targ = off; o = op_prepend_elem(OP_LINESEQ, kid, o); } #endif } } PL_cop_seqmax++; if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); return o; } #endif Future-AsyncAwait-0.36/hax/parse_subsignature.c.inc000444001750001750 1221213610147343 21254 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef parse_subsignature #define PERL_EXT #include "feature.h" /* * Need to grab some things that aren't quite core perl API */ /* yyerror() is a long function and hard to emulate or copy-paste for our * purposes; we'll reïmplement a smaller version of it */ #define LEX_IGNORE_UTF8_HINTS 0x00000002 #define PL_linestr (PL_parser->linestr) #ifdef USE_UTF8_SCRIPTS # define UTF cBOOL(!IN_BYTES) #else # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8))) #endif #define yyerror(s) S_yyerror(aTHX_ s) void S_yyerror(pTHX_ const char *s) { SV *message = sv_2mortal(newSVpvs_flags("", 0)); char *context = PL_parser->oldbufptr; STRLEN contlen = PL_parser->bufptr - PL_parser->oldbufptr; sv_catpvf(message, "%s at %s line %" IVdf, s, OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); if(context) sv_catpvf(message, ", near \"%" UTF8f "\"", UTF8fARG(UTF, contlen, context)); sv_catpvf(message, "\n"); PL_parser->error_count++; warn_sv(message); } /* Stolen from op.c */ #define OpTYPE_set(op, type) \ STMT_START { \ op->op_type = (OPCODE)type; \ op->op_ppaddr = PL_ppaddr[type]; \ } STMT_END #define alloc_LOGOP(a,b,c) S_alloc_LOGOP(aTHX_ a,b,c) static LOGOP *S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) { dVAR; LOGOP *logop; OP *kid = first; NewOp(1101, logop, 1, LOGOP); OpTYPE_set(logop, type); logop->op_first = first; logop->op_other = other; if (first) logop->op_flags = OPf_KIDS; while (kid && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); if (kid) OpLASTSIB_set(kid, (OP*)logop); return logop; } #define parse_sigelem() S_parse_sigelem(aTHX) static OP *S_parse_sigelem(pTHX) { yy_parser *parser = PL_parser; int c = lex_peek_unichar(0); int flags; switch(c) { case '$': flags = OPpARGELEM_SV; break; case '@': flags = OPpARGELEM_AV; break; case '%': flags = OPpARGELEM_HV; break; default: return NULL; } char *lexname = parser->bufptr; OP *varop = NULL; /* Consume sigil */ lex_read_unichar(0); if(isIDFIRST_uni(lex_peek_unichar(0))) { lex_read_unichar(0); while(isALNUM_uni(lex_peek_unichar(0))) lex_read_unichar(0); lex_read_space(0); varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (parser->sig_elems))); varop->op_private |= flags; varop->op_targ = pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL); } if(c == '$') { if(parser->sig_slurpy) yyerror("Slurpy parameters not last"); parser->sig_elems++; if(lex_peek_unichar(0) == '=') { lex_read_unichar(0); lex_read_space(0); parser->sig_optelems++; OP *defexpr = parse_termexpr(0); OP *defop = (OP *)alloc_LOGOP(OP_ARGDEFELEM, defexpr, LINKLIST(defexpr)); defop->op_targ = (PADOFFSET)(parser->sig_elems - 1); varop->op_flags |= OPf_STACKED; op_sibling_splice(varop, NULL, 0, defop); defop = op_contextualize(defop, G_SCALAR); LINKLIST(varop); varop->op_next = defop; defexpr->op_next = varop; } else { if(parser->sig_optelems) yyerror("Mandatory parameter follows optional parameter"); } } else { if(parser->sig_slurpy) yyerror("Multiple slurpy parameters not allowed"); parser->sig_slurpy = c; if(lex_peek_unichar(0) == '=') yyerror("A slurpy parameter may not have a default value"); } return varop ? newSTATEOP(0, NULL, varop) : NULL; } #define parse_subsignature(flags) S_parse_subsignature(aTHX_ flags) static OP *S_parse_subsignature(pTHX_ int flags) { /* Mostly reconstructed logic from perl 5.28.0's toke.c and perly.y */ yy_parser *parser = PL_parser; ENTER; SAVEIV(parser->sig_elems); SAVEIV(parser->sig_optelems); SAVEI8(parser->sig_slurpy); parser->sig_elems = 0; parser->sig_optelems = 0; parser->sig_slurpy = 0; OP *elems = NULL; while(lex_peek_unichar(0) != ')') { OP *elem = parse_sigelem(); elems = op_append_list(OP_LINESEQ, elems, elem); if(PL_parser->error_count) { LEAVE; return NULL; } lex_read_space(0); switch(lex_peek_unichar(0)) { case ')': goto endofelems; case ',': break; default: fprintf(stderr, "ARGH unsure how to proceed parse_subsignature at <%s>\n", parser->bufptr); croak("ARGH"); break; } lex_read_unichar(0); lex_read_space(0); } endofelems: if(!elems) { LEAVE; return NULL; } if (!FEATURE_SIGNATURES_IS_ENABLED) croak("Experimental subroutine signatures not enabled"); Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SIGNATURES), "The signatures feature is experimental"); UNOP_AUX_item *aux = (UNOP_AUX_item *)PerlMemShared_malloc(sizeof(UNOP_AUX_item) * 3); aux[0].iv = parser->sig_elems; aux[1].iv = parser->sig_optelems; aux[2].iv = parser->sig_slurpy; OP *checkop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux); LEAVE; return op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), op_prepend_elem(OP_LINESEQ, checkop, elems)); } #endif Future-AsyncAwait-0.36/hax/save_clearpadrange.c.inc000444001750001750 76513610147343 21127 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.36/hax/scalarseq.c.inc000444001750001750 136713610147343 17316 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef scalarseq #define scalarseq(A) S_scalarseq(aTHX_ A) static OP *S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { const OPCODE type = o->op_type; if (type == OP_LINESEQ || type == OP_SCOPE || type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { op_contextualize(kid, G_VOID); } } PL_curcop = &PL_compiling; } o->op_flags &= ~OPf_PARENS; if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS; } else o = newOP(OP_STUB, 0); return o; } #endif Future-AsyncAwait-0.36/hax/wrap_keyword_plugin.c.inc000444001750001750 133613610147343 21427 0ustar00leoleo000000000000/* vi: set ft=c inde=: */ #ifndef OP_CHECK_MUTEX_LOCK /* < 5.15.8 */ # define OP_CHECK_MUTEX_LOCK ((void)0) # define OP_CHECK_MUTEX_UNLOCK ((void)0) #endif #define wrap_keyword_plugin(func, var) S_wrap_keyword_plugin(aTHX_ func, var) static void S_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t func, Perl_keyword_plugin_t *var) { /* BOOT can potentially race with other threads (RT123547) */ /* Perl doesn't really provide us a nice mutex for doing this so this is the * best we can find. See also * https://rt.perl.org/Public/Bug/Display.html?id=132413 */ if(*var) return; OP_CHECK_MUTEX_LOCK; if(!*var) { *var = PL_keyword_plugin; PL_keyword_plugin = func; } OP_CHECK_MUTEX_UNLOCK; } Future-AsyncAwait-0.36/lib000755001750001750 013610147343 14246 5ustar00leoleo000000000000Future-AsyncAwait-0.36/lib/Future000755001750001750 013610147343 15520 5ustar00leoleo000000000000Future-AsyncAwait-0.36/lib/Future/AsyncAwait.h000444001750001750 564013610147343 20076 0ustar00leoleo000000000000#ifndef __FUTURE_ASYNCAWAIT_H__ #define __FUTURE_ASYNCAWAIT_H__ #include "perl.h" /* * 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. */ /* * 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; /* 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.36/lib/Future/AsyncAwait.pm000444001750001750 3323013610147343 20277 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-2019 -- leonerd@leonerd.org.uk package Future::AsyncAwait; use strict; use warnings; our $VERSION = '0.36'; use Carp; require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); require Future; =head1 NAME C - deferred subroutine syntax for futures =head1 SYNOPSIS 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 is considering adding it. 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; 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. =head1 STABILITY WARNING This module is still relatively new and under active development. While it now seems relatively stable enough for most use-cases, there may still be a number of memory leaks left in it, especially if still-pending futures are abandoned. While it seems stable enough for small-scale development and experimental testing, take care when using this module in production, as some growth in memory over time may be observed. Careful use of monitoring and periodic restarts of long-running processes may be a wise precaution. That said, using this module in places like unit-tests and short-term scripts does appear to be quite stable, so do try experimenting with it in this sort of situation, and let me know what does and doesn't work. =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 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 5.026; use feature 'signatures'; async sub quart($x, $y) { ... } =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 * There is currently no way to perform the equivalent of L to add a cancellation callback to a future chain. =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"; } } =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"; } =cut sub import { my $class = shift; my $caller = caller; $class->import_into( $caller, @_ ); } sub import_into { my $class = shift; my $caller = shift; $^H{"Future::AsyncAwait/async"}++; # Just always turn this on while( @_ ) { my $sym = shift; $^H{"Future::AsyncAwait/future"} = shift, next if $sym eq "future_class"; croak "Unrecognised import symbol $sym"; } } if( !defined &Future::AWAIT_CLONE ) { # TODO: These ought to be implemented by Future.pm itself, and it can do # these in a faster, more performant way *Future::AWAIT_CLONE = sub { shift->new }; *Future::AWAIT_NEW_DONE = *Future::AWAIT_DONE = sub { shift->done( @_ ) }; *Future::AWAIT_NEW_FAIL = *Future::AWAIT_FAIL = sub { shift->fail( @_ ) }; *Future::AWAIT_IS_READY = sub { shift->is_ready }; *Future::AWAIT_IS_CANCELLED = sub { shift->is_cancelled }; *Future::AWAIT_ON_READY = sub { shift->on_ready( @_ ) }; *Future::AWAIT_ON_CANCEL = sub { shift->on_cancel( @_ ) }; *Future::AWAIT_GET = sub { shift->get }; } =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; =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.36/lib/Future/AsyncAwait.xs000444001750001750 16526113610147343 20347 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-2019 -- leonerd@leonerd.org.uk */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "AsyncAwait.h" #ifdef HAVE_DMD_HELPER # include "DMD_helper.h" #endif #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #if HAVE_PERL_VERSION(5, 31, 3) # define HAVE_PARSE_SUBSIGNATURE #elif HAVE_PERL_VERSION(5, 26, 0) # include "parse_subsignature.c.inc" # define HAVE_PARSE_SUBSIGNATURE #endif #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) # define OLDSAVEIX(cx) (cx->blk_oldsaveix) #else # define OLDSAVEIX(cx) (PL_scopestack[cx->blk_oldscopesp-1]) #endif #ifndef CX_CUR # define CX_CUR() (&cxstack[cxstack_ix]) #endif #ifndef OpSIBLING # define OpSIBLING(op) (op->op_sibling) #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 #if !HAVE_PERL_VERSION(5, 22, 0) # include "block_start.c.inc" # include "block_end.c.inc" # define CvPADLIST_set(cv, padlist) (CvPADLIST(cv) = padlist) #endif #if !HAVE_PERL_VERSION(5, 18, 0) # define PadARRAY(pad) AvARRAY(pad) # define PadMAX(pad) AvFILLp(pad) typedef AV PADNAMELIST; # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) # define PadlistNAMES(pl) (*PadlistARRAY(pl)) typedef SV PADNAME; # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) # define PadnameLEN(pn) SvCUR(pn) # define PadnameOUTER(pn) !!SvFAKE(pn) # define PadnamelistARRAY(pnl) AvARRAY(pnl) # define PadnamelistMAX(pnl) AvFILLp(pnl) #endif #ifndef wrap_keyword_plugin # include "wrap_keyword_plugin.c.inc" #endif #include "lexer-additions.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 */ 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 */ 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 debug_sv_summary(const SV *sv) { const char *type; switch(SvTYPE(sv)) { case SVt_NULL: type = "NULL"; break; case SVt_IV: type = "IV"; break; case SVt_NV: type = "NV"; break; case SVt_PV: type = "PV"; break; case SVt_PVGV: type = "PVGV"; break; case SVt_PVAV: type = "PVAV"; break; default: { char buf[16]; sprintf(buf, "(%d)", SvTYPE(sv)); type = buf; break; } } if(SvROK(sv)) type = "RV"; fprintf(stderr, "SV{type=%s,refcnt=%d", type, SvREFCNT(sv)); if(SvTEMP(sv)) fprintf(stderr, ",TEMP"); if(SvROK(sv)) fprintf(stderr, ",ROK"); else { if(SvIOK(sv)) fprintf(stderr, ",IV=%" IVdf, SvIVX(sv)); if(SvUOK(sv)) fprintf(stderr, ",UV=%" UVuf, SvUVX(sv)); if(SvPOK(sv)) { fprintf(stderr, ",PVX=\"%.10s\"", SvPVX((SV *)sv)); if(SvCUR(sv) > 10) fprintf(stderr, "..."); } } fprintf(stderr, "}"); } static void debug_showstack(const char *name) { SV **sp; fprintf(stderr, "%s:\n", name ? name : "Stack"); PERL_CONTEXT *cx = CX_CUR(); I32 floor = cx->blk_oldsp; I32 *mark = PL_markstack + cx->blk_oldmarksp + 1; fprintf(stderr, " marks (TOPMARK=@%d):\n", TOPMARK - floor); for(; mark <= PL_markstack_ptr; mark++) fprintf(stderr, " @%d\n", *mark - floor); mark = PL_markstack + cx->blk_oldmarksp + 1; for(sp = PL_stack_base + floor + 1; sp <= PL_stack_sp; sp++) { fprintf(stderr, sp == PL_stack_sp ? "-> " : " "); fprintf(stderr, "%p = ", *sp); debug_sv_summary(*sp); while(mark <= PL_markstack_ptr && PL_stack_base + *mark == sp) fprintf(stderr, " [*M]"), mark++; fprintf(stderr, "\n"); } } 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); } /* * Magic that we attach to suspended CVs, that contains state required to restore * them */ static int magic_free(pTHX_ SV *sv, MAGIC *mg); static MGVTBL vtbl = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ magic_free, }; #ifdef HAVE_DMD_HELPER static int dumpmagic(pTHX_ 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_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->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) 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; sv_magicext((SV *)cv, NULL, PERL_MAGIC_ext, &vtbl, (char *)ret, 0); return ret; } static int magic_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: #ifdef SAVEt_STRLEN case SAVEt_STRLEN: #endif case SAVEt_SET_SVFLAGS: break; case SAVEt_FREEPV: Safefree(saved->cur.ptr); 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; default: fprintf(stderr, "TODO: free saved slot type %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->modhookdata) { SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", FALSE); if(hookp && SvOK(*hookp) && SvUV(*hookp)) { 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; } #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) 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: panic("TODO: Unsure how to handle savestack entry of %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; 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; } } static bool padname_is_normal_lexical(PADNAME *pname) { /* PAD slots without names are certainly not lexicals */ if(!pname || #if !HAVE_PERL_VERSION(5, 20, 0) /* Perl before 5.20.0 could put PL_sv_undef in PADNAMEs */ pname == &PL_sv_undef || #endif !PadnameLEN(pname)) return FALSE; /* Outer lexical captures are not lexicals */ if(PadnameOUTER(pname)) return FALSE; /* Protosubs for closures are not lexicals */ if(PadnamePV(pname)[0] == '&') return FALSE; /* anything left is a normal lexical */ return TRUE; } #define cv_dup_for_suspend(orig) MY_cv_dup_for_suspend(aTHX_ orig) static CV *MY_cv_dup_for_suspend(pTHX_ CV *orig) { /* 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) = NULL; /* intentionally left NULL because caller should fill this in */ 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 */ { ENTER_with_name("cv_dup_for_suspend"); SAVESPTR(PL_compcv); PL_compcv = new; CvOUTSIDE(new) = MUTABLE_CV(SvREFCNT_inc(CvOUTSIDE(orig))); 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]); SV **origpad = AvARRAY(PadlistARRAY(CvPADLIST(orig))[CvDEPTH(orig)]); #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; for(padix = 1; padix <= fpad; padix++) { PADNAME *pname = (padix <= fnames) ? pnames[padix] : NULL; SV *newval; if(padname_is_normal_lexical(pname)) { /* 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. */ continue; } else if(pname && PadnamePV(pname)) { #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(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_dup_for_suspend(origproto); 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 if(origpad[padix]) newval = SvREFCNT_inc_NN(origpad[padix]); #else newval = SvREFCNT_inc_NN(origpad[padix]); #endif } else { newval = newSV(0); SvPADTMP_on(newval); } PL_curpad[padix] = newval; } LEAVE_with_name("cv_dup_for_suspend"); } return new; } #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; 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); 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; } /* Don't fiddle refcount */ state->padslots[i-1] = PadARRAY(pad)[i]; switch(PadnamePV(pname)[0]) { case '@': PadARRAY(pad)[i] = MUTABLE_SV(newAV()); break; case '%': PadARRAY(pad)[i] = MUTABLE_SV(newHV()); break; case '$': PadARRAY(pad)[i] = newSV(0); break; default: panic("TODO: unsure how to steal and switch pad slot with pname %s\n", PadnamePV(pname)); } } if(PL_curpm) state->curpm = PL_curpm; else state->curpm = NULL; 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; 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; #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] */ 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"); 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; } /* * 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) { *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) { 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) { 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); XPUSHs(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); XPUSHs(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); XPUSHs(f); mXPUSHs(newRV_inc((SV *)code)); PUTBACK; call_method("AWAIT_ON_READY", G_VOID); FREETMPS; LEAVE_with_name("future_on_ready"); } #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); XPUSHs(f1); XPUSHs(f2); PUTBACK; call_method("AWAIT_ON_CANCEL", G_VOID); FREETMPS; LEAVE_with_name("future_chain_on_cancel"); } /* * Custom ops */ static XOP xop_leaveasync; static OP *pp_leaveasync(pTHX) { dSP; dMARK; SV *f = NULL; SV *ret; SuspendedState *state = suspendedstate_get(find_runcv(0)); if(state && state->returning_future) { f = state->returning_future; state->returning_future = NULL; } if(SvTRUE(ERRSV)) { ret = future_fail(f, ERRSV); } else { ret = future_done_from_stack(f, mark); } PERL_CONTEXT *cx = CX_CUR(); SPAGAIN; SV **oldsp = PL_stack_base + cx->blk_oldsp; /* Pop extraneous stack items */ while(SP > oldsp) POPs; EXTEND(SP, 1); mPUSHs(ret); PUTBACK; if(f) SvREFCNT_dec(f); return PL_op->op_next; } static OP *newLEAVEASYNCOP(I32 flags) { OP *op = newOP(OP_CUSTOM, flags); op->op_ppaddr = &pp_leaveasync; return op; } 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; 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); } 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 && state->awaiting_future) { 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"); PUSHMARK(SP); PUTBACK; return PL_ppaddr[OP_RETURN](aTHX); } 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); { SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", FALSE); if(hookp && SvOK(*hookp) && SvUV(*hookp)) { SuspendHookFunc *hook = INT2PTR(SuspendHookFunc *, SvUV(*hookp)); if(!state->modhookdata) state->modhookdata = newHV(); (*hook)(aTHX_ FAA_PHASE_PRERESUME, curcv, state->modhookdata); } } suspendedstate_resume(state, curcv); #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(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 */ curcv = cv_dup_for_suspend(curcv); state = suspendedstate_new(curcv); TRACEPRINT(" SUSPEND cloned CV->%p\n", curcv); defer_mortal_curcv = TRUE; } else { TRACEPRINT(" SUSPEND reuse CV\n"); } state->curcop = PL_curcop; suspendedstate_suspend(state, origcv); { SV **hookp = hv_fetchs(PL_modglobal, "Future::AsyncAwait/suspendhook", FALSE); if(hookp && SvOK(*hookp) && SvUV(*hookp)) { 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(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); /* 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 */ #if HAVE_PERL_VERSION(5, 24, 0) future_chain_on_cancel(state->returning_future, state->awaiting_future); #endif if(!SvROK(state->returning_future)) panic("ARGH we lost state->returning_future for curcv=%p\n", curcv); 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 OP *newAWAITOP(I32 flags, OP *expr) { OP *op = newUNOP(OP_CUSTOM, flags, expr); op->op_ppaddr = &pp_await; return op; } 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 int async_keyword_plugin(pTHX_ OP **op_ptr) { lex_read_space(0); /* At this point we want to parse the sub NAME BLOCK or sub BLOCK * We can't just call parse_fullstmt because that will do too much that we * can't hook into. We'll have to go a longer way round. */ /* async must be immediately followed by 'sub' */ if(!lex_consume("sub")) croak("Expected async to be followed by sub"); lex_read_space(0); /* Might be named or anonymous */ SV *name = lex_scan_ident(); lex_read_space(0); ENTER_with_name("parse_block"); /* From here onwards any `return` must be prefixed by LEAVE_with_name() */ I32 floor_ix = start_subparse(FALSE, name ? 0 : CVf_ANON); SAVEFREESV(PL_compcv); OP *attrs = NULL; if(lex_peek_unichar(0) == ':') { lex_read_unichar(0); attrs = lex_scan_attrs(PL_compcv); } #ifdef HAVE_PARSE_SUBSIGNATURE OP *sigop = NULL; if(lex_peek_unichar(0) == '(') { lex_read_unichar(0); sigop = parse_subsignature(0); lex_read_space(0); if(PL_parser->error_count) { LEAVE_with_name("parse_block"); return 0; } if(lex_peek_unichar(0) != ')') croak("Expected ')'"); lex_read_unichar(0); lex_read_space(0); } #endif if(lex_peek_unichar(0) != '{') croak("Expected async sub %sto be followed by '{'", name ? "NAME " : ""); /* Save the identity of the currently-compiling sub so that * await_keyword_plugin() can check */ PL_hints |= HINT_LOCALIZE_HH; SAVEHINTS(); hv_stores(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", newSVuv(PTR2UV(PL_compcv))); I32 save_ix = block_start(TRUE); OP *body = parse_block(0); /* body might be NULL if an error happened; we check that below so for now * just be defensive */ if(body) { COP *last_cop = PL_curcop; check_optree(aTHX_ body, NO_FORBID, &last_cop); } SvREFCNT_inc(PL_compcv); body = block_end(save_ix, body); if(PL_parser->error_count) { /* parse_block() still sometimes returns a valid body even if a parse * error happens. * We need to destroy this partial body before returning a valid(ish) * state to the keyword hook mechanism, so it will find the error count * correctly * See https://rt.cpan.org/Ticket/Display.html?id=130417 */ op_free(body); #ifdef HAVE_PARSE_SUBSIGNATURE if(sigop) op_free(sigop); #endif *op_ptr = newOP(OP_NULL, 0); if(name) { SvREFCNT_dec(name); LEAVE_with_name("parse_block"); return KEYWORD_PLUGIN_STMT; } else { LEAVE_with_name("parse_block"); return KEYWORD_PLUGIN_EXPR; } } #ifdef HAVE_PARSE_SUBSIGNATURE if(sigop) body = op_append_list(OP_LINESEQ, sigop, body); #endif /* turn block into * NEXTSTATE; PUSHMARK; eval { BLOCK }; LEAVEASYNC */ OP *op = newSTATEOP(0, NULL, NULL); op = op_append_elem(OP_LINESEQ, op, newOP(OP_PUSHMARK, 0)); OP *try; op = op_append_elem(OP_LINESEQ, op, try = newUNOP(OP_ENTERTRY, 0, body)); op_contextualize(try, G_ARRAY); op = op_append_elem(OP_LINESEQ, op, newLEAVEASYNCOP(OPf_WANT_SCALAR)); CV *cv = newATTRSUB(floor_ix, name ? newSVOP(OP_CONST, 0, SvREFCNT_inc(name)) : NULL, NULL, attrs, op); if(CvLVALUE(cv)) warn("Pointless use of :lvalue on async sub"); LEAVE_with_name("parse_block"); if(name) { *op_ptr = newOP(OP_NULL, 0); SvREFCNT_dec(name); return KEYWORD_PLUGIN_STMT; } else { *op_ptr = newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV *)cv)); return KEYWORD_PLUGIN_EXPR; } } static int await_keyword_plugin(pTHX_ OP **op_ptr) { SV **asynccvp = hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", 0); if(!asynccvp || SvUV(*asynccvp) != PTR2UV(PL_compcv)) croak(CvEVAL(PL_compcv) ? "await is not allowed inside string eval" : "Cannot 'await' outside of an 'async sub'"); lex_read_space(0); OP *expr; /* await TERMEXPR wants a single term expression * await( FULLEXPR ) will be a full expression */ if(lex_peek_unichar(0) == '(') { lex_read_unichar(0); expr = parse_fullexpr(0); lex_read_space(0); if(lex_peek_unichar(0) != ')') croak("Expected ')'"); lex_read_unichar(0); } else expr = parse_termexpr(0); op_contextualize(expr, OP_SCALAR); *op_ptr = newAWAITOP(0, expr); return KEYWORD_PLUGIN_EXPR; } static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); static int my_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op_ptr) { HV *hints = GvHV(PL_hintgv); if((PL_parser && PL_parser->error_count) || !hints) return (*next_keyword_plugin)(aTHX_ kw, kwlen, op_ptr); if(kwlen == 5 && strEQ(kw, "async") && hv_fetchs(hints, "Future::AsyncAwait/async", 0)) return async_keyword_plugin(aTHX_ op_ptr); if(kwlen == 5 && strEQ(kw, "await") && hv_fetchs(hints, "Future::AsyncAwait/async", 0)) return await_keyword_plugin(aTHX_ op_ptr); return (*next_keyword_plugin)(aTHX_ kw, kwlen, op_ptr); } MODULE = Future::AsyncAwait PACKAGE = Future::AsyncAwait int __cxstack_ix() CODE: RETVAL = cxstack_ix; OUTPUT: RETVAL BOOT: 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); wrap_keyword_plugin(&my_keyword_plugin, &next_keyword_plugin); #ifdef HAVE_DMD_HELPER DMD_SET_MAGIC_HELPER(&vtbl, dumpmagic); #endif Future-AsyncAwait-0.36/lib/Future/AsyncAwait000755001750001750 013610147343 17563 5ustar00leoleo000000000000Future-AsyncAwait-0.36/lib/Future/AsyncAwait/Awaitable.pm000444001750001750 1201513610147343 22166 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-2020 -- leonerd@leonerd.org.uk package Future::AsyncAwait::Awaitable; use strict; use warnings; our $VERSION = '0.36'; =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 ) ); } =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_ON_CANCEL Attach a future instance to be cancelled when another one is cancelled. $f1->AWAIT_ON_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_ON_CANCEL { } =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.36/lib/Test000755001750001750 013610147343 15165 5ustar00leoleo000000000000Future-AsyncAwait-0.36/lib/Test/Future000755001750001750 013610147343 16437 5ustar00leoleo000000000000Future-AsyncAwait-0.36/lib/Test/Future/AsyncAwait000755001750001750 013610147343 20502 5ustar00leoleo000000000000Future-AsyncAwait-0.36/lib/Test/Future/AsyncAwait/Awaitable.pm000444001750001750 1271313610147343 23112 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 -- leonerd@leonerd.org.uk package Test::Future::AsyncAwait::Awaitable; use strict; use warnings; our $VERSION = '0.36'; use Test::More; 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 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_deeply( [ $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\n" ), "AWAIT_NEW_FAIL yields object" ); ok( $f->AWAIT_IS_READY, 'AWAIT_IS_READY true' ); ok( !$f->AWAIT_IS_CANCELLED, 'AWAIT_IS_CANCELLED false' ); ok( !defined eval { $f->AWAIT_GET; 1 }, 'AWAIT_GET in void context' ); is( $@, "Oopsie\n", 'AWAIT_GET throws exception' ); }; 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\n" ); ok( $f->AWAIT_IS_READY, 'AWAIT_IS_READY true' ); ok( !defined eval { $f->AWAIT_GET; 1 }, 'AWAIT_GET in void context' ); is( $@, "Late oopsie\n", 'AWAIT_GET throws exception' ); }; 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_ON_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' ); }; } =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.36/t000755001750001750 013610147343 13743 5ustar00leoleo000000000000Future-AsyncAwait-0.36/t/00use.t000444001750001750 15413610147343 15201 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use_ok( "Future::AsyncAwait" ); done_testing; Future-AsyncAwait-0.36/t/01async-immediate.t000444001750001750 243013610147343 17476 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Future; use Future::AsyncAwait; # immediate done ANON scalar { my $func = async sub { return 5; }; my $f = $func->(); isa_ok( $f, "Future", '$f' ); 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_deeply( [ $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' ); } done_testing; Future-AsyncAwait-0.36/t/02await-immediate.t000444001750001750 240413610147343 17470 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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_deeply( [ $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_deeply( [ $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.36/t/03await.t000444001750001750 552313610147343 15542 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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_deeply( [ $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_deeply( [ $fret->get ], [ 1, 2, [ 3, 4, 5, 6 ], 7, 8 ], 'async/await respects stack discipline' ); } # 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 dies { await $f1; die "Oopsie\n"; } my $fret = dies(); $f1->done; is( $fret->failure, "Oopsie\n", '$fret->failure for 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.36/t/04await-twice.t000444001750001750 207313610147343 16651 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Future; use Future::AsyncAwait; my $orig_cxstack_ix = Future::AsyncAwait::__cxstack_ix; # 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' ); } is( Future::AsyncAwait::__cxstack_ix, $orig_cxstack_ix, 'cxstack_ix did not grow during the test' ); done_testing; Future-AsyncAwait-0.36/t/05await-expr.t000444001750001750 102413610147343 16510 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/06await-nested.t000444001750001750 352113610147343 17021 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/07await-label.t000444001750001750 115713610147343 16622 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/08await-cancel.t000444001750001750 153313610147343 16767 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/10pad.t000444001750001750 334413610147343 15176 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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_deeply( [ $fret->get ], [ "outerXX", "outerXX" ], '$fret now ready after done for closure' ); } done_testing; Future-AsyncAwait-0.36/t/11contexts.t000444001750001750 307413610147343 16302 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/12closure.t000444001750001750 154013610147343 16104 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/13regexp.t000444001750001750 137613610147343 15732 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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_deeply( [ $fret->get ], [ "Hello", 0, 5 ], 'await restores regexp context' ); } done_testing; Future-AsyncAwait-0.36/t/14packagevar.t000444001750001750 65613610147343 16525 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/15local-errsv.t000444001750001750 315213610147343 16665 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Refcount 0.09 import => [qw( is_refcount 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.36/t/20context-block.t000444001750001750 224213610147343 17203 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/21context-while.t000444001750001750 311013610147343 17215 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/22context-foreach.t000444001750001750 1063413610147343 17546 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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 $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.36/t/23context-map.t000444001750001750 124413610147343 16672 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/30stringeval.t000444001750001750 147413610147343 16614 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/31destroy.t000444001750001750 270513610147343 16126 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; # Optional dependency. Not required for correctness testing but useful for # debugging when tests fail use constant HAVE_TEST_REFCOUNT => eval { require Test::Refcount }; 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( $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" ); HAVE_TEST_REFCOUNT and Test::Refcount::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' ); HAVE_TEST_REFCOUNT and Test::Refcount::is_oneref( $fret, '$fret should have one ref' ); undef $fret; ok( $destroyed, 'Destroyed by dropping $fret' ); HAVE_TEST_REFCOUNT and $generated_cv and Test::Refcount::is_oneref( $generated_cv, '$generated_cv should have one ref' ); undef $generated_cv; } done_testing; Future-AsyncAwait-0.36/t/32compile-errors.t000444001750001750 347513610147343 17405 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Future::AsyncAwait; # 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 $@; 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( "$@", qr/^Global symbol "\$api" requires explicit package name/, 'Failure message complains about undeclared $api' ); } done_testing; Future-AsyncAwait-0.36/t/40croak.t000444001750001750 60113610147343 15505 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/41end.t000444001750001750 43413610147343 15161 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/42unresolved.t000444001750001750 423413610147343 16624 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Refcount 0.09 import => [qw( is_refcount 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 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.36/t/43failure.t000444001750001750 340013610147343 16060 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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_deeply( [ @{ $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_deeply( [ @{ $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_deeply( [ @{ $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_deeply( [ $fret->failure ], [ "message\n", category => qw( details here ) ], '$fret->failure after ->fail' ); } done_testing; Future-AsyncAwait-0.36/t/44sub-attrs.t000444001750001750 211513610147343 16360 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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 { 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.36/t/45sub-signatures.t000444001750001750 176213610147343 17417 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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' ); } # 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' ); } done_testing; Future-AsyncAwait-0.36/t/50future-subclass.t000444001750001750 111113610147343 17553 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/51awaitable-role.t000444001750001750 120613610147343 17322 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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; Test::More::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 Test::More::like( $@, qr/^Can't apply Future::AsyncAwait::Awaitable to Test::NotAwaitable /, 'exception from unapplicable role' ); } done_testing; Future-AsyncAwait-0.36/t/52awaitable-future.t000444001750001750 43713610147343 17661 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/80await+dynamically.t000444001750001750 236513610147343 20052 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.31_001 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.31001' ) }; plan skip_all => "Syntax::Keyword::Dynamically >= 0.01 is not available" unless eval { require Syntax::Keyword::Dynamically; Syntax::Keyword::Dynamically->VERSION( '0.01' ) }; Future::AsyncAwait->import; Syntax::Keyword::Dynamically->import; 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' ); } done_testing; Future-AsyncAwait-0.36/t/80await+try.t000444001750001750 417713610147343 16365 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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::Try >= 0.07 is not available" unless eval { require Syntax::Keyword::Try; Syntax::Keyword::Try->VERSION( '0.07' ) }; 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 { $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 {} $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/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' ); } done_testing; Future-AsyncAwait-0.36/t/81memory-growth.t000444001750001750 136413610147343 17262 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Test::MemoryGrowth; } or plan skip_all => "No Test::MemoryGrowth"; } use Test::MemoryGrowth; use Test::Refcount; use Future; use Future::AsyncAwait; 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'; done_testing; Future-AsyncAwait-0.36/t/82devel-mat-dumper-helper.t000444001750001750 72213610147343 21045 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/90rt128176.t000444001750001750 125413610147343 15556 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/90rt129836.t000444001750001750 41213610147343 15535 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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.36/t/99pod.t000444001750001750 25713610147343 15215 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok();