New upstream version 0.21
This commit is contained in:
zhouganqing
parent
50b956e507
commit
30ed21a535
|
|
@ -0,0 +1,4 @@
|
|||
root = true
|
||||
|
||||
[*.{pm,pl,t}]
|
||||
indent_size = 3
|
||||
20
Build.PL
20
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;
|
||||
|
|
|
|||
42
Changes
42
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
|
||||
|
|
|
|||
18
LICENSE
18
LICENSE
|
|
@ -1,4 +1,4 @@
|
|||
This software is copyright (c) 2021 by Paul Evans <leonerd@leonerd.org.uk>.
|
||||
This software is copyright (c) 2023 by Paul Evans <leonerd@leonerd.org.uk>.
|
||||
|
||||
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 <leonerd@leonerd.org.uk>.
|
||||
This software is Copyright (c) 2023 by Paul Evans <leonerd@leonerd.org.uk>.
|
||||
|
||||
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 <leonerd@leonerd.org.uk>.
|
||||
This software is Copyright (c) 2023 by Paul Evans <leonerd@leonerd.org.uk>.
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
15
MANIFEST
15
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
|
||||
|
|
|
|||
17
META.json
17
META.json
|
|
@ -4,7 +4,7 @@
|
|||
"Paul Evans <leonerd@leonerd.org.uk>"
|
||||
],
|
||||
"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"
|
||||
}
|
||||
|
|
|
|||
14
META.yml
14
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'
|
||||
|
|
|
|||
11
README
11
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
package Module::Build::with::XSTests;
|
||||
|
||||
use strict;
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use base qw( Module::Build );
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
@ -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<Sublike::Extended> - enable extended features when parsing C<sub>-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<sub> 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<XS::Parse::Sublike> 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<sub> (or
|
||||
other sub-like function keyword).
|
||||
|
||||
This keyword can be freely mixed with other C<sub>-prefix keywords, such as
|
||||
C<async> from L<Future::AsyncAwait>
|
||||
|
||||
async extended sub f (:$param) { ... }
|
||||
|
||||
This can also be used with other keywords that provide C<sub>-like syntax,
|
||||
such as C<method> from L<Object::Pad> or the core C<use feature 'class'>.
|
||||
|
||||
extended method f (:$param) { ... }
|
||||
|
||||
=cut
|
||||
|
||||
sub import
|
||||
{
|
||||
$^H{"Sublike::Extended/extended"}++;
|
||||
}
|
||||
|
||||
sub unimport
|
||||
{
|
||||
delete $^H{"Sublike::Extended/extended"};
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Evans <leonerd@leonerd.org.uk>
|
||||
|
||||
=cut
|
||||
|
||||
0x55AA;
|
||||
|
|
@ -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);
|
||||
|
|
@ -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<require_parts>. It
|
||||
is always permitted not to provide a signature for a function definition,
|
||||
because such syntax only applies when C<use feature 'signatures'> 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<require_parts>. This is because such syntax only applies when
|
||||
C<use feature 'signatures'> is in effect, and only on supporting perl
|
||||
versions.
|
||||
|
||||
However, setting the bit in I<require_parts> instead has the effect of
|
||||
enabling C<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.
|
||||
|
||||
=item XS_PARSE_SUBLIKE_PART_BODY
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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<XSParseSublike.h> file to the current working directory. To cause
|
||||
the compiler to actually find this file, see L</extra_compiler_flags>.
|
||||
|
|
@ -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<Module::Build>-based distribution use the helper.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 ();
|
||||
|
|
|
|||
|
|
@ -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' );
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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' );
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::stages";
|
||||
|
|
|
|||
|
|
@ -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' );
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::registrations";
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::parts";
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::parts";
|
||||
|
|
|
|||
|
|
@ -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()";
|
||||
}
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
|
||||
use lib "t";
|
||||
use testcase "t::flags";
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test2::V0;
|
||||
use Sub::Util 'subname';
|
||||
|
||||
use lib "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;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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 $@;
|
||||
|
|
|
|||
3
t/any.xs
3
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,
|
||||
|
|
|
|||
43
t/func.xs
43
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
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
package testcase;
|
||||
|
||||
use strict;
|
||||
use v5.14;
|
||||
use warnings;
|
||||
|
||||
use lib "t/blib", "t/blib/arch";
|
||||
|
|
|
|||
Loading…
Reference in New Issue