diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 0000000..24b6e3b --- /dev/null +++ b/.editorconfig @@ -0,0 +1,4 @@ +root = true + +[*.{pm,pl,t}] +indent_size = 3 diff --git a/Build.PL b/Build.PL index 265d8da..ada5d82 100644 --- a/Build.PL +++ b/Build.PL @@ -1,9 +1,23 @@ +use v5; use strict; use warnings; use lib 'inc'; use Module::Build::with::XSTests; +my @extra_compiler_flags = qw( -I. -Iinclude -Ihax ); + +# Perl 5.36 made -std=c99 standard; before then we'll have to request it specially +push @extra_compiler_flags, qw( -std=c99 ) if $^V lt v5.36.0; + +push @extra_compiler_flags, qw( -DDEBUGGING=-g ) if $^X =~ m|/debugperl|; + +use Config; +if( $Config{ccname} eq "gcc" ) { + # Enable some extra gcc warnings, largely just for author interest + push @extra_compiler_flags, qw( -Wall -Wno-unused-function -Wno-unused-value ); +} + my $build = Module::Build::with::XSTests->new( module_name => 'XS::Parse::Sublike', requires => { @@ -12,8 +26,7 @@ my $build = Module::Build::with::XSTests->new( }, test_requires => { 'Sub::Util' => 0, - 'Test::Fatal' => 0, - 'Test::More' => '0.88', # done_testing + 'Test2::V0' => 0, }, configure_requires => { 'Module::Build' => '0.4004', # test_requires @@ -22,7 +35,8 @@ my $build = Module::Build::with::XSTests->new( create_license => 1, create_readme => 1, - extra_compiler_flags => [qw( -I. -Ihax )], + extra_compiler_flags => \@extra_compiler_flags, + c_source => [ "src/" ], ); $build->create_build_script; diff --git a/Changes b/Changes index 785727c..772dedf 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,47 @@ Revision history for XS-Parse-Sublike +0.21 2023-10-11 + [BUGFIXES] + * Ensure that exceptions thrown from runtime signature handling + appear to come from the callsite and not declaration + * Fix signedness of printf format when complaining about + mismatched `->ver` + +0.20 2023-09-09 + [BUGFIXES] + * Correct ->VERSION check for Object::Pad or Future::AsyncAwait + cross-module tests (RT149700) + * Don't upset gcc's -Wformat by passing an unbounded STRLEN into + %.*s format (RT133035) + * Avoid colons in filename of t/71extended+Object-Pad.t because + Windows doesn't like them (RT149712) + * Ensure that mixed positional + named params in signatures work + properly (thanks alh) + * Ensure name shadowing of param names prints the right diagnostic + warning (thanks alh) + +0.19 2023-09-07 + [CHANGES] + * Added `Sublike::Extended`, a prefix keyword to enable the extended + signature parser for named params and attributes + * Beginnings of an (experimental) XS-level API for attributes on + parameters + * Complain on attempts to register a sublike keyword with neither a + permit function nor hinthash key + +0.18 2023-06-14 + [CHANGES] + * Swap all the unit tests from Test::More to Test2::V0 + + [BUGFIXES] + * Remember to set `-std=c99` compiler flag on Perls before v5.36 + +0.17 2023-03-21 + [CHANGES] + * Experimental support for named param syntax in parse_subsignature() + * Support core perl's `method` syntax when available by setting + CVf_IsMETHOD (perl >= 5.37.10) + 0.16 2021-12-16 [CHANGES] * No longer support ABI version 3 even in back-compatibility mode diff --git a/LICENSE b/LICENSE index f15476d..2404a71 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -This software is copyright (c) 2021 by Paul Evans . +This software is copyright (c) 2023 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. @@ -12,7 +12,7 @@ b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- -This software is Copyright (c) 2021 by Paul Evans . +This software is Copyright (c) 2023 by Paul Evans . This is free software, licensed under: @@ -272,7 +272,7 @@ That's all there is to it! --- The Artistic License 1.0 --- -This software is Copyright (c) 2021 by Paul Evans . +This software is Copyright (c) 2023 by Paul Evans . This is free software, licensed under: @@ -292,21 +292,21 @@ Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through - textual modification. + 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. + Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for - the package. + 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.) + 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. + 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 @@ -373,7 +373,7 @@ 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. +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End diff --git a/MANIFEST b/MANIFEST index 1622bf9..700d1cb 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,17 +1,23 @@ +.editorconfig Build.PL Changes hax/block_end.c.inc hax/block_start.c.inc hax/COP_SEQ_RANGE_HIGH_set.c.inc +hax/croak_from_caller.c.inc hax/lexer-additions.c.inc +hax/LOGOP_ANY.c.inc hax/make_argcheck_aux.c.inc +hax/newSV_with_free.c.inc hax/pad_block_start.c.inc hax/pad_leavemy.c.inc -hax/parse_subsignature.c.inc hax/scalarseq.c.inc hax/sv_setrv.c.inc hax/wrap_keyword_plugin.c.inc inc/Module/Build/with/XSTests.pm +include/parse_subsignature_ex.h +lib/Sublike/Extended.pm +lib/Sublike/Extended.xs lib/XS/Parse/Sublike.pm lib/XS/Parse/Sublike.xs lib/XS/Parse/Sublike/Builder.pm @@ -21,10 +27,13 @@ MANIFEST This list of files META.json META.yml README +src/parse_subsignature_ex.c t/00use.t t/01func.t t/02func-signatures.t t/03func-deparse.t +t/04func-named-params.t +t/05func-sig-attributes.t t/10stages-permit.t t/11stages-pre_subparse.t t/12stages-post_blockstart.t @@ -39,6 +48,10 @@ t/41parts-attrs.t t/42parts-signature.t t/50flags-no-body.t t/60actions.t +t/70extended.t +t/80extended+async.t +t/80extended+feature-class.t +t/80extended+Object-Pad.t t/99pod.t t/actions.xs t/any.xs diff --git a/META.json b/META.json index c15b573..72ff7b0 100644 --- a/META.json +++ b/META.json @@ -4,7 +4,7 @@ "Paul Evans " ], "dynamic_config" : 1, - "generated_by" : "Module::Build version 0.4231", + "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], @@ -32,19 +32,22 @@ "test" : { "requires" : { "Sub::Util" : "0", - "Test::Fatal" : "0", - "Test::More" : "0.88" + "Test2::V0" : "0" } } }, "provides" : { + "Sublike::Extended" : { + "file" : "lib/Sublike/Extended.pm", + "version" : "0.21" + }, "XS::Parse::Sublike" : { "file" : "lib/XS/Parse/Sublike.pm", - "version" : "0.16" + "version" : "0.21" }, "XS::Parse::Sublike::Builder" : { "file" : "lib/XS/Parse/Sublike/Builder.pm", - "version" : "0.16" + "version" : "0.21" } }, "release_status" : "stable", @@ -53,6 +56,6 @@ "http://dev.perl.org/licenses/" ] }, - "version" : "0.16", - "x_serialization_backend" : "JSON::PP version 4.05" + "version" : "0.21", + "x_serialization_backend" : "JSON::PP version 4.07" } diff --git a/META.yml b/META.yml index 7ec4e7b..45d7d19 100644 --- a/META.yml +++ b/META.yml @@ -5,27 +5,29 @@ author: build_requires: ExtUtils::CBuilder: '0' Sub::Util: '0' - Test::Fatal: '0' - Test::More: '0.88' + Test2::V0: '0' configure_requires: Module::Build: '0.4004' dynamic_config: 1 -generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.150010' +generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: XS-Parse-Sublike provides: + Sublike::Extended: + file: lib/Sublike/Extended.pm + version: '0.21' XS::Parse::Sublike: file: lib/XS/Parse/Sublike.pm - version: '0.16' + version: '0.21' XS::Parse::Sublike::Builder: file: lib/XS/Parse/Sublike/Builder.pm - version: '0.16' + version: '0.21' requires: perl: '5.016' resources: license: http://dev.perl.org/licenses/ -version: '0.16' +version: '0.21' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/README b/README index a58fe9d..374fff8 100644 --- a/README +++ b/README @@ -227,12 +227,17 @@ PARSE HOOKS The parameter signature of the function. - This part can be skipped, but the bit is ignored when in - require_parts. It is always permitted not to provide a signature for - a function definition, because such syntax only applies when use + This part can be skipped, but it is always permitted not to provide a + signature for a function definition even if the bit it set in + require_parts. This is because such syntax only applies when use feature 'signatures' is in effect, and only on supporting perl versions. + However, setting the bit in require_parts instead has the effect of + enabling use feature 'signatures' (at least on supporting perl + versions), thus permitting the syntax to use a signature even if the + signatures feature was not previously enabled. + XS_PARSE_SUBLIKE_PART_BODY The actual body of the function, expressed as a brace-delimited diff --git a/XSParseSublike.h b/XSParseSublike.h index c0a266e..9d23bfd 100644 --- a/XSParseSublike.h +++ b/XSParseSublike.h @@ -1,7 +1,7 @@ #ifndef __XS_PARSE_SUBLIKE_H__ #define __XS_PARSE_SUBLIKE_H__ -#define XSPARSESUBLIKE_ABI_VERSION 4 +#define XSPARSESUBLIKE_ABI_VERSION 5 struct XSParseSublikeContext { SV *name; /* may be NULL for anon subs */ @@ -25,6 +25,11 @@ enum { XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL = 1<<1, XS_PARSE_SUBLIKE_FLAG_PREFIX = 1<<2, + /* *Experimental* named parameter parsing support */ + XS_PARSE_SUBLIKE_FLAG_SIGNATURE_NAMED_PARAMS = 1<<3, + /* *Experimental* parameter attribute parsing support */ + XS_PARSE_SUBLIKE_FLAG_SIGNATURE_PARAM_ATTRIBUTES = 1<<4, + /* Back-compat flags we hope to remove in the next ABI version */ XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS = 1<<15, }; @@ -92,6 +97,43 @@ static int S_xs_parse_sublike_any(pTHX_ const struct XSParseSublikeHooks *hooks, return (*parseany_xs_parse_sublike_func)(aTHX_ hooks, hookdata, op_ptr); } + +/* Experimental support for subroutine parameter attributes. + * Only supported on Perl v5.26 or later + */ + +struct XPSSignatureParamContext { + bool is_named; + PADOFFSET padix; + OP *varop; + /* apply phase runs here */ + OP *defop; + OP *op; + /* post_defop phase runs here */ +}; + +struct XPSSignatureAttributeFuncs { + U32 ver; /* caller must initialise to XSPARSESUBLIKE_ABI_VERSION */ + U32 flags; + const char *permit_hintkey; + + void (*apply)(pTHX_ struct XPSSignatureParamContext *ctx, SV *attrvalue, void **attrdata_ptr, void *funcdata); + void (*post_defop)(pTHX_ struct XPSSignatureParamContext *ctx, void *attrdata, void *funcdata); + + void (*free)(pTHX_ void *attrdata, void *funcdata); +}; + +static void (*register_xps_signature_attribute_func)(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata); +#define register_xps_signature_attribute(name, funcs, funcdata) S_register_xps_signature_attribute(aTHX_ name, funcs, funcdata) +static void S_register_xps_signature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata) +{ + if(!register_xps_signature_attribute_func) + croak("Must call boot_xs_parse_sublike() first"); + + (*register_xps_signature_attribute_func)(aTHX_ name, funcs, funcdata); +} + + #define boot_xs_parse_sublike(ver) S_boot_xs_parse_sublike(aTHX_ ver) static void S_boot_xs_parse_sublike(pTHX_ double ver) { SV **svp; @@ -121,6 +163,9 @@ static void S_boot_xs_parse_sublike(pTHX_ double ver) { parseany_xs_parse_sublike_func = INT2PTR(int (*)(pTHX_ const struct XSParseSublikeHooks *, void *, OP**), SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parseany()@4", 0))); + + register_xps_signature_attribute_func = INT2PTR(void (*)(pTHX_ const char *, const struct XPSSignatureAttributeFuncs *, void *), + SvUV(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/register_sigattr()@5", 0))); } #endif diff --git a/hax/LOGOP_ANY.c.inc b/hax/LOGOP_ANY.c.inc new file mode 100644 index 0000000..52d3d65 --- /dev/null +++ b/hax/LOGOP_ANY.c.inc @@ -0,0 +1,41 @@ +/* vi: set ft=c : */ + +struct logop_any { + BASEOP + OP *op_first; + OP *op_other; + ANY *op_any; +}; + +typedef struct logop_any LOGOP_ANY; + +#define cLOGOP_ANYx(o) ((LOGOP_ANY *)o) +#define cLOGOP_ANY cLOGOP_ANYx(PL_op) +#define cLOGOP_ANYo cLOGOP_ANYx(o) + +#ifndef OpTYPE_set +# define OpTYPE_set(op, type) \ + STMT_START { \ + op->op_type = (OPCODE)type; \ + op->op_ppaddr = PL_ppaddr[type]; \ + } STMT_END +#endif + +#define alloc_LOGOP_ANY(type, first, other) MY_alloc_LOGOP_ANY(aTHX_ type, first, other) +static LOGOP_ANY *MY_alloc_LOGOP_ANY(pTHX_ I32 type, OP *first, OP *other) +{ + dVAR; + LOGOP_ANY *logop; + OP *kid = first; + NewOp(1101, logop, 1, LOGOP_ANY); + 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; +} diff --git a/hax/croak_from_caller.c.inc b/hax/croak_from_caller.c.inc new file mode 100644 index 0000000..9192146 --- /dev/null +++ b/hax/croak_from_caller.c.inc @@ -0,0 +1,36 @@ +/* vi: set ft=c : */ + +static void S_croaksv_from_caller(pTHX_ SV *msg_sv) + __attribute__noreturn__; + +static void S_croaksv_from_caller(pTHX_ SV *msg_sv) +{ + I32 count = 0; + const PERL_CONTEXT *cx; + while((cx = caller_cx(count, NULL))) { + count++; + + /* TODO: Skip internal call frames? */ + /* warn("TODO: maybe croak from caller where caller stash is %s\n", + * HvNAME(CopSTASH(cx->blk_oldcop))); + */ + PL_curcop = cx->blk_oldcop; + break; + } + + croak_sv(msg_sv); +} + +#define croak_from_caller(fmt, ...) S_croak_from_caller(aTHX_ fmt, __VA_ARGS__) +static void S_croak_from_caller(pTHX_ const char *fmt, ...) + __attribute__noreturn__; + +static void S_croak_from_caller(pTHX_ const char *fmt, ...) +{ + va_list args; + va_start(args, fmt); + SV *msg_sv = sv_2mortal(vnewSVpvf(fmt, &args)); + va_end(args); + + S_croaksv_from_caller(aTHX_ msg_sv); +} diff --git a/hax/newSV_with_free.c.inc b/hax/newSV_with_free.c.inc new file mode 100644 index 0000000..4852e33 --- /dev/null +++ b/hax/newSV_with_free.c.inc @@ -0,0 +1,20 @@ +/* vi: set ft=c : */ + +static int magic_free(pTHX_ SV *sv, MAGIC *mg) +{ + void (*freefunc)(pTHX_ SV *sv) = (void *)mg->mg_ptr; + (*freefunc)(aTHX_ sv); + return 0; +} + +static const MGVTBL vtbl_sv_with_free = { + .svt_free = magic_free, +}; + +#define newSV_with_free(size, freefunc) S_newSV_with_free(aTHX_ size, freefunc) +static SV *S_newSV_with_free(pTHX_ STRLEN size, void (*freefunc)(pTHX_ SV *sv)) +{ + SV *sv = newSV(size); + sv_magicext(sv, NULL, PERL_MAGIC_ext, &vtbl_sv_with_free, (void *)freefunc, 0); + return sv; +} diff --git a/hax/parse_subsignature.c.inc b/hax/parse_subsignature.c.inc deleted file mode 100644 index f6570e0..0000000 --- a/hax/parse_subsignature.c.inc +++ /dev/null @@ -1,220 +0,0 @@ -/* vi: set ft=c : */ - -#ifndef parse_subsignature - -#define PERL_EXT -#include "feature.h" - -#include "make_argcheck_aux.c.inc" - -/* - * 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: - croak("Expected a signature element at <%s>\n", parser->bufptr); - } - - 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); - - 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); - - lex_read_space(0); - } - - 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) != ')') { - lex_read_space(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 (!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 = make_argcheck_aux( - parser->sig_elems, parser->sig_optelems, parser->sig_slurpy); - - OP *checkop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux); - - checkop = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), - op_prepend_elem(OP_LINESEQ, checkop, elems)); - - /* a nextstate at the end handles context correctly for an empty - * sub body */ - checkop = op_append_elem(OP_LINESEQ, checkop, newSTATEOP(0, NULL, NULL)); - - LEAVE; - - return checkop; -} - -#endif diff --git a/inc/Module/Build/with/XSTests.pm b/inc/Module/Build/with/XSTests.pm index da57607..5fc5848 100644 --- a/inc/Module/Build/with/XSTests.pm +++ b/inc/Module/Build/with/XSTests.pm @@ -1,6 +1,6 @@ package Module::Build::with::XSTests; -use strict; +use v5.14; use warnings; use base qw( Module::Build ); diff --git a/include/parse_subsignature_ex.h b/include/parse_subsignature_ex.h new file mode 100644 index 0000000..a3e1be7 --- /dev/null +++ b/include/parse_subsignature_ex.h @@ -0,0 +1,23 @@ +/* vi: set ft=c : */ + +/* Some experimental extension flags. Not (currently) part of core perl API +*/ +enum { + PARSE_SUBSIGNATURE_NAMED_PARAMS = (1<<0), + /* Permits ( :$foo, :$bar, :$splot = "default" ) named params + * They are accumulated into a slurpy hash then extracted afterwards + * As with positional params, any param without a defaulting expression is + * required; an error is thrown if the caller did not provide it + */ + + PARSE_SUBSIGNATURE_PARAM_ATTRIBUTES = (1<<1), + /* Permits ( $param :Attribute(Value) ) attributes on params + * These must be registered by calling register_subsignature_attribute() + */ +}; + +#define parse_subsignature_ex(flags) XPS_parse_subsignature_ex(aTHX_ flags) +OP *XPS_parse_subsignature_ex(pTHX_ int flags); + +#define register_subsignature_attribute(name, funcs, funcdata) XPS_register_subsignature_attribute(aTHX_ name, funcs, funcdata) +void XPS_register_subsignature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata); diff --git a/lib/Sublike/Extended.pm b/lib/Sublike/Extended.pm new file mode 100644 index 0000000..4b8cd77 --- /dev/null +++ b/lib/Sublike/Extended.pm @@ -0,0 +1,122 @@ +# 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, 2023 -- leonerd@leonerd.org.uk + +package Sublike::Extended 0.21; + +use v5.14; +use warnings; + +require XSLoader; +XSLoader::load( __PACKAGE__, our $VERSION ); + +=head1 NAME + +C - enable extended features when parsing C-like syntax + +=head1 SYNOPSIS + + use v5.26; + use Sublike::Extended; + use experimental 'signatures'; + + extended sub greet (:$name = "world") { + say "Hello, $name"; + } + + greet( name => $ENV{USER} ); + +=head1 DESCRIPTION + +This module extends the syntax for declaring named or anonymous subroutines +using Perl's builtin C keyword, or other similar keywords provided by +third-party modules, to enable parsing of extra features. + +Currently, the only extended features that are provided are related to the +parsing of a subroutine signature. Since signatures are only available on Perl +version 5.26 or later, this module is unlikely to be useful in earlier +versions of Perl. + +=head2 Named parameters + +Extended subroutines can be declare named parameters in the signature, after +any positional ones. These take the form of a name prefixed by a colon +character. The caller of such a function should pass values for these +parameters by the usual name-value pair syntax that would be used for passing +into a regular hash. Within the body of the subroutine the values passed into +these are unpacked into regular lexical variables. + + extended sub colour (:$red, :$green, :$blue) { + ... # $red, $green and $blue are available as regular lexicals + } + + # argument order at the caller site is not important + colour(green => 1, blue => 2, red => 3); + +As with positional parameters, they are normally mandatory, but can be made +optional by supplying a defaulting expression. If the caller fails to pass a +value corresponding to the parameter, the default expression is evaluated and +used instead. + + extended sub f (:$x0, :$x1, :$x2 = 0) { ... } + # The caller must provide x0 and x1, but x2 is optional + +An optional slurpy hash is also permitted after all of these. It will contain +the values of any other name-value pairs given by the caller, after those +corresponding to named parameters have already been extracted. + + extended sub g (:$alpha, :$beta, %rest) { ... } + +=head2 Parameter Attributes + +Parameters to extended subroutines can use attribute syntax to apply extra +attributes to individual parameters. + + extended sub info ($x :Attribute) { ... } + +Any attributes that are available are ones that have been previously +registered with L using its XS-level API. The particular +behaviour of such an attribute would be defined by whatever module provided +the attribute. + +=head1 KEYWORDS + +=head2 extended + + extended sub NAME (SIGNATURE...) { BODY... } + + extended sub (SIGNATURE...) { BODY... }; + +This prefix keyword enables extra parsing features when handling a C (or +other sub-like function keyword). + +This keyword can be freely mixed with other C-prefix keywords, such as +C from L + + async extended sub f (:$param) { ... } + +This can also be used with other keywords that provide C-like syntax, +such as C from L or the core C. + + extended method f (:$param) { ... } + +=cut + +sub import +{ + $^H{"Sublike::Extended/extended"}++; +} + +sub unimport +{ + delete $^H{"Sublike::Extended/extended"}; +} + +=head1 AUTHOR + +Paul Evans + +=cut + +0x55AA; diff --git a/lib/Sublike/Extended.xs b/lib/Sublike/Extended.xs new file mode 100644 index 0000000..6e7e85d --- /dev/null +++ b/lib/Sublike/Extended.xs @@ -0,0 +1,27 @@ +/* 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, 2023 -- leonerd@leonerd.org.uk + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "XSParseSublike.h" + +static struct XSParseSublikeHooks hooks_extended = { + .permit_hintkey = "Sublike::Extended/extended", + .flags = XS_PARSE_SUBLIKE_FLAG_PREFIX| + XS_PARSE_SUBLIKE_FLAG_SIGNATURE_NAMED_PARAMS| + XS_PARSE_SUBLIKE_FLAG_SIGNATURE_PARAM_ATTRIBUTES, + + /* No hooks */ +}; + +MODULE = Sublike::Extended PACKAGE = Sublike::Extended + +BOOT: + boot_xs_parse_sublike(0); // TODO + + register_xs_parse_sublike("extended", &hooks_extended, NULL); diff --git a/lib/XS/Parse/Sublike.pm b/lib/XS/Parse/Sublike.pm index 1c8a32c..4b0c7f1 100644 --- a/lib/XS/Parse/Sublike.pm +++ b/lib/XS/Parse/Sublike.pm @@ -3,7 +3,7 @@ # # (C) Paul Evans, 2020-2021 -- leonerd@leonerd.org.uk -package XS::Parse::Sublike 0.16; +package XS::Parse::Sublike 0.21; use v5.14; use warnings; @@ -242,10 +242,16 @@ definition. The parameter signature of the function. -This part can be skipped, but the bit is ignored when in I. It -is always permitted not to provide a signature for a function definition, -because such syntax only applies when C is in -effect, and only on supporting perl versions. +This part can be skipped, but it is always permitted not to provide a +signature for a function definition even if the bit it set in +I. This is because such syntax only applies when +C is in effect, and only on supporting perl +versions. + +However, setting the bit in I instead has the effect of +enabling C (at least on supporting perl versions), +thus permitting the syntax to use a signature even if the signatures feature +was not previously enabled. =item XS_PARSE_SUBLIKE_PART_BODY diff --git a/lib/XS/Parse/Sublike.xs b/lib/XS/Parse/Sublike.xs index 075d3d9..ed82fc2 100644 --- a/lib/XS/Parse/Sublike.xs +++ b/lib/XS/Parse/Sublike.xs @@ -1,25 +1,41 @@ /* 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-2021 -- leonerd@leonerd.org.uk + * (C) Paul Evans, 2019-2023 -- leonerd@leonerd.org.uk */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* We need to be able to see FEATURE_*_IS_ENABLED */ +#define PERL_EXT +#include "feature.h" + #include "XSParseSublike.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, 26, 0) -# if !HAVE_PERL_VERSION(5, 31, 3) -# include "parse_subsignature.c.inc" -# endif +#if HAVE_PERL_VERSION(5, 37, 10) +/* feature 'class' first became available in 5.37.9 but it wasn't until + * 5.37.10 that we could pass CVf_IsMETHOD to start_subparse() + */ +# define HAVE_FEATURE_CLASS +#endif +/* We always need this included to get the struct and function definitions + * visible, even though we won't be calling it + */ +#include "parse_subsignature_ex.h" + +#if HAVE_PERL_VERSION(5, 26, 0) # include "make_argcheck_aux.c.inc" +# if !HAVE_PERL_VERSION(5, 31, 3) +# define parse_subsignature(flags) parse_subsignature_ex(0) /* ignore core flags as there are none */ +# endif + # define HAVE_PARSE_SUBSIGNATURE #endif @@ -34,6 +50,9 @@ #include "lexer-additions.c.inc" +#define QUOTED_PVNf "\"%.*s\"%s" +#define QUOTED_PVNfARG(pv,len) ((len) <= 255 ? (int)(len) : 255), (pv), ((len) <= 255 ? "" : "...") + struct HooksAndData { const struct XSParseSublikeHooks *hooks; void *data; @@ -49,6 +68,11 @@ struct HooksAndData { (hooki >= 0) && (hooks = hooksanddata[hooki].hooks, hookdata = hooksanddata[hooki].data), (hooki >= 0); \ hooki--) +/* Non-documented internal flags we use for our own purposes */ +enum { + XS_PARSE_SUBLIKE_ACTION_CVf_IsMETHOD = (1<<31), /* do we set CVf_IsMETHOD? */ +}; + static int parse(pTHX_ struct HooksAndData hooksanddata[], size_t nhooks, @@ -109,7 +133,15 @@ static int parse(pTHX_ ctx.actions |= XS_PARSE_SUBLIKE_ACTION_CVf_ANON; } - I32 floor_ix = start_subparse(FALSE, ctx.actions & XS_PARSE_SUBLIKE_ACTION_CVf_ANON ? CVf_ANON : 0); + int subparse_flags = 0; + if(ctx.actions & XS_PARSE_SUBLIKE_ACTION_CVf_ANON) + subparse_flags |= CVf_ANON; +#ifdef HAVE_FEATURE_CLASS + if(ctx.actions & XS_PARSE_SUBLIKE_ACTION_CVf_IsMETHOD) + subparse_flags |= CVf_IsMETHOD; +#endif + + I32 floor_ix = start_subparse(FALSE, subparse_flags); SAVEFREESV(PL_compcv); if(!(skip_parts & XS_PARSE_SUBLIKE_PART_ATTRS) && (lex_peek_unichar(0) == ':')) { @@ -175,6 +207,18 @@ static int parse(pTHX_ lex_read_unichar(0); lex_read_space(0); + if(require_parts & XS_PARSE_SUBLIKE_PART_SIGNATURE) { +#if HAVE_PERL_VERSION(5, 32, 0) + SAVEI32(PL_compiling.cop_features); + PL_compiling.cop_features |= FEATURE_SIGNATURES_BIT; +#else + /* So far this is only used by the "method" keyword hack for perl 5.38 + * onwards so this doesn't technically matter. Yet... + */ + croak("TODO: import_pragma(\"feature\", \"signatures\")"); +#endif + } + #if HAVE_PERL_VERSION(5, 31, 3) /* core's parse_subsignature doesn't seem able to handle empty sigs * RT132284 @@ -206,7 +250,18 @@ static int parse(pTHX_ else #endif { - sigop = parse_subsignature(0); + U32 flags = 0; + FOREACH_HOOKS_FORWARD { + if(hooks->flags & XS_PARSE_SUBLIKE_FLAG_SIGNATURE_NAMED_PARAMS) + flags |= PARSE_SUBSIGNATURE_NAMED_PARAMS; + if(hooks->flags & XS_PARSE_SUBLIKE_FLAG_SIGNATURE_PARAM_ATTRIBUTES) + flags |= PARSE_SUBSIGNATURE_PARAM_ATTRIBUTES; + } + + if(flags) + sigop = parse_subsignature_ex(flags); + else + sigop = parse_subsignature(0); if(PL_parser->error_count) { assert(PL_scopestack_ix == was_scopestack_ix); @@ -413,11 +468,14 @@ static void register_sublike(pTHX_ const char *kw, const void *hooks, void *hook reg->hooks = hooks; reg->hookdata = hookdata; - if(reg->ver >= 4 && reg->hooks->permit_hintkey) + if(reg->hooks->permit_hintkey) reg->permit_hintkey_len = strlen(reg->hooks->permit_hintkey); else reg->permit_hintkey_len = 0; + if(!reg->hooks->permit && !reg->hooks->permit_hintkey) + croak("Third-party sublike keywords require a permit callback or hinthash key"); + REGISTRATIONS_LOCK; { reg->next = registrations; @@ -476,8 +534,8 @@ static int IMPL_xs_parse_sublike_any_v4(pTHX_ const struct XSParseSublikeHooks * if(kwlen != 3 || !strEQ(kw, "sub")) { reg = find_permitted(aTHX_ kw, kwlen); if(!reg) - croak("Expected a keyword to introduce a sub or sub-like construction, found \"%.*s\"", - kwlen, kw); + croak("Expected a keyword to introduce a sub or sub-like construction, found " QUOTED_PVNf, + QUOTED_PVNfARG(kw, kwlen)); } SvREFCNT_dec(kwsv); @@ -486,7 +544,6 @@ static int IMPL_xs_parse_sublike_any_v4(pTHX_ const struct XSParseSublikeHooks * { .hooks = hooksA, .data = hookdataA }, { 0 } }; - struct XSParseSublikeHooks hooks; if(reg) { hd[1].hooks = reg->hooks; @@ -501,6 +558,42 @@ static int IMPL_xs_parse_sublike_any_v3(pTHX_ const void *hooksA, void *hookdata croak("XS::Parse::Sublike ABI v3 is no longer supported; the caller should be rebuilt to use v4"); } +static void IMPL_register_xps_signature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata) +{ + if(funcs->ver < 5) + croak("Mismatch in signature param attribute ABI version field: module wants %u; we require >= 5\n", + funcs->ver); + if(funcs->ver > XSPARSESUBLIKE_ABI_VERSION) + croak("Mismatch in signature param attribute ABI version field: module wants %u; we support <= %d\n", + funcs->ver, XSPARSESUBLIKE_ABI_VERSION); + + if(!name || !(name[0] >= 'A' && name[0] <= 'Z')) + croak("Signature param attribute names must begin with a capital letter"); + + if(!funcs->permit_hintkey) + croak("Signature param attributes require a permit hinthash key"); + + register_subsignature_attribute(name, funcs, funcdata); +} + +#ifdef HAVE_FEATURE_CLASS +static bool permit_core_method(pTHX_ void *hookdata) +{ + return FEATURE_CLASS_IS_ENABLED; +} + +static void pre_subparse_core_method(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) +{ + ctx->actions |= XS_PARSE_SUBLIKE_ACTION_CVf_IsMETHOD; +} + +static const struct XSParseSublikeHooks hooks_core_method = { + .permit = &permit_core_method, + .pre_subparse = &pre_subparse_core_method, + .require_parts = XS_PARSE_SUBLIKE_PART_SIGNATURE, /* enable signatures feature */ +}; +#endif + static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); static int my_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op_ptr) @@ -543,8 +636,8 @@ static int my_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op_ptr) reg = find_permitted(aTHX_ kw, kwlen); if(!reg) - croak("Expected a keyword to introduce a sub or sub-like construction, found \"%.*s\"", - kwlen, kw); + croak("Expected a keyword to introduce a sub or sub-like construction, found " QUOTED_PVNf, + QUOTED_PVNfARG(kw, kwlen)); hooks = (struct XSParseSublikeHooks *)reg->hooks; @@ -572,8 +665,14 @@ BOOT: /* Newer mechanism */ sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/ABIVERSION_MIN", 1), 4); sv_setiv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/ABIVERSION_MAX", 1), XSPARSESUBLIKE_ABI_VERSION); + sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parse()@4", 1), PTR2UV(&IMPL_xs_parse_sublike_v4)); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/register()@4", 1), PTR2UV(&IMPL_register_xs_parse_sublike_v4)); sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/parseany()@4", 1), PTR2UV(&IMPL_xs_parse_sublike_any_v4)); + sv_setuv(*hv_fetchs(PL_modglobal, "XS::Parse::Sublike/register_sigattr()@5", 1), PTR2UV(&IMPL_register_xps_signature_attribute)); +#ifdef HAVE_FEATURE_CLASS + register_sublike(aTHX_ "method", &hooks_core_method, NULL, 4); +#endif + wrap_keyword_plugin(&my_keyword_plugin, &next_keyword_plugin); diff --git a/lib/XS/Parse/Sublike/Builder.pm b/lib/XS/Parse/Sublike/Builder.pm index b0e7036..078a034 100644 --- a/lib/XS/Parse/Sublike/Builder.pm +++ b/lib/XS/Parse/Sublike/Builder.pm @@ -3,7 +3,7 @@ # # (C) Paul Evans, 2020-2021 -- leonerd@leonerd.org.uk -package XS::Parse::Sublike::Builder 0.16; +package XS::Parse::Sublike::Builder 0.21; use v5.14; use warnings; @@ -46,7 +46,7 @@ require XS::Parse::Sublike::Builder_data; =head2 write_XSParseSublike_h - XS::Parse::Sublike::Builder->write_XSParseSublike_h + XS::Parse::Sublike::Builder->write_XSParseSublike_h; Writes the F file to the current working directory. To cause the compiler to actually find this file, see L. @@ -65,7 +65,7 @@ sub write_XSParseSublike_h =head2 extra_compiler_flags - @flags = XS::Parse::Sublike::Builder->extra_compiler_flags + @flags = XS::Parse::Sublike::Builder->extra_compiler_flags; Returns a list of extra flags that the build scripts should add to the compiler invocation. This enables the C compiler to find the @@ -81,7 +81,7 @@ sub extra_compiler_flags =head2 extend_module_build - XS::Parse::Sublike::Builder->extend_module_build( $build ) + XS::Parse::Sublike::Builder->extend_module_build( $build ); A convenient shortcut for performing all the tasks necessary to make a L-based distribution use the helper. diff --git a/lib/XS/Parse/Sublike/Builder_data.pm.PL b/lib/XS/Parse/Sublike/Builder_data.pm.PL index 042164e..07c4804 100644 --- a/lib/XS/Parse/Sublike/Builder_data.pm.PL +++ b/lib/XS/Parse/Sublike/Builder_data.pm.PL @@ -22,7 +22,7 @@ $outh->print( scalar do { <$in_h> } ); __DATA__ -package XS::Parse::Sublike::Builder_data 0.16; +package XS::Parse::Sublike::Builder_data 0.21; use v5.14; use warnings; diff --git a/src/parse_subsignature_ex.c b/src/parse_subsignature_ex.c new file mode 100644 index 0000000..1e6dc10 --- /dev/null +++ b/src/parse_subsignature_ex.c @@ -0,0 +1,617 @@ +/* vi: set ft=c : */ + +#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)))))) + +#include "XSParseSublike.h" + +/* Skip this entire file on perls older than OP_ARGCHECK */ +#if HAVE_PERL_VERSION(5, 26, 0) + +#define PERL_EXT +/* We need to be able to see FEATURE_*_IS_ENABLED */ +#include "feature.h" +/* Also need KEY_sigvar */ +#include "keywords.h" + +#include "parse_subsignature_ex.h" + +#include "lexer-additions.c.inc" + +#include "LOGOP_ANY.c.inc" +#include "croak_from_caller.c.inc" +#include "make_argcheck_aux.c.inc" +#include "newSV_with_free.c.inc" + +#define newSVpvx(ptr) S_newSVpvx(aTHX_ ptr) +static SV *S_newSVpvx(pTHX_ void *ptr) +{ + SV *sv = newSV(0); + sv_upgrade(sv, SVt_PV); + SvPVX(sv) = ptr; + return sv; +} + +/* + * 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 */ +#ifndef OpTYPE_set +# define OpTYPE_set(op, type) \ + STMT_START { \ + op->op_type = (OPCODE)type; \ + op->op_ppaddr = PL_ppaddr[type]; \ + } STMT_END +#endif + +#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; +} + +/* copypaste from core's pp.c */ +static SV * +S_find_runcv_name(pTHX) +{ + CV *cv; + GV *gv; + SV *sv; + + cv = find_runcv(0); + if (!cv) + return &PL_sv_no; + + gv = CvGV(cv); + if (!gv) + return &PL_sv_no; + + sv = sv_newmortal(); + gv_fullname4(sv, gv, NULL, TRUE); + return sv; +} + +static OP *pp_namedargdefelem(pTHX) +{ + dSP; + ANY *op_any = cLOGOP_ANY->op_any; + SV *keysv = op_any[0].any_sv; + HV *slurpy_hv = (HV *)PAD_SVl(op_any[1].any_iv); + + assert(slurpy_hv && SvTYPE(slurpy_hv) == SVt_PVHV); + + /* TODO: we could precompute the hash and store it in the ANY vector */ + SV *value = hv_delete_ent(slurpy_hv, keysv, 0, 0); + + if(value) { + EXTEND(SP, 1); + PUSHs(value); + RETURN; + } + + if(cLOGOP->op_other) + return cLOGOP->op_other; + + croak_from_caller("Missing argument '%" SVf "' for subroutine %" SVf, + SVfARG(keysv), SVfARG(S_find_runcv_name(aTHX))); +} + +static OP *pp_checknomorenamed(pTHX) +{ + HV *slurpy_hv = (HV *)PAD_SVl(PL_op->op_targ); + + if(!hv_iterinit(slurpy_hv)) + return NORMAL; + + /* There are remaining named arguments; concat their names into a message */ + + HE *he = hv_iternext(slurpy_hv); + + SV *keynames = newSVpvn("", 0); + SAVEFREESV(keynames); + + sv_catpvf(keynames, "'%" SVf "'", SVfARG(HeSVKEY_force(he))); + + IV nkeys = 1; + + while((he = hv_iternext(slurpy_hv))) + sv_catpvf(keynames, ", '%" SVf "'", SVfARG(HeSVKEY_force(he))), nkeys++; + + croak_from_caller("Unrecognised %s %" SVf " for subroutine %" SVf, + nkeys > 1 ? "arguments" : "argument", + SVfARG(keynames), SVfARG(S_find_runcv_name(aTHX))); +} + +#define OP_IS_NAMED_PARAM(o) (o->op_type == OP_ARGELEM && cUNOPx(o)->op_first && \ + cUNOPx(o)->op_first->op_type == OP_CUSTOM && \ + cUNOPx(o)->op_first->op_ppaddr == &pp_namedargdefelem) + +/* Parameter attribute extensions */ +typedef struct SignatureAttributeRegistration SignatureAttributeRegistration; + +struct SignatureAttributeRegistration { + SignatureAttributeRegistration *next; + + const char *name; + STRLEN permit_hintkeylen; + + const struct XPSSignatureAttributeFuncs *funcs; + void *funcdata; +}; + +static SignatureAttributeRegistration *sigattrs = NULL; + +#define find_registered_attribute(name) S_find_registered_attribute(aTHX_ name) +static SignatureAttributeRegistration *S_find_registered_attribute(pTHX_ const char *name) +{ + HV *hints = GvHV(PL_hintgv); + + SignatureAttributeRegistration *reg; + for(reg = sigattrs; reg; reg = reg->next) { + if(!strEQ(name, reg->name)) + continue; + + if(reg->funcs->permit_hintkey && + (!hints || !hv_fetch(hints, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0))) + continue; + + return reg; + } + + croak("Unrecognised signature parameter attribute :%s", name); +} + +struct PendingSignatureFunc { + const struct XPSSignatureAttributeFuncs *funcs; + void *funcdata; + void *attrdata; +}; + +#define PENDING_FROM_SV(sv) ((struct PendingSignatureFunc *)SvPVX(sv)) + +static void pending_free(pTHX_ SV *sv) +{ + struct PendingSignatureFunc *p = PENDING_FROM_SV(sv); + + if(p->funcs->free) + (*p->funcs->free)(aTHX_ p->attrdata, p->funcdata); +} + +#define NEW_SV_PENDING() newSV_with_free(sizeof(struct PendingSignatureFunc), &pending_free) + +struct SignatureParsingContext { + AV *named_varops; /* SV ptrs to the varop of every named parameter */ + + OP *last_varop; /* the most recently-constructed varop */ +}; + +static void free_parsing_ctx(pTHX_ void *_ctx) +{ + struct SignatureParsingContext *ctx = _ctx; + if(ctx->named_varops) + SvREFCNT_dec((SV *)ctx->named_varops); +} + +#define parse_sigelem(ctx, flags) S_parse_sigelem(aTHX_ ctx, flags) +static OP *S_parse_sigelem(pTHX_ struct SignatureParsingContext *ctx, U32 flags) +{ + bool permit_attributes = flags & PARSE_SUBSIGNATURE_PARAM_ATTRIBUTES; + + yy_parser *parser = PL_parser; + + int c = lex_peek_unichar(0); + int private; + struct XPSSignatureParamContext paramctx = {}; + + AV *pending = NULL; + + if((flags & PARSE_SUBSIGNATURE_NAMED_PARAMS) && c == ':') { + lex_read_unichar(0); + lex_read_space(0); + + paramctx.is_named = true; + c = lex_peek_unichar(0); + } + + switch(c) { + case '$': private = OPpARGELEM_SV; break; + case '@': private = OPpARGELEM_AV; break; + case '%': private = OPpARGELEM_HV; break; + default: + croak("Expected a signature element at <%s>\n", parser->bufptr); + } + + char *lexname = parser->bufptr; + + /* Consume sigil */ + lex_read_unichar(0); + + char *lexname_end = NULL; + + if(isIDFIRST_uni(lex_peek_unichar(0))) { + lex_read_unichar(0); + while(isALNUM_uni(lex_peek_unichar(0))) + lex_read_unichar(0); + + paramctx.varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (parser->sig_elems))); + paramctx.varop->op_private |= private; + + if(paramctx.is_named) { + if(!ctx->named_varops) + ctx->named_varops = newAV(); + + av_push(ctx->named_varops, newSVpvx(paramctx.varop)); + } + + ctx->last_varop = paramctx.varop; + + ENTER; + SAVEI16(PL_parser->in_my); + PL_parser->in_my = KEY_sigvar; + + lexname_end = PL_parser->bufptr; + paramctx.padix = paramctx.varop->op_targ = + pad_add_name_pvn(lexname, lexname_end - lexname, 0, NULL, NULL); + + LEAVE; + + lex_read_space(0); + } + + if(permit_attributes && lex_peek_unichar(0) == ':') { + lex_read_unichar(0); + lex_read_space(0); + + SV *attrname = sv_newmortal(), *attrval = sv_newmortal(); + + while(lex_scan_attrval_into(attrname, attrval)) { + lex_read_space(0); + + SignatureAttributeRegistration *reg = find_registered_attribute(SvPV_nolen(attrname)); + + void *attrdata = NULL; + if(reg->funcs->apply) + (*reg->funcs->apply)(aTHX_ ¶mctx, attrval, &attrdata, reg->funcdata); + + if(attrdata || reg->funcs->post_defop) { + if(!pending) { + pending = newAV(); + SAVEFREESV(pending); + } + + SV *psv; + av_push(pending, psv = NEW_SV_PENDING()); + + PENDING_FROM_SV(psv)->funcs = reg->funcs; + PENDING_FROM_SV(psv)->funcdata = reg->funcdata; + PENDING_FROM_SV(psv)->attrdata = attrdata; + } + + if(lex_peek_unichar(0) == ':') { + lex_read_unichar(0); + lex_read_space(0); + } + } + } + + if(c == '$') { + SV *argname = NULL; + + if(paramctx.is_named) { + parser->sig_slurpy = '+'; + argname = newSVpvn(lexname + 1, lexname_end - lexname - 1); + } + else { + 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); + + if(!paramctx.is_named) + parser->sig_optelems++; + + OP *defexpr = parse_termexpr(0); + + if(paramctx.is_named) { + paramctx.defop = (OP *)alloc_LOGOP_ANY(OP_CUSTOM, defexpr, LINKLIST(defexpr)); + paramctx.defop->op_ppaddr = &pp_namedargdefelem; + } + else { + paramctx.defop = (OP *)alloc_LOGOP(OP_ARGDEFELEM, defexpr, LINKLIST(defexpr)); + paramctx.defop->op_targ = (PADOFFSET)(parser->sig_elems - 1); + } + + paramctx.varop->op_flags |= OPf_STACKED; + op_sibling_splice(paramctx.varop, NULL, 0, paramctx.defop); + paramctx.defop = op_contextualize(paramctx.defop, G_SCALAR); + + LINKLIST(paramctx.varop); + + paramctx.varop->op_next = paramctx.defop; + defexpr->op_next = paramctx.varop; + } + else { + if(parser->sig_optelems) + yyerror("Mandatory parameter follows optional parameter"); + } + + if(paramctx.is_named) { + OP *defop = paramctx.defop; + if(!defop) { + defop = (OP *)alloc_LOGOP_ANY(OP_CUSTOM, NULL, NULL); + defop->op_ppaddr = &pp_namedargdefelem; + + paramctx.varop->op_flags |= OPf_STACKED; + op_sibling_splice(paramctx.varop, NULL, 0, defop); + + LINKLIST(paramctx.varop); + + paramctx.varop->op_next = defop; + } + + ANY *op_any; + Newx(op_any, 2, ANY); + + op_any[0].any_sv = argname; + /* [1] is filled in later */ + + cLOGOP_ANYx(defop)->op_any = op_any; + } + } + else { + if(paramctx.is_named) + yyerror("Slurpy parameters may not be named"); + if(parser->sig_slurpy && 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"); + } + + paramctx.op = paramctx.varop; + + if(pending) { + for(int i = 0; i <= AvFILL(pending); i++) { + struct PendingSignatureFunc *p = PENDING_FROM_SV(AvARRAY(pending)[i]); + + if(p->funcs->post_defop) + (*p->funcs->post_defop)(aTHX_ ¶mctx, p->attrdata, p->funcdata); + } + } + + return paramctx.op ? newSTATEOP(0, NULL, paramctx.op) : NULL; +} + +OP *XPS_parse_subsignature_ex(pTHX_ int flags) +{ + /* Mostly reconstructed logic from perl 5.28.0's toke.c and perly.y + */ + yy_parser *parser = PL_parser; + struct SignatureParsingContext ctx = {}; + + assert((flags & ~(PARSE_SUBSIGNATURE_NAMED_PARAMS|PARSE_SUBSIGNATURE_PARAM_ATTRIBUTES)) == 0); + + ENTER; + SAVEDESTRUCTOR_X(&free_parsing_ctx, &ctx); + + 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; + OP *namedelems = NULL; + OP *final_elem = NULL; + + while(lex_peek_unichar(0) != ')') { + lex_read_space(0); + OP *elem = parse_sigelem(&ctx, flags); + + /* placeholder anonymous elems are NULL */ + if(elem) { + /* elem should be an OP_LINESEQ[ OP_NEXTSTATE. actual elem ] */ + assert(elem->op_type == OP_LINESEQ); + assert(cLISTOPx(elem)->op_first); + assert(OpSIBLING(cLISTOPx(elem)->op_first)); + + final_elem = OpSIBLING(cLISTOPx(elem)->op_first); + + if(OP_IS_NAMED_PARAM(ctx.last_varop)) + namedelems = op_append_list(OP_LIST, namedelems, elem); + else + 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 (!FEATURE_SIGNATURES_IS_ENABLED) + croak("Experimental subroutine signatures not enabled"); + +#if !HAVE_PERL_VERSION(5, 37, 0) + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SIGNATURES), + "The signatures feature is experimental"); +#endif + + bool allow_extras_after_named = true; + if(ctx.named_varops) { + switch(PL_parser->sig_slurpy) { + case 0: + case '@': + NOT_REACHED; + case '+': + { + /* Pretend we have a new, unnamed slurpy hash */ + OP *varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (parser->sig_elems))); + varop->op_private |= OPpARGELEM_HV; + varop->op_targ = pad_add_name_pvs("%(params)", 0, NULL, NULL); + + final_elem = varop; + + OP *elem = newSTATEOP(0, NULL, varop); + elems = op_append_list(OP_LINESEQ, elems, elem); + + PL_parser->sig_slurpy = '%'; + allow_extras_after_named = false; + } + break; + case '%': + break; + } + } + + UNOP_AUX_item *aux = make_argcheck_aux( + parser->sig_elems, parser->sig_optelems, parser->sig_slurpy); + + OP *checkop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux); + + OP *ops = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), + op_prepend_elem(OP_LINESEQ, checkop, elems)); + + if(ctx.named_varops) { + assert(final_elem->op_type == OP_ARGELEM); + assert(final_elem->op_private == OPpARGELEM_HV); + + PADOFFSET slurpy_padix = final_elem->op_targ; + + /* Tell all the pp_namedargdefelem()s where to find the slurpy hash */ + for(int i = 0; i <= AvFILL(ctx.named_varops); i++) { + OP *elemop = (OP *)(SvPVX(AvARRAY(ctx.named_varops)[i])); + assert(elemop); + assert(OP_IS_NAMED_PARAM(elemop)); + + OP *defelemop = cUNOPx(elemop)->op_first; + assert(defelemop); + assert(defelemop->op_type == OP_CUSTOM && + defelemop->op_ppaddr == &pp_namedargdefelem); + ANY *op_any = cLOGOP_ANYx(defelemop)->op_any; + op_any[1].any_iv = slurpy_padix; + } + + ops = op_append_list(OP_LINESEQ, ops, + namedelems); + + if(!allow_extras_after_named) { + ops = op_append_list(OP_LINESEQ, ops, + newSTATEOP(0, NULL, checkop = newOP(OP_CUSTOM, 0))); + checkop->op_ppaddr = &pp_checknomorenamed; + checkop->op_targ = slurpy_padix; + } + } + + /* a nextstate at the end handles context correctly for an empty + * sub body */ + ops = op_append_elem(OP_LINESEQ, ops, newSTATEOP(0, NULL, NULL)); + + LEAVE; + + return ops; +} + +void XPS_register_subsignature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata) +{ + SignatureAttributeRegistration *reg; + Newx(reg, 1, struct SignatureAttributeRegistration); + + *reg = (struct SignatureAttributeRegistration){ + .name = name, + .funcs = funcs, + .funcdata = funcdata, + }; + + if(funcs->permit_hintkey) + reg->permit_hintkeylen = strlen(funcs->permit_hintkey); + + reg->next = sigattrs; + sigattrs = reg; +} + +#else /* !HAVE_PERL_VERSION(5, 26, 0) */ + +void XPS_register_subsignature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata) +{ + croak("Custom subroutine signature attributes are not supported on this verison of Perl"); +} + +#endif diff --git a/t/00use.t b/t/00use.t index 6d9b5e9..af3220e 100644 --- a/t/00use.t +++ b/t/00use.t @@ -3,8 +3,9 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; -use_ok( "XS::Parse::Sublike" ); +require XS::Parse::Sublike; +pass( "Modules loaded" ); done_testing; diff --git a/t/01func.t b/t/01func.t index 2699683..a9fba47 100644 --- a/t/01func.t +++ b/t/01func.t @@ -3,11 +3,13 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::func"; +BEGIN { $^H{"t::func/func"}++ } + # named func { func example { return 123; } @@ -30,7 +32,7 @@ use testcase "t::func"; { my ( $pkg, $sub, $attr ) = @_; $modify_invoked++; - Test::More::is( $attr, "MyCustomAttribute(value here)", + ::is( $attr, "MyCustomAttribute(value here)", 'MODIFY_CODE_ATTRIBUTES takes attribute' ); return (); diff --git a/t/02func-signatures.t b/t/02func-signatures.t index 17fa70f..1ef1ffd 100644 --- a/t/02func-signatures.t +++ b/t/02func-signatures.t @@ -3,11 +3,10 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } -use Test::Fatal; use feature 'signatures'; no warnings 'experimental'; @@ -15,6 +14,8 @@ no warnings 'experimental'; use lib "t"; use testcase "t::func"; +BEGIN { $^H{"t::func/func"}++ } + # basic sig { func withparam($x) { return $x + 1 } @@ -56,7 +57,7 @@ use testcase "t::func"; func noparams() { return "constant" } is( noparams, "constant", 'func with no params' ); - like( exception { noparams( 1, 2, 3 ) }, + like( dies { noparams( 1, 2, 3 ) }, # message was extended somewhere in perl 5.33 qr/^Too many arguments for subroutine 'main::noparams' (\(.*\) )?at /, 'Exception thrown from empty signature validation failure' ); diff --git a/t/03func-deparse.t b/t/03func-deparse.t index 58a9318..3d6821c 100644 --- a/t/03func-deparse.t +++ b/t/03func-deparse.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } @@ -14,6 +14,8 @@ no warnings 'experimental'; use lib "t"; use testcase "t::func"; +BEGIN { $^H{"t::func/func"}++ } + use B::Deparse; my $deparser = B::Deparse->new(); diff --git a/t/04func-named-params.t b/t/04func-named-params.t new file mode 100644 index 0000000..1d066cb --- /dev/null +++ b/t/04func-named-params.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test2::V0; +BEGIN { + $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; +} + +use feature 'signatures'; +no warnings 'experimental'; + +use lib "t"; +use testcase "t::func"; + +BEGIN { $^H{"t::func/nfunc"}++ } + +# a signature with experimental named parameter support +{ + my %was_rest; + nfunc withx(:$x, %rest) { %was_rest = %rest; return $x } + + is( withx( x => 123 ), 123, 'named param extracts value' ); + is( \%was_rest, {}, 'named param not visible in %rest' ); + + withx( x => 1, y => 2 ); + is( \%was_rest, { y => 2 }, 'other params still visible in %rest' ); + + my $LINE = __LINE__+1; + like( dies { withx() }, + qr/^Missing argument 'x' for subroutine main::withx at \S+ line $LINE\./, + 'complaint from missing named param' ); + + nfunc with2x(:$x1, :$x2) { return "x1=$x1 x2=$x2"; } + is( with2x( x1 => 10, x2 => 20 ), "x1=10 x2=20", + 'supports multiple named params' ); +} + +# named params can still have defaults +{ + nfunc withy(:$y = "Y", %rest) { return $y } + + is( withy( y => 456 ), 456, 'named param with default' ); + is( withy(), "Y", 'named param applies default' ); +} + +# named params still work without a slurpy +{ + nfunc withz(:$z) { return $z } + + is( withz( z => 789 ), 789, 'named param without slurpy' ); + + my $LINE = __LINE__+1; + like( dies { withz( z => 1, w => 1 ); 1 }, + qr/^Unrecognised argument 'w' for subroutine main::withz at \S+ line $LINE\./, + 'complaint from unknown param' ); +} + +# mixed positional+named +{ + nfunc withboth($x, :$y = "def") { return "x=$x y=$y"; } + + is( withboth(1, y => 2), "x=1 y=2", + 'supports mixed positional + named' ); + is( withboth(1), "x=1 y=def", + 'mixed still applies defaults' ); +} + +# diagnostics on duplicates +{ + sub warnings_from ( $code ) { + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + eval( "$code; 1" ) or die $@; + return $warnings; + } + + like( warnings_from( 'nfunc diag1($x, :$x) { }' ), + qr/^"my" variable \$x masks earlier declaration in same scope at /, + 'warning from duplicated parameter name' ); +} + +done_testing; diff --git a/t/05func-sig-attributes.t b/t/05func-sig-attributes.t new file mode 100644 index 0000000..ad16f7a --- /dev/null +++ b/t/05func-sig-attributes.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test2::V0; +BEGIN { + $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; +} + +use feature 'signatures'; +no warnings 'experimental'; + +use lib "t"; +use testcase "t::func"; + +BEGIN { $^H{"t::func/afunc"}++ } +BEGIN { $^H{"t::func/Attribute"}++ } + +our @ATTRIBUTE_APPLIED; + +{ + afunc withattr($x :Attribute, $y :Attribute(Value)) { } + + is( \@ATTRIBUTE_APPLIED, + [ '$x' => undef, '$y' => "Value" ], + ':Attribute applied to subroutine parameters' ); +} + +done_testing; diff --git a/t/10stages-permit.t b/t/10stages-permit.t index 240098d..1fc8f88 100644 --- a/t/10stages-permit.t +++ b/t/10stages-permit.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::stages"; @@ -14,7 +14,7 @@ sub stages { return $_[0] } { my $ret = stages { one => "one" }; - is_deeply( $ret, { one => "one" }, + is( $ret, { one => "one" }, 'not permitted keyword falls through to regular symbol lookup' ); } diff --git a/t/11stages-pre_subparse.t b/t/11stages-pre_subparse.t index fe1a507..d5abe0d 100644 --- a/t/11stages-pre_subparse.t +++ b/t/11stages-pre_subparse.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::stages"; diff --git a/t/12stages-post_blockstart.t b/t/12stages-post_blockstart.t index aff4653..046cdb5 100644 --- a/t/12stages-post_blockstart.t +++ b/t/12stages-post_blockstart.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::stages"; diff --git a/t/13stages-pre_blockend.t b/t/13stages-pre_blockend.t index d8bef1e..ba6b362 100644 --- a/t/13stages-pre_blockend.t +++ b/t/13stages-pre_blockend.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::stages"; diff --git a/t/14stages-post_newcv.t b/t/14stages-post_newcv.t index 8b9253c..f3367a7 100644 --- a/t/14stages-post_newcv.t +++ b/t/14stages-post_newcv.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::stages"; diff --git a/t/15stages-filter_attr.t b/t/15stages-filter_attr.t index 3de3c20..4b84b74 100644 --- a/t/15stages-filter_attr.t +++ b/t/15stages-filter_attr.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::stages"; @@ -16,7 +16,7 @@ BEGIN { $^H{"t::stages/permit"} = 1; } stages withattr :atname(atvalue) { } - is_deeply( $t::stages::captured, [ atname => "atvalue" ], + is( $t::stages::captured, [ atname => "atvalue" ], 'captured an attribute by attr filter' ); } diff --git a/t/20registrations.t b/t/20registrations.t index 5bd0bd9..417fcfe 100644 --- a/t/20registrations.t +++ b/t/20registrations.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::registrations"; diff --git a/t/30any.t b/t/30any.t index aee03d7..98d4b89 100644 --- a/t/30any.t +++ b/t/30any.t @@ -3,11 +3,13 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::any"; +BEGIN { $^H{"t::any/func"}++ } + our $LOG; BEGIN { $LOG = "" }; prefixed func example { diff --git a/t/31prefix.t b/t/31prefix.t index c595785..6326b51 100644 --- a/t/31prefix.t +++ b/t/31prefix.t @@ -3,11 +3,16 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::prefix"; +BEGIN { + $^H{"t::prefix/func"}++; + $^H{"t::prefix/prefixed"}++; +} + our $LOG; BEGIN { $LOG = "" }; prefixed func example { diff --git a/t/40parts-name.t b/t/40parts-name.t index e195355..b9a1953 100644 --- a/t/40parts-name.t +++ b/t/40parts-name.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::parts"; diff --git a/t/41parts-attrs.t b/t/41parts-attrs.t index 095d2f5..d7b9979 100644 --- a/t/41parts-attrs.t +++ b/t/41parts-attrs.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::parts"; diff --git a/t/42parts-signature.t b/t/42parts-signature.t index 8a995c0..17398d4 100644 --- a/t/42parts-signature.t +++ b/t/42parts-signature.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } diff --git a/t/50flags-no-body.t b/t/50flags-no-body.t index ea4b070..3fc3da6 100644 --- a/t/50flags-no-body.t +++ b/t/50flags-no-body.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use lib "t"; use testcase "t::flags"; diff --git a/t/60actions.t b/t/60actions.t index 536cc01..b8b5212 100644 --- a/t/60actions.t +++ b/t/60actions.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; use Sub::Util 'subname'; use lib "t"; diff --git a/t/70extended.t b/t/70extended.t new file mode 100644 index 0000000..6164f97 --- /dev/null +++ b/t/70extended.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test2::V0; +BEGIN { + $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; +} + +use feature 'signatures'; +no warnings 'experimental'; + +use Sublike::Extended; + +# basic sub +{ + extended sub t1 { return "named" } + my $t2 = extended sub { return "anon" }; + + is( t1(), "named", + 'extended sub can make basic named' ); + is( $t2->(), "anon", + 'extended sub can make basic anon' ); +} + +# sub with named params +{ + extended sub t3 (:$x, :$y) { return "x=$x y=$y"; } + my $t4 = extended sub ( :$i, :$j ) { return "i=$i j=$j"; }; + + is( t3( x => 10, y => 20 ), "x=10 y=20", + 'extended sub can make named param subs' ); + is( $t4->( j => 40, i => 30 ), "i=30 j=40", + 'extended sub can make named param anon subs' ); +} + +use lib "t"; +use testcase "t::func"; + +BEGIN { $^H{"t::func/Attribute"}++ } + +our @ATTRIBUTE_APPLIED; + +{ + extended sub t5 ($x :Attribute, $y :Attribute(Value)) { } + + # No need to call it just to see these + + is( \@ATTRIBUTE_APPLIED, + [ '$x' => undef, '$y' => "Value" ], + ':Attribute applied to subroutine parameters' ); +} + +done_testing; diff --git a/t/80extended+Object-Pad.t b/t/80extended+Object-Pad.t new file mode 100644 index 0000000..61472fd --- /dev/null +++ b/t/80extended+Object-Pad.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test2::V0; +BEGIN { + $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; + + eval { require Object::Pad; + Object::Pad->VERSION( '0.800' ); + 1; } or + plan skip_all => "No Object::Pad"; + + Object::Pad->import; +} + +use Sublike::Extended; + +# extended method +{ + class C1 { + extended method f (:$x, :$y) { return "x=$x y=$y" } + } + + is( C1->new->f( x => "first", y => "second" ), "x=first y=second", + 'async method' ); +} + +done_testing; diff --git a/t/80extended+async.t b/t/80extended+async.t new file mode 100644 index 0000000..a868541 --- /dev/null +++ b/t/80extended+async.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test2::V0; +BEGIN { + $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; + + eval { require Future::AsyncAwait; + Future::AsyncAwait->VERSION( '0.66' ); + 1; } or + plan skip_all => "No Future::AsyncAwait"; + + Future::AsyncAwait->import; +} + +use feature 'signatures'; +no warnings 'experimental'; + +use Sublike::Extended; + +# async extended sub +{ + async extended sub f (:$x, :$y) { return "x=$x y=$y" } + + is( await f( x => "first", y => "second" ), "x=first y=second", + 'async extended sub' ); +} + +done_testing; diff --git a/t/80extended+feature-class.t b/t/80extended+feature-class.t new file mode 100644 index 0000000..9c49408 --- /dev/null +++ b/t/80extended+feature-class.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use v5.14; +use warnings; + +use Test2::V0; +BEGIN { + $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; + + # version 5.37.10 added the ability to start_subparse() with CVf_IsMETHOD, + # which we need + plan skip_all => "feature 'class' is not available" + unless $^V ge v5.37.10; +} + +use Sublike::Extended; + +use feature 'class'; +no warnings 'experimental::class'; + +# extended method +{ + class C1 { + extended method f (:$x, :$y) { return "x=$x y=$y" } + } + + is( C1->new->f( x => "first", y => "second" ), "x=first y=second", + 'async method' ); +} + +done_testing; diff --git a/t/99pod.t b/t/99pod.t index d1972ce..c70eec2 100644 --- a/t/99pod.t +++ b/t/99pod.t @@ -3,7 +3,7 @@ use v5.14; use warnings; -use Test::More; +use Test2::V0; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; diff --git a/t/any.xs b/t/any.xs index 485c06c..4ec9064 100644 --- a/t/any.xs +++ b/t/any.xs @@ -1,7 +1,7 @@ /* 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 + * (C) Paul Evans, 2020-2023 -- leonerd@leonerd.org.uk */ #include "EXTERN.h" @@ -39,6 +39,7 @@ static void func_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_logs } static const struct XSParseSublikeHooks parse_func_hooks = { + .permit_hintkey = "t::any/func", .pre_subparse = func_pre_subparse, .post_blockstart = func_post_blockstart, .pre_blockend = func_pre_blockend, diff --git a/t/func.xs b/t/func.xs index 4168572..6daf191 100644 --- a/t/func.xs +++ b/t/func.xs @@ -1,7 +1,7 @@ /* 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 + * (C) Paul Evans, 2020-2023 -- leonerd@leonerd.org.uk */ #include "EXTERN.h" @@ -10,13 +10,52 @@ #include "XSParseSublike.h" +#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 26) +# define HAVE_SUB_PARAM_ATTRIBUTES +#endif + static const struct XSParseSublikeHooks parse_func_hooks = { - /* empty */ + .permit_hintkey = "t::func/func", }; +static const struct XSParseSublikeHooks parse_nfunc_hooks = { + .permit_hintkey = "t::func/nfunc", + .flags = XS_PARSE_SUBLIKE_FLAG_SIGNATURE_NAMED_PARAMS, +}; + +static const struct XSParseSublikeHooks parse_afunc_hooks = { + .permit_hintkey = "t::func/afunc", + .flags = XS_PARSE_SUBLIKE_FLAG_SIGNATURE_PARAM_ATTRIBUTES, +}; + +#ifdef HAVE_SUB_PARAM_ATTRIBUTES +static void apply_Attribute(pTHX_ struct XPSSignatureParamContext *ctx, SV *attrvalue, void **attrdata_ptr, void *funcdata) +{ + /* TODO: maybe the context should store a lexname string? */ + PADNAME *pn = PadnamelistARRAY(PL_comppad_name)[ctx->padix]; + + AV *av = get_av("main::ATTRIBUTE_APPLIED", GV_ADD); + + av_push(av, newSVsv(PadnameSV(pn))); + av_push(av, newSVsv(attrvalue)); +} + +static const struct XPSSignatureAttributeFuncs attr_funcs = { + .ver = XSPARSESUBLIKE_ABI_VERSION, + .permit_hintkey = "t::func/Attribute", + + .apply = apply_Attribute, +}; +#endif + MODULE = t::func PACKAGE = t::func BOOT: boot_xs_parse_sublike(0); register_xs_parse_sublike("func", &parse_func_hooks, NULL); + register_xs_parse_sublike("nfunc", &parse_nfunc_hooks, NULL); + register_xs_parse_sublike("afunc", &parse_afunc_hooks, NULL); +#ifdef HAVE_SUB_PARAM_ATTRIBUTES + register_xps_signature_attribute("Attribute", &attr_funcs, NULL); +#endif diff --git a/t/prefix.xs b/t/prefix.xs index 1b44599..a57ca4d 100644 --- a/t/prefix.xs +++ b/t/prefix.xs @@ -35,6 +35,7 @@ static void func_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_logs } static const struct XSParseSublikeHooks parse_func_hooks = { + .permit_hintkey = "t::prefix/func", .pre_subparse = func_pre_subparse, .post_blockstart = func_post_blockstart, .pre_blockend = func_pre_blockend, @@ -67,6 +68,7 @@ static void prefixed_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *_ static const struct XSParseSublikeHooks parse_prefixed_hooks = { .flags = XS_PARSE_SUBLIKE_FLAG_PREFIX, + .permit_hintkey = "t::prefix/prefixed", .pre_subparse = prefixed_pre_subparse, .post_blockstart = prefixed_post_blockstart, diff --git a/t/testcase.pm b/t/testcase.pm index dff8351..8d92d1c 100644 --- a/t/testcase.pm +++ b/t/testcase.pm @@ -1,6 +1,6 @@ package testcase; -use strict; +use v5.14; use warnings; use lib "t/blib", "t/blib/arch";