--- /dev/null
+include ./Makefile
+
+CCFLAGS := -DDEVEL $(CCFLAGS)
Changes
-MANIFEST
+lib/Function/Parameters.pm
Makefile.PL
+MANIFEST
+MANIFEST.SKIP
+MYMETA.json
+MYMETA.yml
+Parameters.xs
README
-lib/Function/Parameters.pm
-t/pod.t
t/00-load.t
t/01-compiles.t
t/02-compiles.t
-t/elsewhere.t
-t/rename.t
-t/eating_strict_error.t
t/eating_strict_error.fail
+t/eating_strict_error.t
t/eating_strict_error_2.fail
+t/elsewhere.t
t/lineno-torture.t
t/lineno.t
t/named.t
t/named_2.fail
t/named_3.fail
t/named_4.fail
+t/pod.t
+t/rename.t
+t/strict.t
+t/strict_1.fail
+t/strict_2.fail
+t/strict_3.fail
+t/strict_4.fail
+toke_on_crack.c.inc
'Test::More' => 0,
},
PREREQ_PM => {
+ 'Carp' => 0,
+ 'B::Hooks::EndOfScope' => 0,
'XSLoader' => 0,
+ 'bytes' => 0,
'warnings' => 0,
'strict' => 0,
},
--- /dev/null
+/*
+Copyright 2012 Lukas Mai.
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+ */
+
+#ifdef __GNUC__
+ #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
+ #define PRAGMA_GCC_(X) _Pragma(#X)
+ #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
+ #endif
+#endif
+
+#ifndef PRAGMA_GCC
+ #define PRAGMA_GCC(X)
+#endif
+
+#ifdef DEVEL
+ #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
+ #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X)
+ #define WARNINGS_ENABLE \
+ WARNINGS_ENABLEW(-Wall) \
+ WARNINGS_ENABLEW(-Wextra) \
+ WARNINGS_ENABLEW(-Wundef) \
+ WARNINGS_ENABLEW(-Wshadow) \
+ WARNINGS_ENABLEW(-Wbad-function-cast) \
+ WARNINGS_ENABLEW(-Wcast-align) \
+ WARNINGS_ENABLEW(-Wwrite-strings) \
+ /* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \
+ WARNINGS_ENABLEW(-Wstrict-prototypes) \
+ WARNINGS_ENABLEW(-Wmissing-prototypes) \
+ WARNINGS_ENABLEW(-Winline) \
+ WARNINGS_ENABLEW(-Wdisabled-optimization)
+
+#else
+ #define WARNINGS_RESET
+ #define WARNINGS_ENABLE(X)
+#endif
+
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <string.h>
+
+WARNINGS_ENABLE
+
+#define MY_PKG "Function::Parameters"
+
+#define HINTK_KEYWORDS MY_PKG "/keywords"
+#define HINTK_NAME_ MY_PKG "/name:"
+#define HINTK_SHIFT_ MY_PKG "/shift:"
+
+typedef struct {
+ enum {
+ FLAG_NAME_OPTIONAL = 1,
+ FLAG_NAME_REQUIRED,
+ FLAG_NAME_PROHIBITED
+ } name;
+ char shift[256];
+} Spec;
+
+static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
+
+static int kw_flags(const char *kw_ptr, STRLEN kw_len, Spec *spec) {
+ HV *hints;
+ SV *sv, **psv;
+ const char *p, *kw_active;
+ STRLEN kw_active_len;
+
+ spec->name = 0;
+ spec->shift[0] = '\0';
+
+ if (!(hints = GvHV(PL_hintgv))) {
+ return FALSE;
+ }
+ if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
+ return FALSE;
+ }
+ sv = *psv;
+ kw_active = SvPV(sv, kw_active_len);
+ if (kw_active_len <= kw_len) {
+ return FALSE;
+ }
+ for (p = kw_active; p < kw_active + kw_active_len - kw_len; p++) {
+ if (
+ (p == kw_active || p[-1] == ' ') &&
+ p[kw_len] == ' ' &&
+ memcmp(kw_ptr, p, kw_len) == 0
+ ) {
+ const char *kf_ptr;
+ STRLEN kf_len;
+ SV *kf_sv;
+
+ kf_sv = sv_2mortal(newSVpvs(HINTK_NAME_));
+ sv_catpvn(kf_sv, kw_ptr, kw_len);
+ kf_ptr = SvPV(kf_sv, kf_len);
+ if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
+ croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
+ }
+ spec->name = SvIV(*psv);
+
+ kf_sv = sv_2mortal(newSVpvs(HINTK_SHIFT_));
+ sv_catpvn(kf_sv, kw_ptr, kw_len);
+ kf_ptr = SvPV(kf_sv, kf_len);
+ if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
+ croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
+ }
+ my_sprintf(spec->shift, "%.*s", (int)(sizeof spec->shift - 1), SvPV_nolen(*psv));
+
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
+
+#include "toke_on_crack.c.inc"
+
+
+static int parse_fun(OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
+ SV *gen, *declarator, *params, *sv;
+ line_t line_start;
+ int saw_name, saw_colon;
+ STRLEN len;
+ char *s;
+ I32 c;
+
+ gen = sv_2mortal(newSVpvs("sub"));
+ declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
+ params = sv_2mortal(newSVpvs(""));
+
+ line_start = CopLINE(PL_curcop);
+ lex_read_space(0);
+
+ /* function name */
+ saw_name = 0;
+ s = PL_parser->bufptr;
+ if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(s, TRUE))) {
+ sv_catpvs(gen, " ");
+ sv_catpvn(gen, s, len);
+ sv_catpvs(declarator, " ");
+ sv_catpvn(declarator, s, len);
+ lex_read_to(s + len);
+ lex_read_space(0);
+ saw_name = 1;
+ } else if (spec->name == FLAG_NAME_REQUIRED) {
+ croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
+ } else {
+ sv_catpvs(declarator, " (anon)");
+ }
+
+ /* parameters */
+ c = lex_peek_unichar(0);
+ if (c == '(') {
+ SV *saw_slurpy = NULL;
+
+ lex_read_unichar(0);
+ lex_read_space(0);
+
+ for (;;) {
+ c = lex_peek_unichar(0);
+ if (c && strchr("$@%", c)) {
+ sv_catpvf(params, "%c", (int)c);
+ lex_read_unichar(0);
+ lex_read_space(0);
+
+ s = PL_parser->bufptr;
+ if (!(len = S_scan_word(s, FALSE))) {
+ croak("In %.*s: missing identifier", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ }
+ if (saw_slurpy) {
+ croak("In %.*s: I was expecting \")\" after \"%s\", not \"%c%.*s\"", (int)SvCUR(declarator), SvPV_nolen(declarator), SvPV_nolen(saw_slurpy), (int)c, (int)len, s);
+ }
+ if (c != '$') {
+ saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
+ }
+ sv_catpvn(params, s, len);
+ sv_catpvs(params, ",");
+ lex_read_to(s + len);
+ lex_read_space(0);
+
+ c = lex_peek_unichar(0);
+ if (c == ',') {
+ lex_read_unichar(0);
+ lex_read_space(0);
+ continue;
+ }
+ }
+
+ if (c == ')') {
+ lex_read_unichar(0);
+ lex_read_space(0);
+ break;
+ }
+
+ if (c == -1) {
+ croak("In %.*s: unexpected EOF in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ }
+ croak("In %.*s: unexpected '%c' in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
+ }
+ }
+
+ /* prototype */
+ saw_colon = 0;
+ c = lex_peek_unichar(0);
+ if (c == ':') {
+ lex_read_unichar(0);
+ lex_read_space(0);
+
+ c = lex_peek_unichar(0);
+ if (c != '(') {
+ saw_colon = 1;
+ } else {
+ sv = sv_2mortal(newSVpvs(""));
+ if (!S_scan_str(sv, TRUE, TRUE)) {
+ croak("In %.*s: malformed prototype", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ }
+ sv_catsv(gen, sv);
+ lex_read_space(0);
+ }
+ }
+
+ if (saw_name) {
+ len = SvCUR(gen);
+ s = SvGROW(gen, (len + 1) * 2);
+ sv_catpvs(gen, ";");
+ sv_catpvn(gen, s, len);
+ }
+
+ /* attributes */
+ if (!saw_colon) {
+ c = lex_peek_unichar(0);
+ if (c == ':') {
+ saw_colon = 1;
+ lex_read_unichar(0);
+ lex_read_space(0);
+ }
+ }
+ if (saw_colon) {
+ for (;;) {
+ s = PL_parser->bufptr;
+ if (!(len = S_scan_word(s, FALSE))) {
+ break;
+ }
+ sv_catpvs(gen, ":");
+ sv_catpvn(gen, s, len);
+ lex_read_to(s + len);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == '(') {
+ sv = sv_2mortal(newSVpvs(""));
+ if (!S_scan_str(sv, TRUE, TRUE)) {
+ croak("In %.*s: malformed attribute argument list", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ }
+ sv_catsv(gen, sv);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ }
+ if (c == ':') {
+ lex_read_unichar(0);
+ lex_read_space(0);
+ }
+ }
+ }
+
+ /* body */
+ c = lex_peek_unichar(0);
+ if (c != '{') {
+ croak("In %.*s: I was expecting a function body, not \"%c\"", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
+ }
+ lex_read_unichar(0);
+ sv_catpvs(gen, "{");
+ if (spec->shift[0]) {
+ sv_catpvf(gen, "my%s=shift;", spec->shift);
+ }
+ if (SvCUR(params)) {
+ sv_catpvs(gen, "my(");
+ sv_catsv(gen, params);
+ sv_catpvs(gen, ")=@_;");
+ }
+
+ /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
+
+ /* named sub */
+ if (saw_name) {
+ lex_stuff_sv(gen, SvUTF8(gen));
+ *pop = parse_barestmt(0);
+ return KEYWORD_PLUGIN_STMT;
+ }
+
+ /* anon sub */
+ sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}");
+ lex_stuff_sv(gen, SvUTF8(gen));
+ *pop = parse_arithexpr(0);
+ s = PL_parser->bufptr;
+ if (*s != '}') {
+ croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s);
+ }
+ lex_unstuff(s + 1);
+ return KEYWORD_PLUGIN_EXPR;
+}
+
+static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
+ Spec spec;
+ int ret;
+
+ SAVETMPS;
+
+ if (kw_flags(keyword_ptr, keyword_len, &spec)) {
+ ret = parse_fun(op_ptr, keyword_ptr, keyword_len, &spec);
+ } else {
+ ret = next_keyword_plugin(keyword_ptr, keyword_len, op_ptr);
+ }
+
+ FREETMPS;
+
+ return ret;
+}
+
+WARNINGS_RESET
+
+MODULE = Function::Parameters PACKAGE = Function::Parameters
+PROTOTYPES: ENABLE
+
+BOOT:
+WARNINGS_ENABLE {
+ HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
+ newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
+ newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
+ newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
+ newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
+ newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
+ newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
+ newCONSTSUB(stash, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift));
+ next_keyword_plugin = PL_keyword_plugin;
+ PL_keyword_plugin = my_keyword_plugin;
+} WARNINGS_RESET
+
+void
+xs_fini()
+ CODE:
+ lex_stuff_pvn("}", 1, 0);
COPYRIGHT AND LICENCE
-Copyright (C) 2009 Lukas Mai
+Copyright (C) 2009-2012 Lukas Mai
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
+++ /dev/null
-blib*
-Makefile
-Makefile.old
-Build
-_build*
-pm_to_blib*
-*.tar.gz
-.lwpcookies
-Function-Parameters-*
-cover_db
use strict;
use warnings;
-our $VERSION = '0.05';
-
-use Carp qw(croak confess);
-use Devel::Declare;
-use B::Hooks::EndOfScope;
-
-our @CARP_NOT = qw(Devel::Declare);
-
-
-# Make our import chainable so a wrapper module that wants to turn on F:P
-# for its users can just say
-# sub import { Function::Parameters->import; }
-#
-# To make that possible we skip all subs named 'import' in our search for the
-# target package.
-#
-sub guess_caller {
- my ($start) = @_;
- $start ||= 1;
-
- my $defcaller = (caller $start)[0];
- my $caller = $defcaller;
-
- for (my $level = $start; ; ++$level) {
- my ($pkg, $function) = (caller $level)[0, 3] or last;
- $function =~ /::import\z/ or return $caller;
- $caller = $pkg;
- }
- $defcaller
+use XSLoader;
+BEGIN {
+ our $VERSION = '0.05_01';
+ XSLoader::load;
}
+use B::Hooks::EndOfScope qw(on_scope_end);
+use Carp qw(confess);
+use bytes ();
sub _assert_valid_identifier {
my ($name, $with_dollar) = @_;
or confess qq{"$name" doesn't look like a valid identifier};
}
-# Parse import spec and make shit happen.
-#
my @bare_arms = qw(function method);
my %type_map = (
function => { name => 'optional' },
method => { name => 'optional', shift => '$self' },
);
-sub import_into {
- my $victim = shift;
+sub import {
+ my $class = shift;
@_ or @_ = ('fun', 'method');
if (@_ == 1 && ref($_[0]) eq 'HASH') {
$type->{name} ||= 'optional';
$type->{name} =~ /^(?:optional|required|prohibited)\z/
or confess qq["$type->{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
- $type->{shift}
- and _assert_valid_identifier $type->{shift}, 1;
+ if ($type->{shift}) {
+ _assert_valid_identifier $type->{shift}, 1;
+ bytes::length($type->{shift}) < SHIFT_NAME_LIMIT
+ or confess qq["$type->{shift}" is longer than I can handle];
+ }
- $spec{$name} = {const => mk_parse($type)};
+ $spec{$name} = $type;
}
- Devel::Declare->setup_for($victim, \%spec);
- for my $name (keys %spec) {
- no strict 'refs';
- *{$victim . '::' . $name} = \&_declarator;
+ for my $kw (keys %spec) {
+ my $type = $spec{$kw};
+
+ $^H{HINTK_SHIFT_ . $kw} = $type->{shift} || '';
+ $^H{HINTK_NAME_ . $kw} =
+ $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED :
+ $type->{name} eq 'required' ? FLAG_NAME_REQUIRED :
+ FLAG_NAME_OPTIONAL
+ ;
+ $^H{+HINTK_KEYWORDS} .= "$kw ";
}
}
-sub import {
+sub unimport {
my $class = shift;
- my $caller = guess_caller;
- import_into $caller, @_;
-}
-
-sub _declarator {
- $_[0]
-}
-
-
-# Wrapper around substr where param 3 is an end offset, not a length.
-#
-sub _substring {
- @_ >= 4
- ? substr $_[0], $_[1], $_[2] - $_[1], $_[3]
- : substr $_[0], $_[1], $_[2] - $_[1]
-}
-
-sub _skip_space {
- my ($ctx, $key) = @_;
- my $cur = my $start = $ctx->{offset};
- while (my $d = Devel::Declare::toke_skipspace $cur) {
- $cur += $d;
- }
- $ctx->{space}{$key} .= _substring Devel::Declare::get_linestr, $start, $cur if $key;
- $ctx->{offset} = $cur;
-}
-
-sub _grab_name {
- my ($ctx) = @_;
- my $p = $ctx->{offset};
- my $namlen = Devel::Declare::toke_scan_word $p, !!'handle_package'
- or return;
- my $str = Devel::Declare::get_linestr;
- $ctx->{name} = substr $str, $p, $namlen;
- $ctx->{offset} += $namlen;
- _skip_space $ctx, 'name';
-}
-
-sub _grab_params {
- my ($ctx) = @_;
- substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '('
- or return;
- $ctx->{offset}++;
- _skip_space $ctx, 'params';
-
- my $pcount = 0;
-
- LOOP: {
- my $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
-
- if ($c =~ /^[\$\@%]\z/) {
- $ctx->{offset}++;
- _skip_space $ctx, "params_$pcount";
- my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
- or croak "Missing identifier";
- my $name = substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
- $ctx->{params} .= $c . $name . ',';
- $ctx->{offset} += $namlen;
- _skip_space $ctx, "params_$pcount";
-
- $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1;
- if ($c eq ',') {
- $ctx->{offset}++;
- _skip_space $ctx, "params_$pcount";
- $pcount++;
- redo LOOP;
- }
- }
-
- if ($c eq ')') {
- $ctx->{offset}++;
- _skip_space $ctx, 'params';
- return;
- }
-
- if ($c eq '') {
- croak "Unexpected EOF in parameter list";
- }
-
- croak "Unexpected '$c' in parameter list";
- }
-}
-
-sub _parse_parens {
- my ($ctx) = @_;
-
- my $strlen = Devel::Declare::toke_scan_str $ctx->{offset};
- $strlen == 0 || $strlen == -1 and return;
-
- $strlen < 0 and confess "Devel::Declare::toke_scan_str done fucked up ($strlen); see https://rt.cpan.org/Ticket/Display.html?id=51679";
-
- my $str = Devel::Declare::get_lex_stuff;
- Devel::Declare::clear_lex_stuff;
-
- $ctx->{offset} += $strlen;
-
- $str
-}
-
-sub _grab_proto {
- my ($ctx) = @_;
-
- my $savepos = $ctx->{offset};
- substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':'
- or return;
- $ctx->{offset}++;
- _skip_space $ctx, 'proto_tmp';
-
- unless (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
- $ctx->{offset} = $savepos;
- delete $ctx->{space}{proto_tmp};
- return;
- }
- $_->{proto} .= delete $_->{proto_tmp} for $ctx->{space};
-
- defined(my $str = _parse_parens $ctx)
- or croak "Malformed prototype";
- $ctx->{proto} = $str;
-
- _skip_space $ctx, 'proto';
-}
-
-sub _grab_attr {
- my ($ctx) = @_;
-
- my $pcount = 0;
-
- if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
- $ctx->{offset}++;
- _skip_space $ctx, "attr_$pcount";
- } elsif (!defined $ctx->{proto}) {
+ if (!@_) {
+ delete $^H{+HINTK_KEYWORDS};
return;
}
- while () {
- my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package'
- or return;
- $ctx->{attr} .= substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen;
- $ctx->{offset} += $namlen;
- _skip_space $ctx, "attr_$pcount";
- if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') {
- defined(my $str = _parse_parens $ctx)
- or croak "Malformed attribute argument list";
- $ctx->{attr} .= "($str)";
- _skip_space $ctx, "attr_$pcount";
- }
- $pcount++;
-
- if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') {
- $ctx->{offset}++;
- _skip_space $ctx, "attr_$pcount";
- }
- }
-}
-
-# IN:
-# fun name (params) :(proto) :attr { ... }
-# OUT:
-# fun (do { sub (proto) :attr { self? my (params) = @_; ... } })
-# fun (do { sub name (proto); sub name (proto) :attr { self? my (params) = @_; ... } });
-#
-sub _generate {
- my ($ctx, $declarator, $shift) = @_;
-
- my $gen = '(do{sub';
-
- my $skipped = join '', values %{$ctx->{space}};
- my $lines = $skipped =~ tr/\n//;
- $gen .= "\n" x $lines;
-
- my $proto = defined $ctx->{proto} ? "($ctx->{proto})" : '';
-
- my $is_stmt = 0;
- if (defined(my $name = $ctx->{name})) {
- $is_stmt = 1;
- $gen .= " $name$proto;";
- $gen .= "sub $name";
- }
-
- $gen .= $proto;
-
- if (defined $ctx->{attr}) {
- $gen .= ":$ctx->{attr}";
- }
-
- $gen .= '{';
- $gen .= "BEGIN{${\__PACKAGE__}::_fini($is_stmt)}";
-
- if ($shift) {
- _assert_valid_identifier $shift, 1;
- $gen .= "my$shift=shift;";
- }
- if (defined $ctx->{params}) {
- $gen .= "my($ctx->{params})=\@_;";
- }
- $gen
-}
-
-sub mk_parse {
- my ($spec) = @_;
-
- sub {
- my ($declarator, $offset_orig) = @_;
- my $ctx = {
- offset => $offset_orig,
- space => {},
- };
-
- $ctx->{offset} += Devel::Declare::toke_move_past_token($ctx->{offset});
- _skip_space $ctx;
-
- my $start = $ctx->{offset};
-
- _grab_name $ctx unless $spec->{name} eq 'prohibited';
- $ctx->{name} or croak qq[I was expecting a function name, not "${\substr Devel::Declare::get_linestr, $ctx->{offset}}"] if $spec->{name} eq 'required';
- my $fname = $ctx->{name} || '(anon)';
- _grab_params $ctx;
- if ($ctx->{params} && $ctx->{params} =~ /([\@%]\w+),([\$\@%]\w+)/) {
- my ($slurpy, $after) = ($1, $2);
- croak qq[In $declarator $fname: I was expecting ")" after "$slurpy", not "$after"];
- }
- _grab_proto $ctx;
- _grab_attr $ctx;
-
- my $offset = $ctx->{offset};
-
- my $linestr = Devel::Declare::get_linestr;
- substr($linestr, $offset, 1) eq '{'
- or croak qq[In $declarator $fname: I was expecting a function body, not "${\substr $linestr, $offset}"];
-
- my $gen = _generate $ctx, $declarator, $spec->{shift};
- my $oldlen = $offset + 1 - $start;
- _substring $linestr, $start, $offset + 1, (' ' x $oldlen) . $gen;
- Devel::Declare::set_linestr $linestr;
+ for my $kw (@_) {
+ $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g;
}
}
-# Patch in the end of our synthetic 'do' block, close argument list, and
-# optionally terminate the statement.
-#
sub _fini {
- my ($stmt) = @_;
on_scope_end {
- my $off = Devel::Declare::get_linestr_offset;
- my $str = Devel::Declare::get_linestr;
- substr $str, $off, 0, '})' . ($stmt ? ';' : '');
- Devel::Declare::set_linestr $str;
+ xs_fini;
};
}
+
'ok'
__END__
=head1 DESCRIPTION
This module lets you use parameter lists in your subroutines. Thanks to
-L<Devel::Declare> it works without source filters.
+L<perlapi/PL_keyword_plugin> it works without source filters.
-WARNING: This is my first attempt at using L<Devel::Declare> and I have
+WARNING: This is my first attempt at writing L<XS code|perlxs> and I have
almost no experience with perl's internals. So while this module might
appear to work, it could also conceivably make your programs segfault.
Consider this module alpha quality.
specifying it as the first attribute (this is syntactically unambiguous
because normal attributes have to start with a letter).
-If you want to wrap C<Function::Parameters>, you may find C<import_into>
-helpful. It lets you specify a target package for the syntax magic, as in:
+If you want to wrap L<Function::Parameters>, you just have to call its
+C<import> method. It always applies to the file that is currently being parsed
+and its effects are lexical (i.e. it works like L<warnings> or L<strict>);
package Some::Wrapper;
use Function::Parameters ();
sub import {
- my $caller = caller;
- Function::Parameters::import_into $caller;
- # or Function::Parameters::import_into $caller, @other_import_args;
+ Function::Parameters->import;
+ # or Function::Parameters->import(@other_import_args);
}
-C<import_into> is not exported by this module, so you have to use a fully
-qualified name to call it.
-
=head1 AUTHOR
Lukas Mai, C<< <l.mai at web.de> >>
=head1 COPYRIGHT & LICENSE
-Copyright 2010, 2011 Lukas Mai.
+Copyright 2010, 2011, 2012 Lukas Mai.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
use warnings;
use Test::More;
-use Function::Parameters ();
+{
+ package Wrapper;
+ use Function::Parameters ();
+ sub shazam { Function::Parameters->import(@_); }
+}
-BEGIN { Function::Parameters::import_into __PACKAGE__; }
+BEGIN { Wrapper::shazam; }
ok fun ($x) { $x }->(1);
-BEGIN { Function::Parameters::import_into 'Cu::Ba', 'gorn'; }
-
{
package Cu::Ba;
+ BEGIN { Wrapper::shazam 'gorn'; }
gorn wooden ($gorn) { !$gorn }
}
use warnings;
use strict;
-use Test::More tests => 8;
+use Test::More tests => 10;
use Function::Parameters;
test_loc 'LX -- 4';
}
+TODO: {
+ local $TODO = 'newlines in prototype/attributes';
+
+ fun wtf :(
+
+ )
+ :
+ { test_loc 'LX -- 5 (inner)' }
+
+ wtf;
+ test_loc 'LX -- 5 (outer)';
+}
+
__DATA__
--- /dev/null
+/*
+ * This code was copied from perl/toke.c and subsequently butchered
+ * by Lukas Mai (2012).
+ */
+
+/* vvvvvvvvvvvvvvvvvvvvv I HAVE NO IDEA WHAT I'M DOING vvvvvvvvvvvvvvvvvvvv */
+#define PL_linestr (PL_parser->linestr)
+#define PL_copline (PL_parser->copline)
+#define PL_bufptr (PL_parser->bufptr)
+#define PL_bufend (PL_parser->bufend)
+#define PL_multi_start (PL_parser->multi_start)
+#define PL_multi_open (PL_parser->multi_open)
+#define PL_multi_close (PL_parser->multi_close)
+#define PL_multi_end (PL_parser->multi_end)
+#define PL_rsfp (PL_parser->rsfp)
+
+#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
+
+#ifdef USE_UTF8_SCRIPTS
+# define UTF (!IN_BYTES)
+#else
+# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+#endif
+
+static STRLEN S_scan_word(const char *start, int allow_package) {
+ const char *s = start;
+ for (;;) {
+ if (isALNUM(*s) || (!UTF && isALNUMC_L1(*s))) { /* UTF handled below */
+ s++;
+ } else if (allow_package && s > start && *s == '\'' && isIDFIRST_lazy_if(s+1, UTF)) {
+ s++;
+ } else if (allow_package && s[0] == ':' && s[1] == ':' && isIDFIRST_lazy_if(s+2, UTF)) {
+ s += 2;
+ } else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
+ do {
+ s += UTF8SKIP(s);
+ } while (UTF8_IS_CONTINUED(*s) && is_utf8_mark((U8*)s));
+ } else {
+ return s - start;
+ }
+ }
+}
+
+static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) {
+ dVAR;
+ char *start = PL_bufptr;
+ const char *tmps; /* temp string, used for delimiter matching */
+ char *s = start; /* current position in the buffer */
+ char term; /* terminating character */
+ char *to; /* current position in the sv's data */
+ I32 brackets = 1; /* bracket nesting level */
+ bool has_utf8 = FALSE; /* is there any utf8 content? */
+ I32 termcode; /* terminating char. code */
+ U8 termstr[UTF8_MAXBYTES]; /* terminating string */
+ STRLEN termlen; /* length of terminating string */
+ int last_off = 0; /* last position for nesting bracket */
+
+ /* XXX ATTENTION: we don't skip whitespace! */
+
+ /* mark where we are, in case we need to report errors */
+ CLINE;
+
+ /* after skipping whitespace, the next character is the terminator */
+ term = *s;
+ if (!UTF) {
+ termcode = termstr[0] = term;
+ termlen = 1;
+ }
+ else {
+ termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
+ Copy(s, termstr, termlen, U8);
+ if (!UTF8_IS_INVARIANT(term))
+ has_utf8 = TRUE;
+ }
+
+ /* mark where we are */
+ PL_multi_start = CopLINE(PL_curcop);
+ PL_multi_open = term;
+
+ /* find corresponding closing delimiter */
+ if (term && (tmps = strchr("([{< )]}> )]}>",term)))
+ termcode = termstr[0] = term = tmps[5];
+
+ PL_multi_close = term;
+
+ {
+ STRLEN dummy;
+ SvPV_force(sv, dummy);
+ sv_setpvs(sv, "");
+ SvGROW(sv, 80);
+ }
+
+ /* move past delimiter and try to read a complete string */
+ if (keep_delims)
+ sv_catpvn(sv, s, termlen);
+ s += termlen;
+ for (;;) {
+ if (PL_encoding && !UTF) {
+ bool cont = TRUE;
+
+ while (cont) {
+ int offset = s - SvPVX_const(PL_linestr);
+ const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
+ &offset, (char*)termstr, termlen);
+ const char * const ns = SvPVX_const(PL_linestr) + offset;
+ char * const svlast = SvEND(sv) - 1;
+
+ for (; s < ns; s++) {
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
+ CopLINE_inc(PL_curcop);
+ }
+ if (!found)
+ goto read_more_line;
+ else {
+ /* handle quoted delimiters */
+ if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
+ const char *t;
+ for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
+ t--;
+ if ((svlast-1 - t) % 2) {
+ if (!keep_quoted) {
+ *(svlast-1) = term;
+ *svlast = '\0';
+ SvCUR_set(sv, SvCUR(sv) - 1);
+ }
+ continue;
+ }
+ }
+ if (PL_multi_open == PL_multi_close) {
+ cont = FALSE;
+ }
+ else {
+ const char *t;
+ char *w;
+ for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
+ /* At here, all closes are "was quoted" one,
+ so we don't check PL_multi_close. */
+ if (*t == '\\') {
+ if (!keep_quoted && *(t+1) == PL_multi_open)
+ t++;
+ else
+ *w++ = *t++;
+ }
+ else if (*t == PL_multi_open)
+ brackets++;
+
+ *w = *t;
+ }
+ if (w < t) {
+ *w++ = term;
+ *w = '\0';
+ SvCUR_set(sv, w - SvPVX_const(sv));
+ }
+ last_off = w - SvPVX(sv);
+ if (--brackets <= 0)
+ cont = FALSE;
+ }
+ }
+ }
+ if (!keep_delims) {
+ SvCUR_set(sv, SvCUR(sv) - 1);
+ *SvEND(sv) = '\0';
+ }
+ break;
+ }
+
+ /* extend sv if need be */
+ SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
+ /* set 'to' to the next character in the sv's string */
+ to = SvPVX(sv)+SvCUR(sv);
+
+ /* if open delimiter is the close delimiter read unbridle */
+ if (PL_multi_open == PL_multi_close) {
+ for (; s < PL_bufend; s++,to++) {
+ /* embedded newlines increment the current line number */
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
+ CopLINE_inc(PL_curcop);
+ /* handle quoted delimiters */
+ if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
+ if (!keep_quoted && s[1] == term)
+ s++;
+ /* any other quotes are simply copied straight through */
+ else
+ *to++ = *s++;
+ }
+ /* terminate when run out of buffer (the for() condition), or
+ have found the terminator */
+ else if (*s == term) {
+ if (termlen == 1)
+ break;
+ if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
+ break;
+ }
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
+ has_utf8 = TRUE;
+ *to = *s;
+ }
+ }
+
+ /* if the terminator isn't the same as the start character (e.g.,
+ matched brackets), we have to allow more in the quoting, and
+ be prepared for nested brackets.
+ */
+ else {
+ /* read until we run out of string, or we find the terminator */
+ for (; s < PL_bufend; s++,to++) {
+ /* embedded newlines increment the line count */
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
+ CopLINE_inc(PL_curcop);
+ /* backslashes can escape the open or closing characters */
+ if (*s == '\\' && s+1 < PL_bufend) {
+ if (!keep_quoted &&
+ ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
+ s++;
+ else
+ *to++ = *s++;
+ }
+ /* allow nested opens and closes */
+ else if (*s == PL_multi_close && --brackets <= 0)
+ break;
+ else if (*s == PL_multi_open)
+ brackets++;
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
+ has_utf8 = TRUE;
+ *to = *s;
+ }
+ }
+ /* terminate the copied string and update the sv's end-of-string */
+ *to = '\0';
+ SvCUR_set(sv, to - SvPVX_const(sv));
+
+ /*
+ * this next chunk reads more into the buffer if we're not done yet
+ */
+
+ if (s < PL_bufend)
+ break; /* handle case where we are done yet :-) */
+
+#ifndef PERL_STRICT_CR
+ if (to - SvPVX_const(sv) >= 2) {
+ if ((to[-2] == '\r' && to[-1] == '\n') ||
+ (to[-2] == '\n' && to[-1] == '\r'))
+ {
+ to[-2] = '\n';
+ to--;
+ SvCUR_set(sv, to - SvPVX_const(sv));
+ }
+ else if (to[-1] == '\r')
+ to[-1] = '\n';
+ }
+ else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
+ to[-1] = '\n';
+#endif
+
+ read_more_line:
+ /* if we're out of file, or a read fails, bail and reset the current
+ line marker so we can report where the unterminated string began
+ */
+ CopLINE_inc(PL_curcop);
+ PL_bufptr = PL_bufend;
+ if (!lex_next_chunk(0)) {
+ CopLINE_set(PL_curcop, (line_t)PL_multi_start);
+ return NULL;
+ }
+ s = PL_bufptr;
+ }
+
+ /* at this point, we have successfully read the delimited string */
+
+ if (!PL_encoding || UTF) {
+ if (keep_delims)
+ sv_catpvn(sv, s, termlen);
+ s += termlen;
+ }
+ if (has_utf8 || PL_encoding)
+ SvUTF8_on(sv);
+
+ PL_multi_end = CopLINE(PL_curcop);
+
+ /* if we allocated too much space, give some back */
+ if (SvCUR(sv) + 5 < SvLEN(sv)) {
+ SvLEN_set(sv, SvCUR(sv) + 1);
+ SvPV_renew(sv, SvLEN(sv));
+ }
+
+ PL_bufptr = s;
+ return s;
+}
+/* ^^^^^^^^^^^^^^^^^^^^^ I HAVE NO IDEA WHAT I'M DOING ^^^^^^^^^^^^^^^^^^^^ */
projects / p5sagit/Function-Parameters.git / commitdiff