From: Lukas Mai Date: Sun, 17 Jun 2012 00:54:41 +0000 (+0200) Subject: rewrite in XS X-Git-Tag: v0.05_01~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FFunction-Parameters.git;a=commitdiff_plain;h=db81d362a1901dbeccf6063a39e86b35b2838875 rewrite in XS --- diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 index 0000000..6b3454d --- /dev/null +++ b/GNUmakefile @@ -0,0 +1,3 @@ +include ./Makefile + +CCFLAGS := -DDEVEL $(CCFLAGS) diff --git a/MANIFEST b/MANIFEST index c113acc..91bb5ac 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,17 +1,19 @@ 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 @@ -19,3 +21,11 @@ t/named_1.fail 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 diff --git a/Makefile.PL b/Makefile.PL index ea52471..b9fdbfa 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,7 +17,10 @@ WriteMakefile( 'Test::More' => 0, }, PREREQ_PM => { + 'Carp' => 0, + 'B::Hooks::EndOfScope' => 0, 'XSLoader' => 0, + 'bytes' => 0, 'warnings' => 0, 'strict' => 0, }, diff --git a/Parameters.xs b/Parameters.xs new file mode 100644 index 0000000..240a859 --- /dev/null +++ b/Parameters.xs @@ -0,0 +1,348 @@ +/* +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 + +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); diff --git a/README b/README index b5e7069..0dba1d0 100644 --- a/README +++ b/README @@ -36,7 +36,7 @@ You can also look for information at: 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 diff --git a/ignore.txt b/ignore.txt deleted file mode 100644 index 319a58f..0000000 --- a/ignore.txt +++ /dev/null @@ -1,10 +0,0 @@ -blib* -Makefile -Makefile.old -Build -_build* -pm_to_blib* -*.tar.gz -.lwpcookies -Function-Parameters-* -cover_db diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index 69aa627..50fb348 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -3,37 +3,15 @@ package Function::Parameters; 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) = @_; @@ -42,16 +20,14 @@ sub _assert_valid_identifier { 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') { @@ -78,272 +54,48 @@ sub import_into { $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/(? it works without source filters. +L it works without source filters. -WARNING: This is my first attempt at using L and I have +WARNING: This is my first attempt at writing L 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. @@ -494,27 +246,24 @@ by L. However, you can include a prototype by 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, you may find C -helpful. It lets you specify a target package for the syntax magic, as in: +If you want to wrap L, you just have to call its +C method. It always applies to the file that is currently being parsed +and its effects are lexical (i.e. it works like L or L); 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 is not exported by this module, so you have to use a fully -qualified name to call it. - =head1 AUTHOR Lukas Mai, C<< >> =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 diff --git a/t/elsewhere.t b/t/elsewhere.t index 432a1fc..a25a602 100644 --- a/t/elsewhere.t +++ b/t/elsewhere.t @@ -2,16 +2,19 @@ use strict; 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 } } diff --git a/t/lineno.t b/t/lineno.t index 40ac0be..dabddf5 100644 --- a/t/lineno.t +++ b/t/lineno.t @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 8; +use Test::More tests => 10; use Function::Parameters; @@ -60,4 +60,17 @@ TODO: { 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__ diff --git a/toke_on_crack.c.inc b/toke_on_crack.c.inc new file mode 100644 index 0000000..905c85f --- /dev/null +++ b/toke_on_crack.c.inc @@ -0,0 +1,289 @@ +/* + * 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 ^^^^^^^^^^^^^^^^^^^^ */