Future-AsyncAwait-0.13000755001750001750 013230142756 13474 5ustar00leoleo000000000000Future-AsyncAwait-0.13/Build.PL000444001750001750 122413230142756 15124 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Future::AsyncAwait', requires => { 'Future' => 0, 'perl' => '5.018', # PL_keyword_plugin, SAVEt_CLEARPADRANGE, PADNAME, ... }, test_requires => { 'Test::More' => '0.88', # done_testing }, 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 => [qw( -std=c89 -Ihax )], ); $build->create_build_script; Future-AsyncAwait-0.13/Changes000444001750001750 714213230142756 15130 0ustar00leoleo000000000000Revision history for Future-AsyncAwait 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.13/LICENSE000444001750001750 4376213230142756 14672 0ustar00leoleo000000000000This software is copyright (c) 2018 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) 2018 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) 2018 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.13/MANIFEST000444001750001750 112713230142756 14763 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/pad_block_start.c.inc hax/pad_leavemy.c.inc hax/README hax/save_clearpadrange.c.inc hax/scalarseq.c.inc lib/Future/AsyncAwait.pm lib/Future/AsyncAwait.xs 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/10pad.t t/11contexts.t t/12closure.t t/20context-block.t t/21context-while.t t/22context-foreach.t t/40croak.t t/80await+try.t t/99pod.t Future-AsyncAwait-0.13/META.json000444001750001750 230213230142756 15247 0ustar00leoleo000000000000{ "abstract" : "deferred subroutine syntax for futures", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.422", "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.018" } }, "test" : { "requires" : { "Test::More" : "0.88" } } }, "provides" : { "Future::AsyncAwait" : { "file" : "lib/Future/AsyncAwait.pm", "version" : "0.13" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "x_IRC" : "irc://irc.perl.org/#io-async" }, "version" : "0.13", "x_serialization_backend" : "JSON::PP version 2.94" } Future-AsyncAwait-0.13/META.yml000444001750001750 133613230142756 15105 0ustar00leoleo000000000000--- abstract: 'deferred subroutine syntax for futures' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test::More: '0.88' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.422, 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.13' requires: Future: '0' perl: '5.018' resources: IRC: irc://irc.perl.org/#io-async license: http://dev.perl.org/licenses/ version: '0.13' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Future-AsyncAwait-0.13/README000444001750001750 1706713230142756 14544 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, and lately even 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 forces the return value of the function to always be 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. 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. 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. EARLY-VERSION WARNING WARNING: The actual semantics in this module are in an early state of implementation. Some things will randomly break. While it seems stable enough for small-scale development and experimental testing, don't expect to be able to use this module reliably in production yet. Things That Work 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 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; } Things That Don't Yet Work local variable assignments inside an async function will confuse the suspend mechanism: our $DEBUG = 0; async sub quark { local $DEBUG = 1; await func(); } Since foreach loops on non-lexical iterator variables (usually package variables) effectively imply a local-like behaviour, these are also disallowed. our $VAR; async sub splurt { foreach $VAR ( LIST ) { await ... } } Additionally, complications with the savestack appear to be affecting some uses of package-level our variables captured by async functions: our $VAR; async sub bork { print "VAR is $VAR\n"; await func(); } See also the "TODO" list for further things. Async Without Await 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. 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. 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. Some notes on what makes the problem hard can be found at https://rt.cpan.org/Ticket/Display.html?id=122793 * Clean up the implementation; check for and fix memory leaks. * Support older versions of perl than 5.18. https://rt.cpan.org/Ticket/Display.html?id=122252 * Support sub signatures in recent perls. https://rt.cpan.org/Ticket/Display.html?id=124122 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. AUTHOR Paul Evans Future-AsyncAwait-0.13/hax000755001750001750 013230142756 14254 5ustar00leoleo000000000000Future-AsyncAwait-0.13/hax/COP_SEQ_RANGE_HIGH_set.c.inc000444001750001750 30013230142756 21015 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.13/hax/README000444001750001750 71213230142756 15251 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.13/hax/block_end.c.inc000444001750001750 216413230142756 17250 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.13/hax/block_start.c.inc000444001750001750 73113230142756 17615 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.13/hax/cx_pushblock.c.inc000444001750001750 53213230142756 17771 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); ENTER; SAVETMPS; PUSHBLOCK(cx, t, sp); return cx; } #endif Future-AsyncAwait-0.13/hax/cx_pusheval.c.inc000444001750001750 46213230142756 17630 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.13/hax/pad_block_start.c.inc000444001750001750 124513230142756 20462 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.13/hax/pad_leavemy.c.inc000444001750001750 436213230142756 17620 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.13/hax/save_clearpadrange.c.inc000444001750001750 76513230142756 21123 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.13/hax/scalarseq.c.inc000444001750001750 136713230142756 17312 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.13/lib000755001750001750 013230142756 14242 5ustar00leoleo000000000000Future-AsyncAwait-0.13/lib/Future000755001750001750 013230142756 15514 5ustar00leoleo000000000000Future-AsyncAwait-0.13/lib/Future/AsyncAwait.pm000444001750001750 1752713230142756 20306 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-2018 -- leonerd@leonerd.org.uk package Future::AsyncAwait; use strict; use warnings; our $VERSION = '0.13'; 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, and lately even 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 forces the return value of the function to always be 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. =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. 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. =head1 EARLY-VERSION WARNING B: The actual semantics in this module are in an early state of implementation. Some things will randomly break. While it seems stable enough for small-scale development and experimental testing, don't expect to be able to use this module reliably in production yet. =head2 Things That Work 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 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; } =head2 Things That Don't Yet Work C variable assignments inside an C function will confuse the suspend mechanism: our $DEBUG = 0; async sub quark { local $DEBUG = 1; await func(); } Since C loops on non-lexical iterator variables (usually package variables) effectively imply a C-like behaviour, these are also disallowed. our $VAR; async sub splurt { foreach $VAR ( LIST ) { await ... } } Additionally, complications with the savestack appear to be affecting some uses of package-level C variables captured by async functions: our $VAR; async sub bork { print "VAR is $VAR\n"; await func(); } See also the L list for further things. =head2 Async Without Await 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 WITH OTHER MODULES =head2 Syntax::Keyword::Try As of C version 0.10 and L version 0.07, cross-module integration tests assert that basic C blocks inside an C work correctly, including those that attempt to C from inside C. =cut sub import { my $class = shift; my $caller = caller; $class->import_into( $caller, @_ ); } sub import_into { my $class = shift; my ( $caller, @syms ) = @_; @syms or @syms = qw( async ); my %syms = map { $_ => 1 } @syms; $^H{"Future::AsyncAwait/async"}++ if delete $syms{async}; croak "Unrecognised import symbols @{[ keys %syms ]}" if keys %syms; } =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. Some notes on what makes the problem hard can be found at L =item * Clean up the implementation; check for and fix memory leaks. =item * Support older versions of perl than 5.18. L =item * Support sub signatures in recent perls. L =back =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. =head1 AUTHOR Paul Evans =cut 0x55AA; Future-AsyncAwait-0.13/lib/Future/AsyncAwait.xs000444001750001750 7512713230142756 20324 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 -- leonerd@leonerd.org.uk */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #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, 24, 0) # define HAVE_PERL_CX_5_24 #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 #include "save_clearpadrange.c.inc" #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" #endif typedef struct SuspendedFrame SuspendedFrame; struct SuspendedFrame { SuspendedFrame *next; U8 type; U8 gimme; U32 stacklen; SV **stack; U32 marklen; I32 *marks; /* 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 */ struct { SV *sv; U32 mask, set; } svflags; /* for SAVEt_SET_SVFLAGS */ } u; union { SV *sv; /* for SAVEt_SV, SAVEt_FREESV */ 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; }; #ifdef HAVE_ITERVAR SV *itervar; #endif }; 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 */ SuspendedFrame *frames; U32 padlen; SV **padslots; } SuspendedState; static void debug_sv_summary(const SV *sv) { fprintf(stderr, "SV{type=%d,refcnt=%d", SvTYPE(sv), SvREFCNT(sv)); if(SvROK(sv)) fprintf(stderr, ",ROK"); else if(SvIOK(sv)) fprintf(stderr, ",IV=%d", SvIVX(sv)); fprintf(stderr, "}"); } static void debug_showstack(const char *name) { #ifdef DEBUG_SHOW_STACKS 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"); } #endif } /* * Magic that we attach to suspended CVs, that contains state required to restore * them */ static MGVTBL vtbl = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ NULL, /* free - TODO?? */ }; #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; sv_magicext((SV *)cv, NULL, PERL_MAGIC_ext, &vtbl, (char *)ret, 0); return ret; } #define suspend_block(frame, cx) MY_suspend_block(aTHX_ frame, cx) static void MY_suspend_block(pTHX_ SuspendedFrame *frame, PERL_CONTEXT *cx) { /* The base of the stack within this context */ SV **bp = PL_stack_base + cx->blk_oldsp + 1; I32 *markbase = PL_markstack + cx->blk_oldmarksp + 1; frame->stacklen = (I32)(PL_stack_sp - PL_stack_base) - cx->blk_oldsp; if(frame->stacklen) { 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 i; Newx(frame->marks, frame->marklen, I32); for(i = 0; i < frame->marklen; i++) { /* Translate mark value relative to bp */ I32 relmark = markbase[i] - cx->blk_oldsp; frame->marks[i] = relmark; } PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp; } 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 */ 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) { 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; } 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_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) croak("TODO: Unsure how to handle a savestack entry of SAVEt_INT_SMALL with var != &PL_tmps_floor"); saved->type = SAVEt_INT; saved->u.iptr = var; saved->cur.i = *var; saved->saved.i = val; /* restore it for now */ *var = val; 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; } #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) croak("TODO: Unsure how to handle a savestack entry of SAVEt_STRLEN with var != &PL_tmps_floor"); saved->type = SAVEt_STRLEN; saved->u.lenptr = var; saved->cur.len = *var; saved->saved.len = val; /* restore it for now */ *var = val; 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) croak("TODO: Unsure how to handle a savestack entry of SAVEt_SV with gv != PL_errgv"); 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) = SvREFCNT_inc(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) croak("TODO: Unsure how to handle a savestack entry of SAVEt_PADSV_AND_MORTALIZE with padav != PL_comppad"); 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: croak("TODO: Unsure how to handle savestack entry of %d", type); } frame->savedlen++; } if(OLDSAVEIX(cx) != PL_savestack_ix) croak("TODO: handle OLDSAVEIX"); } 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 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; suspend_block(frame, cx); /* 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 */ continue; case CXt_LOOP_PLAIN: frame->type = type; frame->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->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) croak("TODO: Unsure how to handle a foreach loop with itervar != PL_comppad"); # else if(cx->blk_loop.itervar_u.svp != &PAD_SVl(cx->blk_loop.my_op->op_targ)) croak("TODO: Unsure how to handle a foreach loop with itervar != PAD_SVl(op_targ))"); # endif frame->itervar = SvREFCNT_inc(*CxITERVAR(cx)); #endif if(type == CXt_LOOP_LAZYSV) { /* these two fields are refcounted, so we need to save them from * dounwind() throwing them away */ SvREFCNT_inc(frame->loop.state_u.lazysv.cur); SvREFCNT_inc(frame->loop.state_u.lazysv.end); } #if !HAVE_PERL_VERSION(5, 24, 0) else if(type == CXt_LOOP_FOR) { if(frame->loop.state_u.ary.ary) SvREFCNT_inc(frame->loop.state_u.ary.ary); } #endif continue; case CXt_EVAL: { if(!(cx->cx_type & CXp_TRYBLOCK)) croak("TODO: handle CXt_EVAL without CXp_TRYBLOCK"); if(cx->blk_eval.old_namesv) croak("TODO: handle cx->blk_eval.old_namesv"); if(cx->blk_eval.old_eval_root) croak("TODO: handle cx->blk_eval.old_eval_root"); if(cx->blk_eval.cur_text) croak("TODO: handle cx->blk_eval.cur_text"); if(cx->blk_eval.cv) croak("TODO: handle cx->blk_eval.cv"); if(cx->blk_eval.cur_top_env != PL_top_env) croak("TODO: handle cx->blk_eval.cur_top_env"); frame->type = CXt_EVAL; frame->gimme = cx->blk_gimme; frame->eval.retop = cx->blk_eval.retop; continue; } default: croak("TODO: unsure how to handle a context frame of type %d", CxTYPE(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]; PadARRAY(pad)[i] = newSV(0); } dounwind(cxix); } #define resume_block(frame, cx) MY_resume_block(aTHX_ frame, cx) static void MY_resume_block(pTHX_ SuspendedFrame *frame, PERL_CONTEXT *cx) { I32 i; 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); } 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; case SAVEt_CLEARPADRANGE: save_clearpadrange(saved->u.clearpad.padix, saved->u.clearpad.count); break; 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_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, saved->saved.sv, SAVEt_SV); SvREFCNT_dec(GvSV(saved->u.gv)); GvSV(saved->u.gv) = 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: croak("TODO: Unsure how to restore a %d savestack entry\n", saved->type); } } if(frame->saved) Safefree(frame->saved); } #define suspendedstate_resume(state, cv) MY_suspendedstate_resume(aTHX_ state, cv) static void MY_suspendedstate_resume(pTHX_ SuspendedState *state, CV *cv) { SuspendedFrame *frame, *next; for(frame = state->frames; frame; frame = next) { next = frame->next; PERL_CONTEXT *cx; switch(frame->type) { case CXt_BLOCK: cx = cx_pushblock(CXt_BLOCK, frame->gimme, PL_stack_sp, PL_savestack_ix); /* nothing else special */ break; case CXt_LOOP_PLAIN: 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->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: 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->loop; #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; #endif break; case CXt_EVAL: cx = cx_pushblock(CXt_EVAL|CXp_TRYBLOCK, frame->gimme, PL_stack_sp, PL_savestack_ix); cx_pusheval(cx, frame->eval.retop, NULL); PL_in_eval = EVAL_INEVAL; CLEAR_ERRSV(); break; default: croak("TODO: Unsure how to restore a %d frame\n", frame->type); } resume_block(frame, cx); Safefree(frame); } 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]; } } } /* * Some Future class helper functions */ #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; SAVETMPS; PUSHMARK(mark); SV **bottom = mark + 1; /* splice the class name 'Future' in to the start of the stack */ for (svp = SP; svp >= bottom; svp--) { *(svp+1) = *svp; } if(f) *bottom = SvREFCNT_inc(f); else *bottom = sv_2mortal(newSVpvn("Future", 6)); SP++; PUTBACK; call_method("done", G_SCALAR); SPAGAIN; SV *ret = SvREFCNT_inc(POPs); FREETMPS; LEAVE; 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; SAVETMPS; PUSHMARK(SP); if(f) PUSHs(SvREFCNT_inc(f)); else mPUSHp("Future", 6); mPUSHs(newSVsv(failure)); PUTBACK; call_method("fail", G_SCALAR); SPAGAIN; SV *ret = SvREFCNT_inc(POPs); FREETMPS; LEAVE; 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; SAVETMPS; PUSHMARK(SP); PUSHs(proto); PUTBACK; call_method("new", G_SCALAR); SPAGAIN; SV *f = SvREFCNT_inc(POPs); FREETMPS; LEAVE; 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_is_ready(aTHX_ f) static int MY_future_is_ready(pTHX_ SV *f) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(f); PUTBACK; call_method("is_ready", G_SCALAR); SPAGAIN; int is_ready = POPi; PUTBACK; FREETMPS; LEAVE; return is_ready; } #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; PUSHMARK(SP); XPUSHs(f); PUTBACK; call_method("get", gimme); LEAVE; } #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; PUSHMARK(SP); XPUSHs(f); mXPUSHs(newRV_inc((SV *)code)); PUTBACK; call_method("on_ready", G_VOID); LEAVE; } /* * Custom ops */ static XOP xop_leaveasync; static OP *pp_leaveasync(pTHX) { dSP; dMARK; PERL_CONTEXT *cx = CX_CUR(); SV *f = NULL; SV *ret; SV **oldsp = PL_stack_base + cx->blk_oldsp; SuspendedState *state = suspendedstate_get(find_runcv(0)); if(state && state->returning_future) f = state->returning_future; if(SvTRUE(ERRSV)) { ret = future_fail(f, ERRSV); } else { ret = future_done_from_stack(f, mark); } /* Pop extraneous stack items */ while(SP > oldsp) POPs; PUSHs(ret); PUTBACK; 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; SuspendedState *state = suspendedstate_get(curcv); if(state && state->awaiting_future) { I32 orig_height; f = 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); suspendedstate_resume(state, curcv); debug_showstack("Stack after resume"); } 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); /* This might throw */ future_get_to_stack(f, GIMME_V); return PL_op->op_next; } debug_showstack("Stack before suspend"); if(!state) { /* Clone the CV and then attach suspendedstate magic to it */ curcv = cv_clone(curcv); state = suspendedstate_new(curcv); } suspendedstate_suspend(state, origcv); CvSTART(curcv) = PL_op; /* resume from here */ future_on_ready(f, curcv); state->awaiting_future = SvREFCNT_inc(f); if(!state->returning_future) state->returning_future = future_new_from_proto(f); PUSHMARK(SP); PUSHs(state->returning_future); PUTBACK; 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; } /* * Lexer extensions */ #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; } #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_scan_ident() MY_lex_scan_ident(aTHX) static SV *MY_lex_scan_ident(pTHX) { /* Inspired by * https://metacpan.org/source/MAUKE/Function-Parameters-1.0705/Parameters.xs#L265 */ I32 c; bool at_start; SV *ret = newSVpvs(""); if(lex_bufutf8()) SvUTF8_on(ret); at_start = TRUE; c = lex_peek_unichar(0); while(c != -1) { if(at_start ? isIDFIRST_uni(c) : isALNUM_uni(c)) { at_start = FALSE; sv_cat_c(ret, lex_read_unichar(0)); c = lex_peek_unichar(0); } else break; } if(SvCUR(ret)) return ret; SvREFCNT_dec(ret); return NULL; } /* * 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); if(lex_peek_unichar(0) != '{') croak("Expected async sub %sto be followed by '{'", name ? "NAME " : ""); I32 floor_ix = start_subparse(FALSE, name ? 0 : CVf_ANON); SAVEFREESV(PL_compcv); /* Save the identity of the currently-compiling sub so that * await_keyword_plugin() can check */ hv_stores(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", newRV((SV *)PL_compcv)); I32 save_ix = block_start(TRUE); OP *body = parse_block(0); SvREFCNT_inc(PL_compcv); body = block_end(save_ix, body); /* turn block into * PUSHMARK; eval { BLOCK }; LEAVEASYNC */ OP *op = newLISTOP(OP_LINESEQ, 0, newOP(OP_PUSHMARK, 0), NULL); 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, NULL, op); if(name) { *op_ptr = newOP(OP_NULL, 0); SvREFCNT_dec(name); return KEYWORD_PLUGIN_STMT; } else { /* Placate Perl RT#131519 * cv_clone() doesn't set CvOUTSIDE if !CvHASEVAL, and in doing so causes a * subsequent cv_clone() on *that* CV to SEGV */ CvHASEVAL_on(cv); *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 **asynccvrefp = hv_fetchs(GvHV(PL_hintgv), "Future::AsyncAwait/PL_compcv", 0); if(!asynccvrefp || !*asynccvrefp || SvRV(*asynccvrefp) != (SV *)PL_compcv) croak("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_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 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); next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = &my_keyword_plugin; Future-AsyncAwait-0.13/t000755001750001750 013230142756 13737 5ustar00leoleo000000000000Future-AsyncAwait-0.13/t/00use.t000444001750001750 15413230142756 15175 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use_ok( "Future::AsyncAwait" ); done_testing; Future-AsyncAwait-0.13/t/01async-immediate.t000444001750001750 177613230142756 17506 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' ); } done_testing; Future-AsyncAwait-0.13/t/02await-immediate.t000444001750001750 240413230142756 17464 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.13/t/03await.t000444001750001750 473713230142756 15544 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Future; use Future::AsyncAwait; 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' ); } # 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' ); } # async sub called 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' ); } # 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' ); } done_testing; Future-AsyncAwait-0.13/t/04await-twice.t000444001750001750 162713230142756 16651 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Future; use Future::AsyncAwait; # 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 ) = @_; await $f1; await $f2; } my $f1 = Future->new; my $f2 = Future->new; my $fret = wait_for_both( $f1, $f2 ); $f1->done; $f2->done( "result" ); is( scalar $fret->get, "result", '$fret->get from double await by pad' ); } done_testing; Future-AsyncAwait-0.13/t/05await-expr.t000444001750001750 56213230142756 16472 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Future; use Future::AsyncAwait; { 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' ); } done_testing; Future-AsyncAwait-0.13/t/10pad.t000444001750001750 355013230142756 15171 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' ); } # 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' ); } # captured variables of nested subs { async sub with_inner_subs { my @F = @_; my $captured = "A"; my $subB = sub { $captured .= "B"; }; await $F[0]; $subB->(); $captured .= "C"; my $subD = sub { $captured .= "D"; }; await $F[1]; $subD->(); $captured .= "E"; return $captured; } my $f1 = Future->new; my $f2 = Future->new; my $fret = with_inner_subs( $f1, $f2 ); $f1->done; $f2->done; is( scalar $fret->get, "ABCDE", '$fret now ready after done for inner subs' ); } done_testing; Future-AsyncAwait-0.13/t/11contexts.t000444001750001750 243313230142756 16274 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' ); } # 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.13/t/12closure.t000444001750001750 153313230142756 16102 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; # just to create a real closure $sub = sub { $x++; 123 }; await $f1; } my $f = closure_before(); $f1->done( 45 ); 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 { my $ret = await $f1; my $x; # just to create a real closure $sub = sub { $x++; 123 }; return $ret; } my $f = closure_after(); $f1->done( 45 ); is( $f->get, 45, 'result of async sub' ); is( $sub->(), 123, 'result of closure after' ); } done_testing; Future-AsyncAwait-0.13/t/20context-block.t000444001750001750 224213230142756 17177 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.13/t/21context-while.t000444001750001750 311013230142756 17211 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.13/t/22context-foreach.t000444001750001750 445413230142756 17525 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' ); } # TODO: # This ought to be a compiletime check. That's hard right now so for now # it's a runtime check { our $VAR; my $f1 = Future->new; async sub foreach_pkgvar { foreach $VAR ( 1 .. 3 ) { await $f1; } } my $fret = foreach_pkgvar(); $f1->done; ok( $fret->failure, 'foreach $VAR failed' ); like( $fret->failure, qr/\bnon-lexical iterator\b/, 'Failure message refers to non-lexical iterator' ); } done_testing; Future-AsyncAwait-0.13/t/40croak.t000444001750001750 60113230142756 15501 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.13/t/80await+try.t000444001750001750 377513230142756 16364 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; } # 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.13/t/99pod.t000444001750001750 25713230142756 15211 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();