Devel-Declare-0.006019/000700 000766 000024 00000000000 13066406136 014613 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/Changes000644 000766 000024 00000023266 13066406076 016134 0ustar00etherstaff000000 000000 Revision history for Devel-Declare 0.006019 - 2017-03-28 - added deprecated flag to metadata. No deprecation warning is given at runtime... for now... - added "WARNING" section in pod, advising the deprecated status of this module 0.006018 - 2015-03-24 - tests fixed for blead (5.21.*) (Matthew Horsfall, RT#102918) 0.006017 - 2014-09-25 - fix for changes in 5.21.4 (Avoid creating GVs when subs are declared), RT#99102, Father Chrysostomos 0.006016 - 2014-03-31 - fixed syntax error in a test 0.006015 - 2014-02-02 - fix use of wrong sprintf formatting codes (Zefram, RT#91983) 0.006014 - 2013-07-21 - converted dist to Distar 0.006013 - 2013-06-18 - re-release, because Module::Install is AWESOME! 0.006012 - 2013-06-18 - Updates for some deprecations in perl 5.17. (Zefram, RT#83968) 0.006011 - 2012-02-22 - In XS, use PERL_NO_GET_CONTEXT for efficiency. - Avoid using Test::Warn, which has previously been a troublesome dependency. 0.006010 - 2012-02-07 - Fix workaround for unexported core symbols to avoid breaking compilation on non-threading builds of Perl 5.8. - Set permissions on .perldb file created during test, to avoid "insecure rcfile" warning. 0.006009 - 2012-02-01 - Be adaptive about whether to delete the line reallocation filter, so as to play as nicely as possible with other kinds of source filter. - Document that injecting newlines doesn't work. - Fix a C declaration after statement, which broke compatibility with older compilers (Jan Dubois). - Partially work around unexported core symbols affecting Perl 5.8 on Windows (David Bouyssie). - Jump through some hoops to avoid compiler warnings. 0.006008 - 2011-11-05 - Adjust toke_scan_str logic to always leave the prefix part of linestr unchanged. 0.006007 - 2011-09-12 - Depend on B::Hooks::OP::Check version 0.19, which fixes a serious bug in how it interacts with other modules that hook ops. - Initialize immediately upon loading the module, so that "was Devel::Declare loaded soon enough" errors in string eval can be fixed by loading the module earlier without having to also actually use the module earlier. - Adjust toke_scan_str logic to always show a positive effective length of string source. - Return undef from toke_scan_str if string was unterminated. - Detect and croak if unwanted reallocation occurs during toke_scan_str. - Avoid memory leak in toke_scan_str. - Give Devel::Declare::Context::Simple a version number. - Add MYMETA.{json,yml} to MANIFEST.SKIP and .gitignore. 0.006006 - 2011-08-23 - Increase default linestr size to avoid reallocations (Zefram). 0.006005 - 2011-07-06 - Add a flag for controlling 'redefined' warnings when installing subs into namespaces (clkao). 0.006004 - 2011-05-02 - Bail out earlier when being called while not lexing (Zefram). - Make sure we continue working with Devel::CallParser loaded (Zefram). 0.006003 - 2011-04-12 - Fix test-failures on old perl versions (Zefram). 0.006002 - 2011-04-08 - Re-add Support for very early growing of PL_linestr using filters (Zefram). 0.006001 - 2011-02-26 - Support perl >= 5.13.7 by re-allocating PL_linestr in block hooks (Zefram). 0.006000 - 2010-03-09 - Make things work on perl 5.11.2 and newer (Zefram). 0.005011 - 2009-08-14 - Add tests for not interpreting various things as barewords when they aren't. - Depend on a Test::More with done_testing support. - Don't invoke the const callback for a keyword followed by a fat comma. 0.005010 - 2009-08-11 - Don't invoke the linestr callback if we found a keyword and the bufptr still contains an arrow at its beginning. This causes the linestr callback not to be fired on things like "->method" (if method is a declarator). While this might be useful, it mostly caused problems so far. It might be added again later as a separate feature. 0.005009 - 2009-08-10 - Stop mixing declarations with code. (Closes: RT#48548) (Cosimo Streppone) - Move strip_attrs, which is a purely parsing method, from MethodInstaller::Simple to Context::Simple (nperez). 0.005008 - 2009-07-27 - Depend on the latest ExtUtils::Depends for win32+gcc support. - Conditionally expand linestrings under perl debugger. 0.005007 - 2009-07-13 - Fix line numbers not being updated from skipspace calls 0.005006 - 2009-06-16 - Fix compilation on 5.8 perls. 0.005005 - 2009-06-05 - Improve compatibility with MAD-enabled perls (Reini Urban, Closes RT#45779). 0.005004 - 2009-06-03 - Don't redefine MEM_WRAP_CHECK_ if it's already defined, getting rid of compilation errors on some perls (Maik Fischer). 0.005003 - 2009-05-24 - Failing tests for line number issues (Ash Berlin). - Add strip_names_and_args (Cory Watson). - Various pod fixes (Yanick Champoux, Florian Ragwitz). - Add copyright statements. 0.005002 - 2009-05-10 - Don't invoke the linestr callback if the parser was expecting an operator. This makes calling a method with the name of a declarator work. 0.005001 - 2009-05-06 - Implement skip_declarator in terms of scan_word in Context::Simple. This avoids relying on PL_tokenbuf to skip past the declarator, as PL_tokenbuf might be overwritten by compiling other code between calling the linestr callback and skip_declarator. 0.005000 - 2009-04-18 - Port the documentation from %^H and Scope::Guard to B::Hooks::EndOfScope. - Fix extracting multi-line strings using scan_str. - Remove the nasty workaround for the above from Context::Simple. 0.004000 - 2009-04-10 - Much improved documentation (osfameron). - Make sure the linestr callback isn't invoked when a declarator is used as part of some quoting construct like qq//, m//, s///, qr//, tr///, qx//, ``, etc (Florian Ragwitz). - Tests for this (osfameron, Florian Ragwitz). 0.003005 - 2009-03-30 - Depend on a recent B::Hooks::EndOfScope to make semicolon injection more robust (Florian Ragwitz). - Add a couple of TODO tests for better error reporting (Marcus Ramberg). - Context::Simple::inject_if_block now returns true if start of block was found (Ash Berlin). 0.003004 - 2008-12-11 - Make magic work within string evals on 5.10 if the hints hash is used. - Bind S_scan_ident to perl. It allows scanning for simple identifiers. - Add strip_ident to Context::Simple. 0.003003 - 2008-10-27 - Devel::Declare::MethodInstaller::Simple now has code_for() which the subclass can override to monkey with the magic shadowed subroutine. This is handy if you want to employ Devel::BeginLift. 0.003002 - 2008-10-25 - Depend on Sub::Name and B::Hooks::EndOfScope. MethodInstaller::Simple and Context::Simple use them. 0.003001 - 2008-10-25 - Don't use :lvalue in Context::Simple and MethodInstaller::Simple to keep the debugger happy. 0.003000 - 2008-10-24 - Add Devel::Declare::Context::Simple and Devel::Declare::MethodInstaller::Simple as an experimental way to make creating block- and sub-like keywords easier (Rhesa Rozendaal). 0.002999_01 - 2008-10-24 - Use B::Hooks::OP::Check to register PL_check callbacks. - Use B::Hooks::EndOfScope instead of %^H and Scope::Guard. - Don't segfault if HvNAME(PL_curstash) == NULL. - Don't segfault on 5.9.5+, where PL_parser is a symbol, not a define. - Don't delete the previous symbol table entry when shadowing subs. This makes us work within the debugger. - Don't mix declarations and code. 0.002002 - 2008-10-19 - switch done_declare call from call_argv to call_pv. - Make get_linestr{,_offset} return sensible values when called while the parser isn't running. - Remove several compile time warnings. - Allow enabling of debug mode using $ENV{DD_DEBUG}. 0.002001 - 2008-10-04 - clean up checks for whether we're lexing and whether lex_stuff exists to handle the PL_parser factor-out in 5.10 - check if reallocation of PL_linestr is necessary before doing it. this way we can bail out properly instead of corrupting memory in some cases - don't call strlen twice on the same sting - try to be more portable - stop using Nullsv - don't use Perl_* functions directly. - don't define PERL_CORE - use NEWSV from handy.h instead of defining our own - don't define PERL_NO_GET_CONTEXT - don't support preprocessors (perl -P) 0.002000 - 2008-09-19 - rewrite guts into perl, add tests for new declaration style 0.001011 - 2008-06-04 - add support for 'method main' and other package names 0.001010 - 2008-06-04 - fix traits code, again, so it compiles on 5.10. 0.001009 - 2008-06-03 - only mangle evals if o->op_ppaddr is actually PL_ppaddr[OP_ENTERVAL] - don't set OPf_SPECIAL on entereval ops, mistaken cargo cult from autobox - fix traits code to work on older 5.8.x perls 0.001008 - 2008-06-01 - turns out 0.1.7 in Makefile.PL results in that version going into the .xs file as well as the dist name. Then everything breaks. 0.001007 - 2008-06-01 - bail on SvGROW during declare process since that can't work - use a source filter on files and an op wrap on evals to pre-grow PL_linestr so we don't get to the point of needing to bail 0.001006 - 2007-11-26 - nasty goto &$func hack to avoid :lvalue+list context weirdness - correct SvGROW invocation 0.001005 - 2007-11-09 - stop using & prototypes at all 0.001004 - 2007-10-25 - correct idiotic typo if ifndef 0.001003 - 2007-10-25 - internalise definitions for toke.c chunks to save hassle - make NEWSV macro defined via ifndef rather than version check in case of 5.8.8-maint (and 5.8.9) 0.001002 - 2007-10-21 - compilation fixes for 5.9.5 and -DDEBUGGING 0.001001 - 2007-10-17 - compilation fixes for 5.8.1+ - set Makefile.PL to bomb out for <5.8.1 0.001000 - 2007-09-23 - Initial release to CPAN Devel-Declare-0.006019/Declare.xs000644 000766 000024 00000036364 12474520440 016551 0ustar00etherstaff000000 000000 #define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "hook_op_check.h" #undef printf #include "stolen_chunk_of_toke.c" #include #include #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #define PERL_DECIMAL_VERSION \ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif /* !Newx */ #define DD_DEBUGf_UPDATED_LINESTR 1 #define DD_DEBUGf_TRACE 2 #define DD_DEBUG_UPDATED_LINESTR (dd_debug & DD_DEBUGf_UPDATED_LINESTR) #define DD_DEBUG_TRACE (dd_debug & DD_DEBUGf_TRACE) static int dd_debug = 0; #define DD_CONST_VIA_RV2CV PERL_VERSION_GE(5,11,2) #define DD_GROW_VIA_BLOCKHOOK PERL_VERSION_GE(5,13,3) #define LEX_NORMAL 10 #define LEX_INTERPNORMAL 9 /* please try not to have a line longer than this :) */ #define DD_PREFERRED_LINESTR_SIZE 16384 /* flag to trigger removal of temporary declaree sub */ static int in_declare = 0; /* in 5.10, PL_parser will be NULL if we aren't parsing, and PL_lex_stuff is a lookup into it - so if anything else we can use to tell, so we need to be a bit more careful if PL_parser exists */ #define DD_AM_LEXING_CHECK (PL_lex_state == LEX_NORMAL || PL_lex_state == LEX_INTERPNORMAL) #if defined(PL_parser) || defined(PERL_5_9_PLUS) #define DD_HAVE_PARSER PL_parser #define DD_HAVE_LEX_STUFF (PL_parser && PL_lex_stuff) #define DD_AM_LEXING (PL_parser && DD_AM_LEXING_CHECK) #else #define DD_HAVE_PARSER 1 #define DD_HAVE_LEX_STUFF PL_lex_stuff #define DD_AM_LEXING DD_AM_LEXING_CHECK #endif /* thing that decides whether we're dealing with a declarator */ int dd_is_declarator(pTHX_ char* name) { HV* is_declarator; SV** is_declarator_pack_ref; HV* is_declarator_pack_hash; SV** is_declarator_flag_ref; int dd_flags; char* curstash_name; is_declarator = get_hv("Devel::Declare::declarators", FALSE); if (!is_declarator) return -1; /* $declarators{$current_package_name} */ curstash_name = HvNAME(PL_curstash); if (!curstash_name) return -1; is_declarator_pack_ref = hv_fetch(is_declarator, curstash_name, strlen(curstash_name), FALSE); if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref)) return -1; /* not a hashref */ is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref); /* $declarators{$current_package_name}{$name} */ is_declarator_flag_ref = hv_fetch( is_declarator_pack_hash, name, strlen(name), FALSE ); /* requires SvIOK as well as TRUE since flags not being an int is useless */ if (!is_declarator_flag_ref || !SvIOK(*is_declarator_flag_ref) || !SvTRUE(*is_declarator_flag_ref)) return -1; dd_flags = SvIVX(*is_declarator_flag_ref); return dd_flags; } /* callback thingy */ void dd_linestr_callback (pTHX_ char* type, char* name) { char* linestr = SvPVX(PL_linestr); int offset = PL_bufptr - linestr; dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(type, 0))); XPUSHs(sv_2mortal(newSVpv(name, 0))); XPUSHs(sv_2mortal(newSViv(offset))); PUTBACK; call_pv("Devel::Declare::linestr_callback", G_VOID|G_DISCARD); FREETMPS; LEAVE; } char* dd_get_linestr(pTHX) { if (!DD_HAVE_PARSER) { return NULL; } return SvPVX(PL_linestr); } void dd_set_linestr(pTHX_ char* new_value) { unsigned int new_len = strlen(new_value); if (SvLEN(PL_linestr) < new_len) { croak("PL_linestr not long enough, was Devel::Declare loaded soon enough in %s", CopFILE(&PL_compiling) ); } memcpy(SvPVX(PL_linestr), new_value, new_len+1); SvCUR_set(PL_linestr, new_len); PL_bufend = SvPVX(PL_linestr) + new_len; if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) { /* Cribbed from toke.c */ AV *fileav = CopFILEAV(&PL_compiling); if (fileav) { SV * const sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); (void)SvIOK_on(sv); SvIV_set(sv, 0); av_store(fileav,(I32)CopLINE(&PL_compiling),sv); } } } char* dd_get_lex_stuff(pTHX) { return (DD_HAVE_LEX_STUFF ? SvPVX(PL_lex_stuff) : ""); } void dd_clear_lex_stuff(pTHX) { if (DD_HAVE_PARSER) PL_lex_stuff = (SV*)NULL; } char* dd_get_curstash_name(pTHX) { return HvNAME(PL_curstash); } int dd_get_linestr_offset(pTHX) { char* linestr; if (!DD_HAVE_PARSER) { return -1; } linestr = SvPVX(PL_linestr); return PL_bufptr - linestr; } char* dd_move_past_token (pTHX_ char* s) { /* * buffer will be at the beginning of the declarator, -unless- the * declarator is at EOL in which case it'll be the next useful line * so we don't short-circuit out if we don't find the declarator */ while (s < PL_bufend && isSPACE(*s)) s++; if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf))) s += strlen(PL_tokenbuf); return s; } int dd_toke_move_past_token (pTHX_ int offset) { char* base_s = SvPVX(PL_linestr) + offset; char* s = dd_move_past_token(aTHX_ base_s); return s - base_s; } int dd_toke_scan_word(pTHX_ int offset, int handle_package) { char tmpbuf[sizeof PL_tokenbuf]; char* base_s = SvPVX(PL_linestr) + offset; STRLEN len; char* s = scan_word(base_s, tmpbuf, sizeof tmpbuf, handle_package, &len); return s - base_s; } int dd_toke_scan_ident(pTHX_ int offset) { char tmpbuf[sizeof PL_tokenbuf]; char* base_s = SvPVX(PL_linestr) + offset; char* s = scan_ident(base_s, PL_bufend, tmpbuf, sizeof tmpbuf, 0); return s - base_s; } int dd_toke_scan_str(pTHX_ int offset) { char* old_pvx = SvPVX(PL_linestr); SV* line_copy = sv_2mortal(newSVsv(PL_linestr)); char* base_s = SvPVX(PL_linestr) + offset; char* s = scan_str(base_s, FALSE, FALSE); if(SvPVX(PL_linestr) != old_pvx) croak("PL_linestr reallocated during scan_str, " "Devel::Declare can't continue"); if (!s) return 0; if (s <= base_s || memcmp(SvPVX(line_copy), SvPVX(PL_linestr), offset)) { s += SvCUR(line_copy); sv_catsv(line_copy, PL_linestr); dd_set_linestr(aTHX_ SvPV_nolen(line_copy)); } return s - base_s; } int dd_toke_skipspace(pTHX_ int offset) { char* old_pvx = SvPVX(PL_linestr); char* base_s = SvPVX(PL_linestr) + offset; char* s = skipspace_force(base_s); if(SvPVX(PL_linestr) != old_pvx) croak("PL_linestr reallocated during skipspace, " "Devel::Declare can't continue"); return s - base_s; } static void call_done_declare(pTHX) { dSP; if (DD_DEBUG_TRACE) { printf("Deconstructing declare\n"); printf("PL_bufptr: %s\n", PL_bufptr); printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr)); printf("linestr: %s\n", SvPVX(PL_linestr)); printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr))); } ENTER; SAVETMPS; PUSHMARK(SP); call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD); FREETMPS; LEAVE; if (DD_DEBUG_TRACE) { printf("PL_bufptr: %s\n", PL_bufptr); printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr)); printf("linestr: %s\n", SvPVX(PL_linestr)); printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr))); printf("actual len: %i\n", (int)strlen(PL_bufptr)); } } static int dd_handle_const(pTHX_ char *name); #ifdef CV_NAME_NOTQUAL /* 5.21.5 */ # define Gv_or_CvNAME(g) (isGV(g) \ ? GvNAME(g) \ : SvPV_nolen(cv_name((CV *)SvRV(g), NULL, CV_NAME_NOTQUAL))) #elif defined(CvNAMED) /* 5.21.4 */ # define Gv_or_CvNAME(g) (isGV(g) \ ? GvNAME(g) \ : CvNAMED(SvRV(g)) \ ? HEK_KEY(CvNAME_HEK((CV *)SvRV(g))) \ : GvNAME(CvGV(SvRV(g)))) #else # define Gv_or_CvNAME(g) GvNAME(g) #endif /* replacement PL_check rv2cv entry */ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) { OP* kid; int dd_flags; char *gvname; PERL_UNUSED_VAR(user_data); if (!DD_AM_LEXING) return o; /* not lexing? */ if (in_declare) { call_done_declare(aTHX); return o; } kid = cUNOPo->op_first; if (kid->op_type != OP_GV) /* not a GV so ignore */ return o; if (!isGV(kGVOP_gv) && (!SvROK(kGVOP_gv) || SvTYPE(SvRV(kGVOP_gv)) != SVt_PVCV)) return o; gvname = Gv_or_CvNAME(kGVOP_gv); if (DD_DEBUG_TRACE) { printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), gvname); } dd_flags = dd_is_declarator(aTHX_ gvname); if (dd_flags == -1) return o; if (DD_DEBUG_TRACE) { printf("dd_flags are: %i\n", dd_flags); printf("PL_tokenbuf: %s\n", PL_tokenbuf); } #if DD_CONST_VIA_RV2CV if (PL_expect != XOPERATOR) { if (!dd_handle_const(aTHX_ Gv_or_CvNAME(kGVOP_gv))) return o; CopLINE(PL_curcop) = PL_copline; /* The parser behaviour that we're simulating depends on what comes after the declarator. */ if (*skipspace(PL_bufptr + strlen(gvname)) != '(') { if (in_declare) { call_done_declare(aTHX); } else { dd_linestr_callback(aTHX_ "rv2cv", gvname); } } return o; } #endif /* DD_CONST_VIA_RV2CV */ dd_linestr_callback(aTHX_ "rv2cv", gvname); return o; } #if DD_GROW_VIA_BLOCKHOOK static void dd_block_start(pTHX_ int full) { PERL_UNUSED_VAR(full); if (SvLEN(PL_linestr) < DD_PREFERRED_LINESTR_SIZE) (void) lex_grow_linestr(DD_PREFERRED_LINESTR_SIZE); } #else /* !DD_GROW_VIA_BLOCKHOOK */ OP* dd_pp_entereval(pTHX) { dSP; STRLEN len; const char* s; SV *sv; #ifdef PERL_5_9_PLUS SV *saved_hh = NULL; if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = POPs; } #endif sv = POPs; if (SvPOK(sv)) { if (DD_DEBUG_TRACE) { printf("mangling eval sv\n"); } if (SvREADONLY(sv)) sv = sv_2mortal(newSVsv(sv)); s = SvPVX(sv); len = SvCUR(sv); if (!len || s[len-1] != ';') { if (!(SvFLAGS(sv) & SVs_TEMP)) sv = sv_2mortal(newSVsv(sv)); sv_catpvn(sv, "\n;", 2); } SvGROW(sv, DD_PREFERRED_LINESTR_SIZE); } PUSHs(sv); #ifdef PERL_5_9_PLUS if (PL_op->op_private & OPpEVAL_HAS_HH) { PUSHs(saved_hh); } #endif return PL_ppaddr[OP_ENTEREVAL](aTHX); } STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) { PERL_UNUSED_VAR(user_data); if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL]) o->op_ppaddr = dd_pp_entereval; return o; } #endif /* !DD_GROW_VIA_BLOCKHOOK */ static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen) { SV *filter_datasv; const I32 count = FILTER_READ(idx+1, sv, maxlen); SvGROW(sv, DD_PREFERRED_LINESTR_SIZE); /* Filters can only be deleted in the correct order (reverse of the order in which they were added). Insisting on deleting the filter here would break if another filter were added after ours and is still around. Not deleting the filter at all would break if another filter were added earlier and attempts to delete itself later. We can play nicely to the maximum possible extent by deleting our filter iff it is currently deletable (i.e., it is on the top of the filter stack). Can still run into trouble in more complex situations, but can't avoid that. */ if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0 && (filter_datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters))) && IoANY(filter_datasv) == FPTR2DPTR(void *, dd_filter_realloc)) { filter_del(dd_filter_realloc); } return count; } static int dd_handle_const(pTHX_ char *name) { switch (PL_lex_inwhat) { case OP_QR: case OP_MATCH: case OP_SUBST: case OP_TRANS: case OP_BACKTICK: case OP_STRINGIFY: return 0; break; default: break; } if (strnEQ(PL_bufptr, "->", 2)) { return 0; } { char buf[256]; STRLEN len; char *s = PL_bufptr; STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr); s = scan_word(s, buf, sizeof buf, FALSE, &len); if (strnEQ(buf, name, len)) { char *d; SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr)); sv_catpvn(inject, buf, len); d = peekspace(s); sv_catpvn(inject, s, d - s); if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) { return 0; } sv_catpv(inject, d); dd_set_linestr(aTHX_ SvPV_nolen(inject)); PL_bufptr = SvPVX(PL_linestr) + old_offset; SvREFCNT_dec (inject); } } dd_linestr_callback(aTHX_ "const", name); return 1; } #if !DD_CONST_VIA_RV2CV STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { int dd_flags; char* name; PERL_UNUSED_VAR(user_data); if (DD_HAVE_PARSER && PL_expect == XOPERATOR) { return o; } /* if this is set, we just grabbed a delimited string or something, not a bareword, so NO TOUCHY */ if (DD_HAVE_LEX_STUFF) return o; /* don't try and look this up if it's not a string const */ if (!SvPOK(cSVOPo->op_sv)) return o; name = SvPVX(cSVOPo->op_sv); dd_flags = dd_is_declarator(aTHX_ name); if (dd_flags == -1) return o; dd_handle_const(aTHX_ name); return o; } #endif /* !DD_CONST_VIA_RV2CV */ STATIC void dd_initialize(pTHX) { static int initialized = 0; if (!initialized) { initialized = 1; #if DD_GROW_VIA_BLOCKHOOK { static BHK bhk; #if PERL_VERSION_GE(5,13,6) BhkENTRY_set(&bhk, bhk_start, dd_block_start); #else /* <5.13.6 */ BhkENTRY_set(&bhk, start, dd_block_start); #endif /* <5.13.6 */ Perl_blockhook_register(aTHX_ &bhk); } #else /* !DD_GROW_VIA_BLOCKHOOK */ hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL); #endif /* !DD_GROW_VIA_BLOCKHOOK */ hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL); #if !DD_CONST_VIA_RV2CV hook_op_check(OP_CONST, dd_ck_const, NULL); #endif /* !DD_CONST_VIA_RV2CV */ } } MODULE = Devel::Declare PACKAGE = Devel::Declare PROTOTYPES: DISABLE void initialize() CODE: dd_initialize(aTHX); void setup() CODE: dd_initialize(aTHX); filter_add(dd_filter_realloc, NULL); char* get_linestr() CODE: RETVAL = dd_get_linestr(aTHX); OUTPUT: RETVAL void set_linestr(char* new_value) CODE: dd_set_linestr(aTHX_ new_value); char* get_lex_stuff() CODE: RETVAL = dd_get_lex_stuff(aTHX); OUTPUT: RETVAL void clear_lex_stuff() CODE: dd_clear_lex_stuff(aTHX); char* get_curstash_name() CODE: RETVAL = dd_get_curstash_name(aTHX); OUTPUT: RETVAL int get_linestr_offset() CODE: RETVAL = dd_get_linestr_offset(aTHX); OUTPUT: RETVAL int toke_scan_word(int offset, int handle_package) CODE: RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package); OUTPUT: RETVAL int toke_move_past_token(int offset); CODE: RETVAL = dd_toke_move_past_token(aTHX_ offset); OUTPUT: RETVAL SV* toke_scan_str(int offset); PREINIT: int len; CODE: len = dd_toke_scan_str(aTHX_ offset); RETVAL = len ? newSViv(len) : &PL_sv_undef; OUTPUT: RETVAL int toke_scan_ident(int offset) CODE: RETVAL = dd_toke_scan_ident(aTHX_ offset); OUTPUT: RETVAL int toke_skipspace(int offset) CODE: RETVAL = dd_toke_skipspace(aTHX_ offset); OUTPUT: RETVAL int get_in_declare() CODE: RETVAL = in_declare; OUTPUT: RETVAL void set_in_declare(int value) CODE: in_declare = value; BOOT: { char *endptr; char *debug_str = getenv ("DD_DEBUG"); if (debug_str) { dd_debug = strtol (debug_str, &endptr, 10); if (*endptr != '\0') { dd_debug = 0; } } } Devel-Declare-0.006019/MANIFEST000644 000766 000024 00000001742 13066406136 015762 0ustar00etherstaff000000 000000 Changes Declare.xs lib/Devel/Declare.pm lib/Devel/Declare/Context/Simple.pm lib/Devel/Declare/MethodInstaller/Simple.pm maint/Makefile.include maint/Makefile.PL.include Makefile.PL MANIFEST This list of files stolen_chunk_of_toke.c t/00load.t t/block_size.t t/build_sub_installer.t t/combi.t t/ctx-simple-like-mxms.t t/ctx-simple.t t/debug.pl t/debug.t t/devel_callparser.t t/early0.t t/early1.t t/early1_x.pm t/early2.t t/eval.t t/fail.t t/filter0.t t/filter1.t t/lines.t t/load_module.t t/methinstaller-simple.t t/method-installer-redefine.t t/method-installer-runtime.t t/method-no-semi.t t/method.t t/multiline-proto.t t/new.t t/no-bareword.t t/pack.t t/padstuff.t t/proto.t t/quote.t t/scanstr.t t/scanstr_fail.t t/simple.t t/statement.t t/sugar.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Devel-Declare-0.006019/META.json000600 000766 000024 00000004620 13066406136 016240 0ustar00etherstaff000000 000000 { "abstract" : "Adding keywords to perl, in perl", "author" : [ "Matt S Trout - - original author" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.2501, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Devel-Declare", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "B::Hooks::OP::Check" : "0.19", "Test::More" : "0.88", "Test::Requires" : "0" } }, "configure" : { "requires" : { "B::Hooks::OP::Check" : "0.19", "ExtUtils::Depends" : "0.302" } }, "runtime" : { "requires" : { "B::Hooks::EndOfScope" : "0.05", "B::Hooks::OP::Check" : "0.19", "Scalar::Util" : "1.11", "Sub::Name" : "0", "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Devel-Declare@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Declare" }, "repository" : { "type" : "git", "url" : "git://git.shadowcat.co.uk/p5sagit/Devel-Declare.git", "web" : "http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Devel-Declare.git" } }, "version" : "0.006019", "x_contributors" : [ "Florian Ragwitz ", "Matt S Trout ", "Karen Etheridge ", "Zefram ", "Rhesa Rozendaal ", "Ash Berlin ", "Chia-liang Kao ", "Marcus Ramberg ", "Christopher Nehren ", "Yuval Kogman ", "Cory Watson ", "Alexandr Ciornii ", "Father Chrysostomos ", "Graham Knop ", "Matthew Horsfall ", "Nick Perez ", "Yanick Champoux " ], "x_deprecated" : 1, "x_serialization_backend" : "JSON::MaybeXS version 1.003009" } Devel-Declare-0.006019/META.yml000600 000766 000024 00000003146 13066406135 016071 0ustar00etherstaff000000 000000 --- abstract: 'Adding keywords to perl, in perl' author: - 'Matt S Trout - - original author' build_requires: B::Hooks::OP::Check: '0.19' Test::More: '0.88' Test::Requires: '0' configure_requires: B::Hooks::OP::Check: '0.19' ExtUtils::Depends: '0.302' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.2501, 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: Devel-Declare no_index: directory: - t - inc requires: B::Hooks::EndOfScope: '0.05' B::Hooks::OP::Check: '0.19' Scalar::Util: '1.11' Sub::Name: '0' perl: '5.008001' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Declare repository: git://git.shadowcat.co.uk/p5sagit/Devel-Declare.git version: '0.006019' x_contributors: - 'Florian Ragwitz ' - 'Matt S Trout ' - 'Karen Etheridge ' - 'Zefram ' - 'Rhesa Rozendaal ' - 'Ash Berlin ' - 'Chia-liang Kao ' - 'Marcus Ramberg ' - 'Christopher Nehren ' - 'Yuval Kogman ' - 'Cory Watson ' - 'Alexandr Ciornii ' - 'Father Chrysostomos ' - 'Graham Knop ' - 'Matthew Horsfall ' - 'Nick Perez ' - 'Yanick Champoux ' x_deprecated: 1 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Devel-Declare-0.006019/Makefile.PL000644 000766 000024 00000005702 13066351453 016604 0ustar00etherstaff000000 000000 use strict; use warnings FATAL => 'all'; use 5.008001; use ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; use ExtUtils::Depends; my $pkg = ExtUtils::Depends->new('Devel::Declare', 'B::Hooks::OP::Check'); my %TEST_DEPS = ( 'B::Hooks::OP::Check' => '0.19', 'Test::More' => '0.88', 'Test::Requires' => '0', ); # have to do this since old EUMM dev releases miss the eval $VERSION line my $mymeta_works = do { no warnings; $ExtUtils::MakeMaker::VERSION >= 6.5707 }; WriteMakefile( NAME => 'Devel::Declare', AUTHOR => 'Matt S Trout - - original author', VERSION_FROM => 'lib/Devel/Declare.pm', MIN_PERL_VERSION => '5.008001', CONFIGURE_REQUIRES => { # minimum version that works on Win32+gcc 'ExtUtils::Depends' => 0.302, # minimum version that depends on ExtUtils::Depends 0.302 'B::Hooks::OP::Check' => '0.19', }, PREREQ_PM => { 'Scalar::Util' => 1.11, # set_prototype appeared in this version 'B::Hooks::OP::Check' => '0.19', 'B::Hooks::EndOfScope' => '0.05', 'Sub::Name' => 0, ($mymeta_works ? () : (%TEST_DEPS)), }, $mymeta_works ? (BUILD_REQUIRES => \%TEST_DEPS) : (), META_MERGE => { 'meta-spec' => { version => 2 }, dynamic_config => 0, resources => { # r/w: p5sagit@git.shadowcat.co.uk:Devel-Declare.git repository => { url => 'git://git.shadowcat.co.uk/p5sagit/Devel-Declare.git', web => 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Devel-Declare.git', type => 'git', }, bugtracker => { mailto => 'bug-Devel-Declare@rt.cpan.org', web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Declare', }, }, x_contributors => [ # manually added, from git shortlog -e -s -n 'Florian Ragwitz ', 'Matt S Trout ', 'Karen Etheridge ', 'Zefram ', 'Rhesa Rozendaal ', 'Ash Berlin ', 'Chia-liang Kao ', 'Marcus Ramberg ', 'Christopher Nehren ', 'Yuval Kogman ', 'Cory Watson ', 'Alexandr Ciornii ', 'Father Chrysostomos ', 'Graham Knop ', 'Matthew Horsfall ', 'Nick Perez ', 'Yanick Champoux ', ], x_deprecated => 1, }, C => [ 'Declare.c' ], XS => { 'Declare.xs' => 'Declare.c' }, depend => { '$(OBJECT)' => 'stolen_chunk_of_toke.c' }, $pkg->get_makefile_vars, ); Devel-Declare-0.006019/README000600 000766 000024 00000034220 13066406136 015476 0ustar00etherstaff000000 000000 NAME Devel::Declare - Adding keywords to perl, in perl SYNOPSIS use Method::Signatures; # or ... use MooseX::Declare; # etc. # Use some new and exciting syntax like: method hello (Str :$who, Int :$age where { $_ > 0 }) { $self->say("Hello ${who}, I am ${age} years old!"); } DESCRIPTION Devel::Declare can install subroutines called declarators which locally take over Perl's parser, allowing the creation of new syntax. This document describes how to create a simple declarator. WARNING Warning: Devel::Declare is a giant bag of crack originally implemented by mst with the goal of upsetting the perl core developers so much by its very existence that they implemented proper keyword handling in the core. As of perl5 version 14, this goal has been achieved, and modules such as Devel::CallParser, Function::Parameters, and Keyword::Simple provide mechanisms to mangle perl syntax that don't require hallucinogenic drugs to interpret the error messages they produce. If you are using something that uses Devel::Declare, please for the love of kittens use something else: * Instead of TryCatch, use Try::Tiny * Instead of Method::Signatures, use real subroutine signatures (requires perl 5.22) or Moops USAGE We'll demonstrate the usage of "Devel::Declare" with a motivating example: a new "method" keyword, which acts like the builtin "sub", but automatically unpacks $self and the other arguments. package My::Methods; use Devel::Declare; Creating a declarator with "setup_for" You will typically create sub import { my $class = shift; my $caller = caller; Devel::Declare->setup_for( $caller, { method => { const => \&parser } } ); no strict 'refs'; *{$caller.'::method'} = sub (&) {}; } Starting from the end of this import routine, you'll see that we're creating a subroutine called "method" in the caller's namespace. Yes, that's just a normal subroutine, and it does nothing at all (yet!) Note the prototype "(&)" which means that the caller would call it like so: method { my ($self, $arg1, $arg2) = @_; ... } However we want to be able to call it like this method foo ($arg1, $arg2) { ... } That's why we call "setup_for" above, to register the declarator 'method' with a custom parser, as per the next section. It acts on an optype, usually 'const' as above. (Other valid values are 'check' and 'rv2cv'). For a simpler way to install new methods, see also Devel::Declare::MethodInstaller::Simple Writing a parser subroutine This subroutine is called at *compilation* time, and allows you to read the custom syntaxes that we want (in a syntax that may or may not be valid core Perl 5) and munge it so that the result will be parsed by the "perl" compiler. For this example, we're defining some globals for convenience: our ($Declarator, $Offset); Then we define a parser subroutine to handle our declarator. We'll look at this in a few chunks. sub parser { local ($Declarator, $Offset) = @_; "Devel::Declare" provides some very low level utility methods to parse character strings. We'll define some useful higher level routines below for convenience, and we can use these to parse the various elements in our new syntax. Notice how our parser subroutine is invoked at compile time, when the "perl" parser is pointed just *before* the declarator name. skip_declarator; # step past 'method' my $name = strip_name; # strip out the name 'foo', if present my $proto = strip_proto; # strip out the prototype '($arg1, $arg2)', if present Now we can prepare some code to 'inject' into the new subroutine. For example we might want the method as above to have "my ($self, $arg1, $arg2) = @_" injected at the beginning of it. We also do some clever stuff with scopes that we'll look at shortly. my $inject = make_proto_unwrap($proto); if (defined $name) { $inject = scope_injector_call().$inject; } inject_if_block($inject); We've now managed to change "method ($arg1, $arg2) { ... }" into "method { injected_code; ... }". This will compile... but we've lost the name of the method! In a cute (or horrifying, depending on your perspective) trick, we temporarily change the definition of the subroutine "method" itself, to specialise it with the $name we stripped, so that it assigns the code block to that name. Even though the *next* time "method" is compiled, it will be redefined again, "perl" caches these definitions in its parse tree, so we'll always get the right one! Note that we also handle the case where there was no name, allowing an anonymous method analogous to an anonymous subroutine. if (defined $name) { $name = join('::', Devel::Declare::get_curstash_name(), $name) unless ($name =~ /::/); shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); } else { shadow(sub (&) { shift }); } } Parser utilities in detail For simplicity, we're using global variables like $Offset in these examples. You may prefer to look at Devel::Declare::Context::Simple, which encapsulates the context much more cleanly. "skip_declarator" This simple parser just moves across a 'token'. The common case is to skip the declarator, i.e. to move to the end of the string 'method' and before the prototype and code block. sub skip_declarator { $Offset += Devel::Declare::toke_move_past_token($Offset); } "toke_move_past_token" This builtin parser simply moves past a 'token' (matching "/[a-zA-Z_]\w*/") It takes an offset into the source document, and skips past the token. It returns the number of characters skipped. "strip_name" This parser skips any whitespace, then scans the next word (again matching a 'token'). We can then analyse the current line, and manipulate it (using pure Perl). In this case we take the name of the method out, and return it. sub strip_name { skipspace; if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { my $linestr = Devel::Declare::get_linestr(); my $name = substr($linestr, $Offset, $len); substr($linestr, $Offset, $len) = ''; Devel::Declare::set_linestr($linestr); return $name; } return; } "toke_scan_word" This builtin parser, given an offset into the source document, matches a 'token' as above but does not skip. It returns the length of the token matched, if any. "get_linestr" This builtin returns the full text of the current line of the source document. "set_linestr" This builtin sets the full text of the current line of the source document. Beware that injecting a newline into the middle of the line is likely to fail in surprising ways. Generally, Perl's parser can rely on the `current line' actually being only a single line. Use other kinds of whitespace instead, in the code that you inject. "skipspace" This parser skips whitsepace. sub skipspace { $Offset += Devel::Declare::toke_skipspace($Offset); } "toke_skipspace" This builtin parser, given an offset into the source document, skips over any whitespace, and returns the number of characters skipped. "strip_proto" This is a more complex parser that checks if it's found something that starts with '(' and returns everything till the matching ')'. sub strip_proto { skipspace; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $Offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($Offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $Offset, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } return; } "toke_scan_str" This builtin parser uses Perl's own parsing routines to match a "stringlike" expression. Handily, this includes bracketed expressions (just think about things like "q(this is a quote)"). Also it Does The Right Thing with nested delimiters (like "q(this (is (a) quote))"). It returns the effective length of the expression matched. Really, what it returns is the difference in position between where the string started, within the buffer, and where it finished. If the string extended across multiple lines then the contents of the buffer may have been completely replaced by the new lines, so this position difference is not the same thing as the actual length of the expression matched. However, because moving backward in the buffer causes problems, the function arranges for the effective length to always be positive, padding the start of the buffer if necessary. Use "get_lex_stuff" to get the actual matched text, the content of the string. Because of the behaviour around multiline strings, you can't reliably get this from the buffer. In fact, after the function returns, you can't rely on any content of the buffer preceding the end of the string. If the string being scanned is not well formed (has no closing delimiter), "toke_scan_str" returns "undef". In this case you cannot rely on the contents of the buffer. "get_lex_stuff" This builtin returns what was matched by "toke_scan_str". To avoid segfaults, you should call "clear_lex_stuff" immediately afterwards. Munging the subroutine Let's look at what we need to do in detail. "make_proto_unwrap" We may have defined our method in different ways, which will result in a different value for our prototype, as parsed above. For example: method foo { # undefined method foo () { # '' method foo ($arg1) { # '$arg1' We deal with them as follows, and return the appropriate "my ($self, ...) = @_;" string. sub make_proto_unwrap { my ($proto) = @_; my $inject = 'my ($self'; if (defined $proto) { $inject .= ", $proto" if length($proto); $inject .= ') = @_; '; } else { $inject .= ') = shift;'; } return $inject; } "inject_if_block" Now we need to inject it after the opening '{' of the method body. We can do this with the building blocks we defined above like "skipspace" and "get_linestr". sub inject_if_block { my $inject = shift; skipspace; my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, 1) eq '{') { substr($linestr, $Offset+1, 0) = $inject; Devel::Declare::set_linestr($linestr); } } "scope_injector_call" We want to be able to handle both named and anonymous methods. i.e. method foo () { ... } my $meth = method () { ... }; These will then get rewritten as method { ... } my $meth = method { ... }; where 'method' is a subroutine that takes a code block. Spot the problem? The first one doesn't have a semicolon at the end of it! Unlike 'sub' which is a builtin, this is just a normal statement, so we need to terminate it. Luckily, using "B::Hooks::EndOfScope", we can do this! use B::Hooks::EndOfScope; We'll add this to what gets 'injected' at the beginning of the method source. sub scope_injector_call { return ' BEGIN { MethodHandlers::inject_scope }; '; } So at the beginning of every method, we are passing a callback that will get invoked at the *end* of the method's compilation... i.e. exactly then the closing '}' is compiled. sub inject_scope { on_scope_end { my $linestr = Devel::Declare::get_linestr; my $offset = Devel::Declare::get_linestr_offset; substr($linestr, $offset, 0) = ';'; Devel::Declare::set_linestr($linestr); }; } Shadowing each method. "shadow" We override the current definition of 'method' using "shadow". sub shadow { my $pack = Devel::Declare::get_curstash_name; Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); } For a named method we invoked like this: shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); So in the case of a "method foo { ... }", this call would redefine "method" to be a subroutine that exports 'sub foo' as the (munged) contents of "{...}". The case of an anonymous method is also cute: shadow(sub (&) { shift }); This means that my $meth = method () { ... }; is rewritten with "method" taking the codeblock, and returning it as is to become the value of $meth. "get_curstash_name" This returns the package name *currently being compiled*. "shadow_sub" Handles the details of redefining the subroutine. SEE ALSO One of the best ways to learn "Devel::Declare" is still to look at modules that use it: . AUTHORS Matt S Trout - - original author Company: http://www.shadowcat.co.uk/ Blog: http://chainsawblues.vox.com/ Florian Ragwitz - maintainer osfameron - first draft of documentation COPYRIGHT AND LICENSE This library is free software under the same terms as perl itself Copyright (c) 2007, 2008, 2009 Matt S Trout Copyright (c) 2008, 2009 Florian Ragwitz stolen_chunk_of_toke.c based on toke.c from the perl core, which is Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others Devel-Declare-0.006019/lib/000700 000766 000024 00000000000 13066406135 015360 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/maint/000700 000766 000024 00000000000 13066406135 015722 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/stolen_chunk_of_toke.c000644 000766 000024 00000100167 12504331712 021171 0ustar00etherstaff000000 000000 /* stolen_chunk_of_toke.c - from perl 5.8.8 toke.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "It all comes from here, the stench and the peril." --Frodo */ /* * this is all blatantly stolen. I sincerely hopes it doesn't fuck anything * up but if it does blame me (Matt S Trout), not the poor original authors */ /* the following #defines are stolen from assorted headers, not toke.c (mst) */ #define skipspace(a) S_skipspace(aTHX_ a, 0) #define peekspace(a) S_skipspace(aTHX_ a, 1) #define skipspace_force(a) S_skipspace(aTHX_ a, 2) #define incline(a) S_incline(aTHX_ a) #define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c) #define scan_str(a,b,c) S_scan_str(aTHX_ a,b,c) #define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e) #define scan_ident(a,b,c,d,e) S_scan_ident(aTHX_ a,b,c,d,e) STATIC void S_incline(pTHX_ char *s); STATIC char* S_skipspace(pTHX_ char *s, int incline); STATIC char * S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append); STATIC char* S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims); STATIC char* S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp); #define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */ #define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */ #define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */ /* conditionalise these two because as of 5.9.5 we already get them from the headers (mst) */ #ifndef Newx #define Newx(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)safemalloc((MEM_SIZE)((n)*sizeof(t))))) #endif #ifndef SvPVX_const #define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef MEM_WRAP_CHECK_ #define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t), #endif #define SvPV_renew(sv,n) \ STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (MEM_WRAP_CHECK_(n,char) \ (char*)saferealloc((Malloc_t)SvPVX(sv), \ (MEM_SIZE)((n))))); \ } STMT_END #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) /* On MacOS, respect nonbreaking spaces */ #ifdef MACOS_TRADITIONAL #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') #else #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') #endif /* * Normally, during compile time, PL_curcop == &PL_compiling is true. However, * Devel::Declare makes the interpreter call back to perl during compile time, * which temporarily enters runtime. Then perl space calls various functions * from this file, which are designed to work during compile time. They all * happen to operate on PL_curcop, not PL_compiling. That doesn't make a * difference in the core, but it does for Devel::Declare, which operates at * runtime, but still wants to mangle the things that are about to be compiled. * That's why we define our own PL_curcop and make it point to PL_compiling * here. */ #undef PL_curcop #define PL_curcop (&PL_compiling) #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) #define LEX_NORMAL 10 /* normal code (ie not within "...") */ #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */ #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */ #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */ #define LEX_INTERPSTART 6 /* expecting the start of a $var */ /* at end of code, eg "$x" followed by: */ #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */ #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */ #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of string or after \E, $foo, etc */ #define LEX_INTERPCONST 2 /* NOT USED */ #define LEX_FORMLINE 1 /* expecting a format line */ #define LEX_KNOWNEXT 0 /* next token known; just return it */ /* and these two are my own madness (mst) */ #if PERL_REVISION == 5 && PERL_VERSION == 8 && PERL_SUBVERSION >= 8 #define PERL_5_8_8_PLUS #endif #if PERL_REVISION == 5 && PERL_VERSION > 8 #define PERL_5_9_PLUS #endif #if !defined(PERL_5_9_PLUS) && defined(PERL_IMPLICIT_CONTEXT) /* These two are not exported from the core on Windows. With 5.9+ it's not an issue, because they're part of the PL_parser structure, which is exported. On multiplicity/thread builds we can work around the lack of export by this formulation, where we provide a substitute implementation of the unexported accessor functions. On single-interpreter builds we can't, because access is directly via symbols that are not exported. */ # define Perl_Ilinestart_ptr my_Ilinestart_ptr char **my_Ilinestart_ptr(pTHX) { return &(aTHX->Ilinestart); } # define Perl_Isublex_info_ptr my_Isublex_info_ptr static SUBLEXINFO *my_Isublex_info_ptr(pTHX) { return &(aTHX->Isublex_info); } #endif #ifdef PERL_5_9_PLUS /* 5.9+ moves a bunch of things to a PL_parser struct so we need to declare the backcompat macros for things to still work (mst) */ /* XXX temporary backwards compatibility */ #define PL_lex_brackets (PL_parser->lex_brackets) #define PL_lex_brackstack (PL_parser->lex_brackstack) #define PL_lex_casemods (PL_parser->lex_casemods) #define PL_lex_casestack (PL_parser->lex_casestack) #define PL_lex_defer (PL_parser->lex_defer) #define PL_lex_dojoin (PL_parser->lex_dojoin) #define PL_lex_expect (PL_parser->lex_expect) #define PL_lex_formbrack (PL_parser->lex_formbrack) #define PL_lex_inpat (PL_parser->lex_inpat) #define PL_lex_inwhat (PL_parser->lex_inwhat) #define PL_lex_op (PL_parser->lex_op) #define PL_lex_repl (PL_parser->lex_repl) #define PL_lex_starts (PL_parser->lex_starts) #define PL_lex_stuff (PL_parser->lex_stuff) #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_pending_ident (PL_parser->pending_ident) #define PL_preambled (PL_parser->preambled) #define PL_sublex_info (PL_parser->sublex_info) #define PL_linestr (PL_parser->linestr) #define PL_sublex_info (PL_parser->sublex_info) #define PL_linestr (PL_parser->linestr) #define PL_expect (PL_parser->expect) #define PL_copline (PL_parser->copline) #define PL_bufptr (PL_parser->bufptr) #define PL_oldbufptr (PL_parser->oldbufptr) #define PL_oldoldbufptr (PL_parser->oldoldbufptr) #define PL_linestart (PL_parser->linestart) #define PL_bufend (PL_parser->bufend) #define PL_last_uni (PL_parser->last_uni) #define PL_last_lop (PL_parser->last_lop) #define PL_last_lop_op (PL_parser->last_lop_op) #define PL_lex_state (PL_parser->lex_state) #define PL_rsfp (PL_parser->rsfp) #define PL_rsfp_filters (PL_parser->rsfp_filters) #define PL_in_my (PL_parser->in_my) #define PL_in_my_stash (PL_parser->in_my_stash) #define PL_tokenbuf (PL_parser->tokenbuf) #define PL_multi_end (PL_parser->multi_end) #define PL_error_count (PL_parser->error_count) #define PL_nexttoke (PL_parser->nexttoke) /* these are from the non-PERL_MAD path but I don't -think- I need the PERL_MAD stuff since my code isn't really populating things (mst) */ # ifdef PERL_MAD # define PL_curforce (PL_parser->curforce) # define PL_lasttoke (PL_parser->lasttoke) # else # define PL_nexttype (PL_parser->nexttype) # define PL_nextval (PL_parser->nextval) # endif /* end of backcompat macros from 5.9 toke.c (mst) */ #endif /* when ccflags include -DDEBUGGING we need this for earlier 5.8 perls */ #ifndef SvPV_nolen_const #define SvPV_nolen_const SvPV_nolen #endif /* Name changed in 5.17; use new name in our code. Apparently we're meant to use something else instead, but no non-underscored way to achieve this is apparent. */ #ifndef _is_utf8_mark #define _is_utf8_mark is_utf8_mark #endif /* utf8_to_uvchr_buf() not defined in earlier perls, but less-capable * substitute is available */ #ifndef utf8_to_uvchr_buf #define utf8_to_uvchr_buf(s, e, lp) ((e), utf8_to_uvchr(s, lp)) #endif /* and now we're back to the toke.c stuff again (mst) */ static const char ident_too_long[] = "Identifier too long"; static const char c_without_g[] = "Use of /c modifier is meaningless without /g"; static const char c_in_subst[] = "Use of /c modifier is meaningless in s///"; #ifdef USE_UTF8_SCRIPTS # define UTF (!IN_BYTES) #else # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) #endif /* Invoke the idxth filter function for the current rsfp. */ /* maxlen 0 = read one text line */ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { filter_t funcp; SV *datasv = NULL; if (!PL_rsfp_filters) return -1; if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); if (maxlen) { /* Want a block */ int len ; const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ if (PerlIO_error(PL_rsfp)) return -1; /* error */ else return 0 ; /* end of file */ } SvCUR_set(buf_sv, old_len + len) ; } else { /* Want a line */ if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { if (PerlIO_error(PL_rsfp)) return -1; /* error */ else return 0 ; /* end of file */ } } return SvCUR(buf_sv); } /* Skip this filter slot if filter has been deleted */ if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) { DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: skipped (filter deleted)\n", idx)); return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", idx, datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ return (*funcp)(aTHX_ idx, buf_sv, maxlen); } STATIC char * S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) { #ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { filter_add(S_cr_textfilter,NULL); } #endif if (PL_rsfp_filters) { if (!append) SvCUR_set(sv, 0); /* start with empty line */ if (FILTER_READ(0, sv, 0) > 0) return ( SvPVX(sv) ) ; else return Nullch ; } else return (sv_gets(sv, fp, append)); } /* * S_skipspace * Called to gobble the appropriate amount and type of whitespace. * Skips comments as well. */ STATIC char * S_skipspace(pTHX_ register char *s, int incline) { if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; return s; } for (;;) { STRLEN prevlen; SSize_t oldprevlen, oldoldprevlen; SSize_t oldloplen = 0, oldunilen = 0; while (s < PL_bufend && isSPACE(*s)) { if (*s++ == '\n' && ((incline == 2) || (PL_in_eval && !PL_rsfp && !incline))) incline(s); } /* comment */ if (s < PL_bufend && *s == '#') { while (s < PL_bufend && *s != '\n') s++; if (s < PL_bufend) { s++; if (PL_in_eval && !PL_rsfp && !incline) { incline(s); continue; } } } /* also skip leading whitespace on the beginning of a line before deciding * whether or not to recharge the linestr. --rafl */ while (s < PL_bufend && isSPACE(*s)) { if (*s++ == '\n' && PL_in_eval && !PL_rsfp && !incline) incline(s); } /* only continue to recharge the buffer if we're at the end * of the buffer, we're not reading from a source filter, and * we're in normal lexing mode */ if (s < PL_bufend || !PL_rsfp || PL_lex_inwhat || PL_lex_state == LEX_FORMLINE) return s; /* try to recharge the buffer */ if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) { /* end of file. Add on the -p or -n magic */ if (PL_minus_p) { sv_setpv(PL_linestr, ";}continue{print or die qq(-p destination: $!\\n);}"); PL_minus_n = PL_minus_p = 0; } else if (PL_minus_n) { sv_setpvn(PL_linestr, ";}", 2); PL_minus_n = 0; } else sv_setpvn(PL_linestr,";", 1); /* reset variables for next time we lex */ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; /* In perl versions previous to p4-rawid: //depot/perl@32954 -P * preprocessors were supported here. We don't support -P at all, even * on perls that support it, and use the following chunk from blead * perl. (rafl) */ /* Close the filehandle. Could be from * STDIN, or a regular file. If we were reading code from * STDIN (because the commandline held no -e or filename) * then we don't close it, we reset it so the code can * read from STDIN too. */ if ((PerlIO*)PL_rsfp == PerlIO_stdin()) PerlIO_clearerr(PL_rsfp); else (void)PerlIO_close(PL_rsfp); PL_rsfp = Nullfp; return s; } /* not at end of file, so we only read another line */ /* make corresponding updates to old pointers, for yyerror() */ oldprevlen = PL_oldbufptr - PL_bufend; oldoldprevlen = PL_oldoldbufptr - PL_bufend; if (PL_last_uni) oldunilen = PL_last_uni - PL_bufend; if (PL_last_lop) oldloplen = PL_last_lop - PL_bufend; PL_linestart = PL_bufptr = s + prevlen; PL_bufend = s + SvCUR(PL_linestr); s = PL_bufptr; PL_oldbufptr = s + oldprevlen; PL_oldoldbufptr = s + oldoldprevlen; if (PL_last_uni) PL_last_uni = s + oldunilen; if (PL_last_lop) PL_last_lop = s + oldloplen; if (!incline) incline(s); /* debugger active and we're not compiling the debugger code, * so store the line into the debugger's array of lines */ if (PERLDB_LINE && PL_curstash != PL_debstash) { AV *fileav = CopFILEAV(PL_curcop); if (fileav) { SV * const sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); (void)SvIOK_on(sv); SvIV_set(sv, 0); av_store(fileav,(I32)CopLINE(PL_curcop),sv); } } } } STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { register char *d = dest; register char * const e = d + destlen - 3; /* two-character token, ending NUL */ for (;;) { if (d >= e) Perl_croak(aTHX_ ident_too_long); if (isALNUM(*s)) /* UTF handled below */ *d++ = *s++; else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) { *d++ = ':'; *d++ = ':'; s++; } else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') { *d++ = *s++; *d++ = *s++; } else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); while (UTF8_IS_CONTINUED(*t) && _is_utf8_mark((U8*)t)) t += UTF8SKIP(t); if (d + (t - s) > e) Perl_croak(aTHX_ ident_too_long); Copy(s, d, t - s, char); d += t - s; s = t; } else { *d = '\0'; *slp = d - dest; return s; } } } /* * S_incline * This subroutine has nothing to do with tilting, whether at windmills * or pinball tables. Its name is short for "increment line". It * increments the current line number in CopLINE(PL_curcop) and checks * to see whether the line starts with a comment of the form * # line 500 "foo.pm" * If so, it sets the current line number and file to the values in the comment. */ STATIC void S_incline(pTHX_ char *s) { char *t; char *n; char *e; char ch; CopLINE_inc(PL_curcop); if (*s++ != '#') return; while (SPACE_OR_TAB(*s)) s++; if (strnEQ(s, "line", 4)) s += 4; else return; if (SPACE_OR_TAB(*s)) s++; else return; while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) return; n = s; while (isDIGIT(*s)) s++; while (SPACE_OR_TAB(*s)) s++; if (*s == '"' && (t = strchr(s+1, '"'))) { s++; e = t + 1; } else { for (t = s; !isSPACE(*t); t++) ; e = t; } while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') e++; if (*e != '\n' && *e != '\0') return; /* false alarm */ ch = *t; *t = '\0'; if (t - s > 0) { /* this chunk was added to S_incline during 5.8.8. I don't know why but I don't honestly care since I probably want to be bug-compatible anyway (mst) */ /* ... my kingdom for a perl parser in perl ... (mst) */ #ifdef PERL_5_8_8_PLUS #ifndef USE_ITHREADS const char *cf = CopFILE(PL_curcop); if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) { /* must copy *{"::_<(eval N)[oldfilename:L]"} * to *{"::_ readline or globs , <>, <$fh>, or <*.c> In most of these cases (all but <>, patterns and transliterate) yylex() calls scan_str(). m// makes yylex() call scan_pat() which calls scan_str(). s/// makes yylex() call scan_subst() which calls scan_str(). tr/// and y/// make yylex() call scan_trans() which calls scan_str(). It skips whitespace before the string starts, and treats the first character as the delimiter. If the delimiter is one of ([{< then the corresponding "close" character )]}> is used as the closing delimiter. It allows quoting of delimiters, and if the string has balanced delimiters ([{<>}]) it allows nesting. On success, the SV with the resulting string is put into lex_stuff or, if that is already non-NULL, into lex_repl. The second case occurs only when parsing the RHS of the special constructs s/// and tr/// (y///). For convenience, the terminating delimiter character is stuffed into SvIVX of the SV. */ STATIC char * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { SV *sv; /* scalar value: string */ char *tmps; /* temp string, used for delimiter matching */ register char *s = start; /* current position in the buffer */ register char term; /* terminating character */ register 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 */ /* 5.8.7+ uses UTF8_MAXBYTES but also its utf8.h defs _MAXLEN to it so I'm reasonably hopeful this won't destroy anything (mst) */ U8 termstr[UTF8_MAXLEN]; /* terminating string */ STRLEN termlen; /* length of terminating string */ char *last = NULL; /* last position for nesting bracket */ /* skip space before the delimiter */ if (isSPACE(*s)) s = skipspace(s); /* 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, 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; /* create a new SV to hold the contents. 87 is leak category, I'm assuming. 79 is the SV's initial length. What a random number. */ sv = NEWSV(87,79); sv_upgrade(sv, SVt_PVIV); SvIV_set(sv, termcode); (void)SvPOK_only(sv); /* validate pointer */ /* 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 *ns = SvPVX_const(PL_linestr) + offset; char *svlast = SvEND(sv) - 1; for (; s < ns; s++) { if (*s == '\n' && !PL_rsfp) 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; if (!last) last = SvPVX(sv); for (t = w = last; 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 = w; 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) 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) 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 */ if (!PL_rsfp || !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { sv_free(sv); CopLINE_set(PL_curcop, (line_t)PL_multi_start); return Nullch; } /* we read a line, so increment our line counter */ CopLINE_inc(PL_curcop); /* update debugger info */ if (PERLDB_LINE && PL_curstash != PL_debstash) { AV *fileav = CopFILEAV(PL_curcop); if (fileav) { SV *sv = NEWSV(88,0); sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); (void)SvIOK_on(sv); SvIV_set(sv, 0); av_store(fileav, (I32)CopLINE(PL_curcop), sv); } } /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; } /* 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); /* 5.8.8 uses SvPV_renew, no prior version actually has the damn thing (mst) */ #ifdef PERL_5_8_8_PLUS SvPV_renew(sv, SvLEN(sv)); #else Renew(SvPVX(sv), SvLEN(sv), char); #endif } /* decide whether this is the first or second quoted string we've read for this op */ if (PL_lex_stuff) PL_lex_repl = sv; else PL_lex_stuff = sv; return s; } #define XFAKEBRACK 128 STATIC char * S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) { register char *d; register char *e; char *bracket = Nullch; char funny = *s++; if (isSPACE(*s)) s = skipspace(s); d = dest; e = d + destlen - 3; /* two-character token, ending NUL */ if (isDIGIT(*s)) { while (isDIGIT(*s)) { if (d >= e) Perl_croak(aTHX_ ident_too_long); *d++ = *s++; } } else { for (;;) { if (d >= e) Perl_croak(aTHX_ ident_too_long); if (isALNUM(*s)) /* UTF handled below */ *d++ = *s++; else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) { *d++ = ':'; *d++ = ':'; s++; } else if (*s == ':' && s[1] == ':') { *d++ = *s++; *d++ = *s++; } else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); while (UTF8_IS_CONTINUED(*t) && _is_utf8_mark((U8*)t)) t += UTF8SKIP(t); if (d + (t - s) > e) Perl_croak(aTHX_ ident_too_long); Copy(s, d, t - s, char); d += t - s; s = t; } else break; } } *d = '\0'; d = dest; if (*d) { if (PL_lex_state != LEX_NORMAL) PL_lex_state = LEX_INTERPENDMAYBE; return s; } if (*s == '$' && s[1] && (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) ) { return s; } if (*s == '{') { bracket = s; s++; } else if (ck_uni) { /* we always call this with ck_uni == 0, so no need for check_uni() */ /* check_uni(); */ } if (s < send) *d = *s++; d[1] = '\0'; if (*d == '^' && *s && isCONTROLVAR(*s)) { *d = toCTRL(*s); s++; } if (bracket) { if (isSPACE(s[-1])) { while (s < send) { const char ch = *s++; if (!SPACE_OR_TAB(ch)) { *d = ch; break; } } } if (isIDFIRST_lazy_if(d,UTF)) { d++; if (UTF) { e = s; while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { e += UTF8SKIP(e); while (e < send && UTF8_IS_CONTINUED(*e) && _is_utf8_mark((U8*)e)) e += UTF8SKIP(e); } Copy(s, d, e - s, char); d += e - s; s = e; } else { while ((isALNUM(*s) || *s == ':') && d < e) *d++ = *s++; if (d >= e) Perl_croak(aTHX_ ident_too_long); } *d = '\0'; while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { /* we don't want perl to guess what is meant. the keyword * parser decides that later. (rafl) */ /* if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { const char *brack = *s == '[' ? "[...]" : "{...}"; Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } */ bracket++; PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); return s; } } /* Handle extended ${^Foo} variables * 1999-02-27 mjd-perl-patch@plover.com */ else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ && isALNUM(*s)) { d++; while (isALNUM(*s) && d < e) { *d++ = *s++; } if (d >= e) Perl_croak(aTHX_ ident_too_long); *d = '\0'; } if (*s == '}') { s++; if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { PL_lex_state = LEX_INTERPEND; PL_expect = XREF; } if (funny == '#') funny = '@'; /* we don't want perl to guess what is meant. the keyword * parser decides that later. (rafl) */ /* if (PL_lex_state == LEX_NORMAL) { if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } } */ } else { s = bracket; /* let the parser handle it */ *dest = '\0'; } } /* don't intuit. we really just want the string. (rafl) */ /* else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) PL_lex_state = LEX_INTERPEND; */ return s; } Devel-Declare-0.006019/t/000700 000766 000024 00000000000 13066406135 015055 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/t/00load.t000644 000766 000024 00000000175 12477001527 016337 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 1; BEGIN { $ENV{PERL_DL_NONLAZY} = 1; use_ok('Devel::Declare'); } Devel-Declare-0.006019/t/block_size.t000644 000766 000024 00000100147 12477001527 017404 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 3; sub handle_fun { my $pack = shift; my $linestr = Devel::Declare::get_linestr(); my $pos = length($linestr); Devel::Declare::toke_skipspace(length($linestr)); Devel::Declare::set_linestr($linestr); } use Devel::Declare; sub fun($) {} BEGIN { Devel::Declare->setup_for( __PACKAGE__, { fun => { const => \&handle_fun } } ); } fun 1; ok 0; this line is deleted by handler ; ok 1; # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # min # pos 8192 occurs between these two lines fun 1; ok 0; this line is deleted by handler ; ok 1; # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless co # pos 16384 occurs between these two lines fun 1; ok 0; this line is deleted by handler ; ok 1; # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # mindless comment lines to pad out the test program to the next block boundary # file size slightly exceeds 32768 1; Devel-Declare-0.006019/t/build_sub_installer.t000644 000766 000024 00000000467 12637357463 021324 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; use Devel::Declare (); BEGIN { Devel::Declare->build_sub_installer('Foo', 'bar', '&') ->(sub { $_[0]->("woot"); }); } my $args; { package Foo; bar { $args = join(', ', @_); }; } is($args, 'woot', 'sub installer worked'); done_testing; Devel-Declare-0.006019/t/combi.t000644 000766 000024 00000000717 12637357463 016366 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; sub method :lvalue {my $sv;} sub handle_method { my ($usepack, $use, $inpack, $name, $proto) = @_; my $H = sub (&) { }; if (defined $proto) { return (sub :lvalue {my $sv;}, $H); } return ($H); } use Devel::Declare; use Devel::Declare method => [ DECLARE_NAME|DECLARE_PROTO, \&handle_method ]; method blah { }; method () { }; method wahey () { }; ok(1, "Survived compilation"); done_testing; Devel-Declare-0.006019/t/ctx-simple-like-mxms.t000644 000766 000024 00000004263 13063024314 021242 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 20; # This test script is derived from a MooseX::Method::Signatures test, # which is sensitive to some details of Devel::Declare behaviour that # ctx-simple.t is not. In particular, the use of a paren immediately # following the declarator, constructing a parenthesised function call, # invokes a different parser path. use Devel::Declare (); use Devel::Declare::Context::Simple (); use B::Hooks::EndOfScope qw(on_scope_end); sub inject_after_scope($) { my ($inject) = @_; on_scope_end { my $line = Devel::Declare::get_linestr(); return unless defined $line; my $offset = Devel::Declare::get_linestr_offset(); substr($line, $offset, 0) = $inject; Devel::Declare::set_linestr($line); }; } sub mtfnpy_parser(@) { my $ctx = Devel::Declare::Context::Simple->new(into => __PACKAGE__); $ctx->init(@_); $ctx->skip_declarator; my $name = $ctx->strip_name; die "No name\n" unless defined $name; my $proto = $ctx->strip_proto; die "Wrong declarator\n" unless $ctx->declarator eq "mtfnpy"; $proto =~ s/\n/\\n/g; $ctx->inject_if_block(qq[BEGIN { @{[__PACKAGE__]}::inject_after_scope(', q[${name}]);') } unshift \@_, "${proto}";], "(sub "); my $compile_stash = $ctx->get_curstash_name; $ctx->shadow(sub { my ($code, $name, @args) = @_; no strict "refs"; *{"${compile_stash}::${name}"} = $code; }); } BEGIN { Devel::Declare->setup_for(__PACKAGE__, { mtfnpy => { const => \&mtfnpy_parser }, }); *mtfnpy = sub {}; } mtfnpy foo (extra) { is scalar(@_), 4; is $_[0], "extra"; is $_[1], "a"; is $_[2], "b"; is $_[3], "c"; } foo(qw(a b c)); mtfnpy bar (ex tra) { is scalar(@_), 4; is $_[0], "ex\ntra"; is $_[1], "a"; is $_[2], "b"; is $_[3], "c"; } bar(qw(a b c)); mtfnpy baz (ex tra extra extra) { is scalar(@_), 4; is $_[0], "ex\ntra extra extra"; is $_[1], "a"; is $_[2], "b"; is $_[3], "c"; } baz(qw(a b c)); mtfnpy quux (ex tra extra) { is scalar(@_), 4; is $_[0], "ex\ntra\nextra"; is $_[1], "a"; is $_[2], "b"; is $_[3], "c"; } quux(qw(a b c)); 1; Devel-Declare-0.006019/t/ctx-simple.t000644 000766 000024 00000007223 12637357463 017361 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare (); { package MethodHandlers; use strict; use warnings; use Devel::Declare::Context::Simple; # undef -> my ($self) = shift; # '' -> my ($self) = @_; # '$foo' -> my ($self, $foo) = @_; sub make_proto_unwrap { my ($proto) = @_; my $inject = 'my ($self'; if (defined $proto) { $proto =~ s/[\r\n\s]+/ /g; $inject .= ", $proto" if length($proto); $inject .= ') = @_; '; } else { $inject .= ') = shift;'; } return $inject; } sub parser { my $ctx = Devel::Declare::Context::Simple->new->init(@_); $ctx->skip_declarator; my $name = $ctx->strip_name; my $proto = $ctx->strip_proto; # Check for an 'is' to test strip_name_and_args my $word = $ctx->strip_name; my $traits; if (defined($word) && ($word eq 'is')) { $traits = $ctx->strip_names_and_args; } my $inject = make_proto_unwrap($proto); if (defined $name) { $inject = $ctx->scope_injector_call().$inject; } $ctx->inject_if_block($inject); if (defined $name) { $name = join('::', Devel::Declare::get_curstash_name(), $name) unless ($name =~ /::/); # for trait testing we're just interested in the trait parse result, not # the method body and its injections $ctx->shadow(sub (&) { no strict 'refs'; *{$name} = $traits ? sub { $traits } : shift; }); } else { $ctx->shadow(sub (&) { shift }); } } } my ($test_method1, $test_method2, @test_list); { package DeclareTest; sub method (&); BEGIN { Devel::Declare->setup_for( __PACKAGE__, { method => { const => \&MethodHandlers::parser } } ); } method new { my $class = ref $self || $self; return bless({ @_ }, $class); } method foo ($foo) { return (ref $self).': Foo: '.$foo; } method has_many_traits() is (Trait1, Trait2(foo => 'bar'), Baz(one, two)) { return 1; } method has_a_trait() is Foo1 { return 1; } method upgrade(){ # no spaces to make case pathological bless($self, 'DeclareTest2'); } method DeclareTest2::bar () { return 'DeclareTest2: bar'; } $test_method1 = method { return join(', ', $self->{attr}, $_[1]); }; $test_method2 = method ($what) { return join(', ', ref $self, $what); }; method main () { return "main"; } @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); method multiline1( $foo ) { return "$foo$foo"; } method multiline2( $foo, $bar ) { return "$foo $bar"; } method multiline3 ($foo, $bar) { return "$bar $foo"; } } use Test::More 0.88; my $o = DeclareTest->new(attr => "value"); isa_ok($o, 'DeclareTest'); is($o->{attr}, 'value', '@_ args ok'); is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); is($o->main, 'main', 'declaration of package named method ok'); is($o->multiline1(3), '33', 'multiline1 proto ok'); is($o->multiline2(1,2), '1 2', 'multiline2 proto ok'); is($o->multiline3(4,5), '5 4', 'multiline3 proto ok'); is_deeply( $o->has_many_traits, [['Trait1', undef], ['Trait2', q[foo => 'bar']], ['Baz', 'one, two']], 'extracting multiple traits', ); is_deeply( $o->has_a_trait, [['Foo1', undef]], 'extract one trait without arguments', ); $o->upgrade; isa_ok($o, 'DeclareTest2'); is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); done_testing; Devel-Declare-0.006019/t/debug.pl000644 000766 000024 00000001471 12477001527 016516 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare; BEGIN { Devel::Declare->install_declarator( 'DeclareTest', 'method', DECLARE_PACKAGE | DECLARE_PROTO, sub { my ($name, $proto) = @_; return 'my $self = shift;' unless defined $proto && $proto ne '@_'; return 'my ($self'.(length $proto ? ", ${proto}" : "").') = @_;'; }, sub { my ($name, $proto, $sub, @rest) = @_; if (defined $name && length $name) { unless ($name =~ /::/) { $name = "DeclareTest::${name}"; } no strict 'refs'; *{$name} = $sub; } return wantarray ? ($sub, @rest) : $sub; } ); } my ($test_method1, $test_method2, @test_list); { package DeclareTest; method new { }; } { no strict; no warnings 'uninitialized'; print @{"_ "line debugging broken on 5.11.2"; } } use Cwd qw/cwd/; use FindBin qw/$Bin/; $ENV{PERLDB_OPTS} = "NonStop"; $ENV{DD_DEBUG} = 1; cwd("$Bin/.."); # Write a .perldb file so we make sure we dont use the users one umask 077; open PERLDB, ">", "$Bin/../.perldb" or die "Cannot open $Bin/../.perldb: $!"; close PERLDB; $SIG{CHLD} = 'IGNORE'; $SIG{ALRM} = sub { fail("SIGALRM timeout triggered"); kill(9, $$); }; alarm 10; my $output = `$^X -d t/debug.pl`; like($output, qr/method new \{\}, sub \{my \$self = shift;/, "replaced line string visible in debug lines"); done_testing; Devel-Declare-0.006019/t/devel_callparser.t000644 000766 000024 00000000721 12477001527 020564 0ustar00etherstaff000000 000000 use warnings; use strict; use Test::More; use Test::Requires 'Devel::CallParser'; plan tests => 1; use Devel::CallParser (); sub method { my ($usepack, $name, $inpack, $sub) = @_; no strict "refs"; *{"${inpack}::${name}"} = $sub; } use Devel::Declare method => sub { my ($usepack, $use, $inpack, $name) = @_; return sub (&) { ($usepack, $name, $inpack, $_[0]); }; }; method bar { return join(",", @_); }; is +__PACKAGE__->bar(qw(x y)), "main,x,y"; 1; Devel-Declare-0.006019/t/early0.t000644 000766 000024 00000001263 12477001527 016453 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 1; BEGIN { require Devel::Declare; *class = sub (&) { $_[0]->() }; Devel::Declare->setup_for(__PACKAGE__, { class => { const => sub { my ($kw, $off) = @_; $off += Devel::Declare::toke_move_past_token($off); $off += Devel::Declare::toke_skipspace($off); die unless substr(Devel::Declare::get_linestr(), $off, 1) eq '{'; my $l = Devel::Declare::get_linestr(); substr $l, $off + 1, 0, 'pass q[injected];' . (';' x 1000); Devel::Declare::set_linestr($l); }, }, }); } class {}; Devel-Declare-0.006019/t/early1.t000644 000766 000024 00000000132 12746463444 016457 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 1; use lib 't'; use early1_x; class {}; Devel-Declare-0.006019/t/early1_x.pm000644 000766 000024 00000001347 12746463430 017163 0ustar00etherstaff000000 000000 package early1_x; use strict; use warnings; sub import { require Devel::Declare; my $caller = caller(); no strict 'refs'; *{ "${caller}::class" } = sub (&) { $_[0]->() }; Devel::Declare->setup_for($caller, { class => { const => sub { my ($kw, $off) = @_; $off += Devel::Declare::toke_move_past_token($off); $off += Devel::Declare::toke_skipspace($off); die unless substr(Devel::Declare::get_linestr(), $off, 1) eq '{'; my $l = Devel::Declare::get_linestr(); substr $l, $off + 1, 0, 'pass q[injected];' . (';' x 1000); Devel::Declare::set_linestr($l); }, }, }); } 1; Devel-Declare-0.006019/t/early2.t000644 000766 000024 00000001151 12477001527 016451 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 2; use Devel::Declare; eval q[ BEGIN { *class = sub (&) { $_[0]->() }; Devel::Declare->setup_for(__PACKAGE__, { class => { const => sub { my ($kw, $off) = @_; $off += Devel::Declare::toke_move_past_token($off); $off += Devel::Declare::toke_skipspace($off); die unless substr(Devel::Declare::get_linestr(), $off, 1) eq '{'; my $l = Devel::Declare::get_linestr(); substr $l, $off + 1, 0, 'pass q[injected];' . (';' x 1000); Devel::Declare::set_linestr($l); }, }, }); } class {}; ]; is $@, ""; 1; Devel-Declare-0.006019/t/eval.t000644 000766 000024 00000000700 12637357463 016214 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; sub method { my ($usepack, $name, $inpack, $sub) = @_; no strict 'refs'; *{"${inpack}::${name}"} = $sub; } sub handle_method { my ($usepack, $use, $inpack, $name) = @_; return sub (&) { ($usepack, $name, $inpack, $_[0]); }; } use Devel::Declare 'method' => \&handle_method; BEGIN { $^H{foo} = 'bar' } eval "method bar { 42 }"; diag $@ if $@; is( __PACKAGE__->bar, 42 ); done_testing; Devel-Declare-0.006019/t/fail.t000644 000766 000024 00000001622 12637357463 016204 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; use Devel::Declare::MethodInstaller::Simple; BEGIN { Devel::Declare::MethodInstaller::Simple->install_methodhandler( name => 'method', into => __PACKAGE__, ); } TODO: { local $TODO = 'Method does not throw proper errors for bad parens yet'; eval 'method main ( { return "foo" }'; like($@, qr/Prototype\snot\sterminated/, 'Missing end parens'); eval 'method main ) { return "foo" }'; like($@, qr/Illegal\sdeclaration\sof\ssubroutine/, 'Missing start parens'); }; TODO: { local $TODO = 'method does not disallow invalid sub names'; eval 'method 1main() { return "foo" }'; like($@, qr/Illegal\sdeclaration\sof\sanonymous\ssubroutine/, 'starting with a number'); eval 'method møø() { return "foo" }'; like($@, qr/Illegal\sdeclaration\sof\ssubroutine\smain\:\:m/, 'with unicode'); }; done_testing; Devel-Declare-0.006019/t/filter0.t000644 000766 000024 00000000622 12477001527 016622 0ustar00etherstaff000000 000000 use warnings; use strict; use Test::More; use Test::Requires 'Filter::Util::Call'; plan tests => 2; use Devel::Declare (); use Filter::Util::Call qw(filter_add filter_del); sub my_quote($) { $_[0] } my $i = 0; BEGIN { Devel::Declare->setup_for(__PACKAGE__, { my_quote => { const => sub { } } }); } BEGIN { filter_add(sub { filter_del(); $_ .= "ok \$i++ == 0;"; return 1; }); } ok $i++ == 1; 1; Devel-Declare-0.006019/t/filter1.t000644 000766 000024 00000000622 12477001527 016623 0ustar00etherstaff000000 000000 use warnings; use strict; use Test::More; use Test::Requires 'Filter::Util::Call'; plan tests => 2; use Devel::Declare (); use Filter::Util::Call qw(filter_add filter_del); sub my_quote($) { $_[0] } my $i = 0; BEGIN { filter_add(sub { filter_del(); $_ .= "ok \$i++ == 0;"; return 1; }); } BEGIN { Devel::Declare->setup_for(__PACKAGE__, { my_quote => { const => sub { } } }); } ok $i++ == 1; 1; Devel-Declare-0.006019/t/lines.t000644 000766 000024 00000001627 12477001527 016375 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More; use Test::Requires 'B::Compiling'; plan tests => 5; my @lines; sub handle_fun { my $pack = shift; push @lines, PL_compiling->line; my $offset = Devel::Declare::get_linestr_offset(); $offset += Devel::Declare::toke_move_past_token($offset); my $stripped = Devel::Declare::toke_skipspace($offset); my $linestr = Devel::Declare::get_linestr(); push @lines, PL_compiling->line; } use Devel::Declare; BEGIN { sub fun(&) {} Devel::Declare->setup_for( __PACKAGE__, { fun => { const => \&handle_fun } } ); } #line 100 fun { }; my $line = __LINE__; my $line2 = __LINE__; # Reset the line number back to what it actually is #line 48 is(@lines, 2, "2 line numbers recorded"); is $lines[0], 100, "fun starts on line 100"; is $lines[1], 101, "fun stops on line 101"; is $line, 102, "next statement on line 102"; is $line2, 103, "next statement on line 103"; Devel-Declare-0.006019/t/load_module.t000644 000766 000024 00000000514 12477001527 017541 0ustar00etherstaff000000 000000 =pod This tests against a segfault when PL_parser becomes NULL temporarly, while another module is loaded. =cut use strict; use warnings; use Test::More tests => 1; # last test to print use Devel::Declare 'method' => sub{}; sub lowercase { lc $_[0]; } is lowercase("FOO\x{263a}"), "foo\x{263a}"; Devel-Declare-0.006019/t/methinstaller-simple.t000644 000766 000024 00000005213 12637357463 021433 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; my $Have_Devel_BeginLift; BEGIN { # setup_for_cv() introduced in 0.001001 $Have_Devel_BeginLift = eval q{ use Devel::BeginLift 0.001001; 1 }; } { package MethodHandlers; use strict; use warnings; use base 'Devel::Declare::MethodInstaller::Simple'; # undef -> my ($self) = shift; # '' -> my ($self) = @_; # '$foo' -> my ($self, $foo) = @_; sub parse_proto { my $ctx = shift; my ($proto) = @_; my $inject = 'my ($self'; if (defined $proto) { $inject .= ", $proto" if length($proto); $inject .= ') = @_; '; } else { $inject .= ') = shift;'; } return $inject; } sub code_for { my($self, $name) = @_; my $code = $self->SUPER::code_for($name); if( defined $name and $Have_Devel_BeginLift ) { Devel::BeginLift->setup_for_cv($code); } return $code; } } my ($test_method1, $test_method2, @test_list); { package DeclareTest; BEGIN { # normally, this'd go in MethodHandlers::import MethodHandlers->install_methodhandler( name => 'method', into => __PACKAGE__, ); } # Test at_BEGIN SKIP: { ::skip "Need Devel::BeginLift for compile time methods", 1 unless $Have_Devel_BeginLift; ::can_ok( "DeclareTest", qw(new foo upgrade) ); } method new { my $class = ref $self || $self; return bless({ @_ }, $class); } method foo ($foo) { return (ref $self).': Foo: '.$foo; } method upgrade(){ # no spaces to make case pathological bless($self, 'DeclareTest2'); } method DeclareTest2::bar () { return 'DeclareTest2: bar'; } $test_method1 = method { return join(', ', $self->{attr}, $_[1]); }; $test_method2 = method ($what) { return join(', ', ref $self, $what); }; method main () { return "main"; } @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); method leftie($left) : method { $self->{left} ||= $left; $self->{left} }; } my $o = DeclareTest->new(attr => "value"); isa_ok($o, 'DeclareTest'); is($o->{attr}, 'value', '@_ args ok'); is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); is($o->main, 'main', 'declaration of package named method ok'); $o->leftie( 'attributes work' ); is($o->leftie, 'attributes work', 'code attributes intact'); $o->upgrade; isa_ok($o, 'DeclareTest2'); is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); done_testing; Devel-Declare-0.006019/t/method-installer-redefine.t000644 000766 000024 00000001374 12477001527 022314 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 5; use Devel::Declare::MethodInstaller::Simple; BEGIN { Devel::Declare::MethodInstaller::Simple->install_methodhandler( name => 'method', into => 'main', ); } BEGIN { no warnings 'redefine'; Devel::Declare::MethodInstaller::Simple->install_methodhandler( name => 'method_quiet', into => 'main', ); } ok(!main->can('foo'), 'foo() not installed yet'); method foo { $_[0]->method } ok(main->can('foo'), 'foo() installed at runtime'); my @warnings; $SIG{__WARN__} = sub { push @warnings, $_[0] }; @warnings = (); method foo { $_[0]->method; } is scalar(@warnings), 1; like $warnings[0], qr/redefined/; @warnings = (); method_quiet foo { $_[0]->method; } is_deeply \@warnings, []; Devel-Declare-0.006019/t/method-installer-runtime.t000644 000766 000024 00000000551 12477001527 022212 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 2; use Devel::Declare::MethodInstaller::Simple; BEGIN { Devel::Declare::MethodInstaller::Simple->install_methodhandler( name => 'method', into => 'main', ); } ok(!main->can('foo'), 'foo() not installed yet'); method foo { $_[0]->method } ok(main->can('foo'), 'foo() installed at runtime'); Devel-Declare-0.006019/t/method-no-semi.t000644 000766 000024 00000010154 12637357463 020116 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare (); { package MethodHandlers; use strict; use warnings; use B::Hooks::EndOfScope; our ($Declarator, $Offset); sub skip_declarator { $Offset += Devel::Declare::toke_move_past_token($Offset); } sub skipspace { $Offset += Devel::Declare::toke_skipspace($Offset); } sub strip_name { skipspace; if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { my $linestr = Devel::Declare::get_linestr(); my $name = substr($linestr, $Offset, $len); substr($linestr, $Offset, $len) = ''; Devel::Declare::set_linestr($linestr); return $name; } return; } sub strip_proto { skipspace; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $Offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($Offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $Offset, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } return; } sub shadow { my $pack = Devel::Declare::get_curstash_name; Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); } # undef -> my ($self) = shift; # '' -> my ($self) = @_; # '$foo' -> my ($self, $foo) = @_; sub make_proto_unwrap { my ($proto) = @_; my $inject = 'my ($self'; if (defined $proto) { $inject .= ", $proto" if length($proto); $inject .= ') = @_; '; } else { $inject .= ') = shift;'; } return $inject; } sub inject_if_block { my $inject = shift; skipspace; my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, 1) eq '{') { substr($linestr, $Offset+1, 0) = $inject; Devel::Declare::set_linestr($linestr); } } sub scope_injector_call { return ' BEGIN { MethodHandlers::inject_scope }; '; } sub parser { local ($Declarator, $Offset) = @_; skip_declarator; my $name = strip_name; my $proto = strip_proto; my $inject = make_proto_unwrap($proto); if (defined $name) { $inject = scope_injector_call().$inject; } inject_if_block($inject); if (defined $name) { $name = join('::', Devel::Declare::get_curstash_name(), $name) unless ($name =~ /::/); shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); } else { shadow(sub (&) { shift }); } } sub inject_scope { on_scope_end { my $linestr = Devel::Declare::get_linestr; my $offset = Devel::Declare::get_linestr_offset; substr($linestr, $offset, 0) = ';'; Devel::Declare::set_linestr($linestr); }; } } my ($test_method1, $test_method2, @test_list); { package DeclareTest; sub method (&); BEGIN { Devel::Declare->setup_for( __PACKAGE__, { method => { const => \&MethodHandlers::parser } } ); } method new { my $class = ref $self || $self; return bless({ @_ }, $class); } method foo ($foo) { return (ref $self).': Foo: '.$foo; } method upgrade(){ # no spaces to make case pathological bless($self, 'DeclareTest2'); } method DeclareTest2::bar () { return 'DeclareTest2: bar'; } $test_method1 = method { return join(', ', $self->{attr}, $_[1]); }; $test_method2 = method ($what) { return join(', ', ref $self, $what); }; method main () { return "main"; } @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); } use Test::More 0.88; my $o = DeclareTest->new(attr => "value"); isa_ok($o, 'DeclareTest'); is($o->{attr}, 'value', '@_ args ok'); is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); is($o->main, 'main', 'declaration of package named method ok'); $o->upgrade; isa_ok($o, 'DeclareTest2'); is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); done_testing; Devel-Declare-0.006019/t/method.t000644 000766 000024 00000007255 12637357463 016561 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare (); { package MethodHandlers; use strict; use warnings; our ($Declarator, $Offset); sub skip_declarator { $Offset += Devel::Declare::toke_move_past_token($Offset); } sub skipspace { $Offset += Devel::Declare::toke_skipspace($Offset); } sub strip_name { skipspace; if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { my $linestr = Devel::Declare::get_linestr(); my $name = substr($linestr, $Offset, $len); substr($linestr, $Offset, $len) = ''; Devel::Declare::set_linestr($linestr); return $name; } return; } sub strip_proto { skipspace; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $Offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($Offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $Offset, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } return; } sub shadow { my $pack = Devel::Declare::get_curstash_name; Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); } # undef -> my ($self) = shift; # '' -> my ($self) = @_; # '$foo' -> my ($self, $foo) = @_; sub make_proto_unwrap { my ($proto) = @_; my $inject = 'my ($self'; if (defined $proto) { $inject .= ", $proto" if length($proto); $inject .= ') = @_; '; } else { $inject .= ') = shift;'; } return $inject; } sub inject_if_block { my $inject = shift; skipspace; my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, 1) eq '{') { substr($linestr, $Offset+1, 0) = $inject; Devel::Declare::set_linestr($linestr); } } sub parser { local ($Declarator, $Offset) = @_; skip_declarator; my $name = strip_name; my $proto = strip_proto; inject_if_block( make_proto_unwrap($proto) ); if (defined $name) { $name = join('::', Devel::Declare::get_curstash_name(), $name) unless ($name =~ /::/); shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); } else { shadow(sub (&) { shift }); } } } my ($test_method1, $test_method2, @test_list); { package DeclareTest; sub method (&); BEGIN { Devel::Declare->setup_for( __PACKAGE__, { method => { const => \&MethodHandlers::parser } } ); } method new { my $class = ref $self || $self; return bless({ @_ }, $class); }; method foo ($foo) { return (ref $self).': Foo: '.$foo; }; method upgrade(){ # no spaces to make case pathological bless($self, 'DeclareTest2'); }; method DeclareTest2::bar () { return 'DeclareTest2: bar'; }; $test_method1 = method { return join(', ', $self->{attr}, $_[1]); }; $test_method2 = method ($what) { return join(', ', ref $self, $what); }; method main () { return "main"; }; @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); } use Test::More 0.88; my $o = DeclareTest->new(attr => "value"); isa_ok($o, 'DeclareTest'); is($o->{attr}, 'value', '@_ args ok'); is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); is($o->main, 'main', 'declaration of package named method ok'); $o->upgrade; isa_ok($o, 'DeclareTest2'); is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); done_testing; Devel-Declare-0.006019/t/multiline-proto.t000644 000766 000024 00000000725 12477001527 020424 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 1; sub fun :lvalue { return my $sv; } sub handle_fun { my ($usepack, $use, $inpack, $name, $proto) = @_; my $XX = sub (&) { my $cr = $_[0]; return sub { return join(': ', $proto, $cr->()); }; }; return (undef, $XX); } use Devel::Declare; use Devel::Declare fun => [ DECLARE_PROTO, \&handle_fun ]; my $foo = fun ($a, $b) { "woot" }; is($foo->(), "\$a,\n\$b: woot", 'proto declarator ok'); Devel-Declare-0.006019/t/new.t000644 000766 000024 00000004620 12637357463 016063 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare (); use Test::More 0.88; { package FoomHandlers; use strict; use warnings; our ($Declarator, $Offset); sub skip_declarator { $Offset += Devel::Declare::toke_move_past_token($Offset); } sub skipspace { $Offset += Devel::Declare::toke_skipspace($Offset); } sub strip_name { skipspace; if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { my $linestr = Devel::Declare::get_linestr(); my $name = substr($linestr, $Offset, $len); substr($linestr, $Offset, $len) = ''; Devel::Declare::set_linestr($linestr); return $name; } return; } sub strip_proto { skipspace; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $Offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($Offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $Offset, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } return; } sub shadow { my $pack = Devel::Declare::get_curstash_name; Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); } sub inject_str { my $linestr = Devel::Declare::get_linestr; substr($linestr, $Offset, 0) = $_[0]; Devel::Declare::set_linestr($linestr); } sub strip_str { my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, length($_[0])) eq $_[0]) { substr($linestr, $Offset, length($_[0])) = ''; Devel::Declare::set_linestr($linestr); return 1; } return 0; } sub const { local ($Declarator, $Offset) = @_; skip_declarator; my $name = strip_name; my $str = "happy ".(defined $name ? "foom: ${name}" : "anonymous foom"); if (defined(my $proto = strip_proto)) { $str .= "; ${proto}"; } shadow(sub { $str }); } package Foo; use strict; use warnings; sub foom { } BEGIN { Devel::Declare->setup_for( __PACKAGE__, { foom => { const => \&FoomHandlers::const, } } ); } ::is(foom, "happy anonymous foom", "foom"); ::is(foom KABOOM, "happy foom: KABOOM", "foom KABOOM"); ::is(foom (zoom), "happy anonymous foom; zoom", "foom (zoom)"); ::is(foom KABOOM (zoom), "happy foom: KABOOM; zoom", "foom KABOOM (zoom)"); } done_testing; Devel-Declare-0.006019/t/no-bareword.t000644 000766 000024 00000000710 12637357463 017505 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; our $i; BEGIN { $i = 0 }; sub method { } BEGIN { require Devel::Declare; Devel::Declare->setup_for( __PACKAGE__, { "method" => { const => sub { $i++ } } }, ); } { package Foo; sub method { } } Foo->method; BEGIN { is($i, 0) } my @foo = ( method => 123 ); BEGIN { is($i, 0) } is_deeply(\@foo, ['method', '123']); done_testing; Devel-Declare-0.006019/t/pack.t000644 000766 000024 00000000743 12637357463 016212 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; sub class { $_[0]->(); } sub handle_class { my ($usepack, $use, $inpack, $name, $proto, $is_block) = @_; return (sub (&) { shift; }, undef, "package ${name};"); } use Devel::Declare; use Devel::Declare 'class' => [ DECLARE_PACKAGE, \&handle_class ]; my $packname; class Foo::Bar { $packname = __PACKAGE__; }; is($packname, 'Foo::Bar', 'Package saved ok'); is(__PACKAGE__, 'main', 'Package scoped correctly'); done_testing; Devel-Declare-0.006019/t/padstuff.t000644 000766 000024 00000000623 12637357463 017105 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; sub action (&) { return shift; } sub handle_action { return (undef, undef, 'my ($self, $c) = (shift, shift);'); } use Devel::Declare; use Devel::Declare action => [ DECLARE_NONE, \&handle_action ]; my $args; my $a = action { $args = join(', ', $self, $c); }; $a->("SELF", "CONTEXT"); is($args, "SELF, CONTEXT", "args passed ok"); done_testing; Devel-Declare-0.006019/t/proto.t000644 000766 000024 00000001025 12637357463 016431 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; sub fun :lvalue { return my $sv; } sub X { "what?" } sub handle_fun { my ($usepack, $use, $inpack, $name, $proto) = @_; my $XX = sub (&) { my $cr = $_[0]; return sub { return join(': ', $proto, $cr->()); }; }; return (undef, $XX); } use Devel::Declare; use Devel::Declare fun => [ DECLARE_PROTO, \&handle_fun ]; my $foo = fun ($a, $b) { "woot" }; is($foo->(), '$a, $b: woot', 'proto declarator ok'); is(X(), 'what?', 'X sub restored ok'); done_testing; Devel-Declare-0.006019/t/quote.t000644 000766 000024 00000002000 12477001527 016402 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More tests => 15; use Devel::Declare 'method' => sub {}; use File::Spec; sub test_eval; QUOTE: { test_eval 'qq/method/'; test_eval 'q/method/'; test_eval "'method'"; test_eval '"method"'; test_eval 'qw/method/'; test_eval '< 42 }'; } SYSTEM: { test_eval 'sub {`method`}'; # compiled to prevent calling arbitrary exe! test_eval 'sub { qx{method} }'; } REGEX: { local $_=''; # the passing results will act on $_ test_eval 'qr/method/'; test_eval '/method/'; test_eval 's/method//'; test_eval 'tr/method/METHOD/'; } FILE: { test_eval q{ no warnings 'reserved'; open method, '<', File::Spec->devnull }; test_eval ''; } sub test_eval { my $what = shift; eval $what; ok !$@, "$what" or d($@); } { my %seen; sub d { # diag the error the first time we get it my $err = shift; $err =~s/ at .*$//; $seen{$err}++ or diag $err; } } Devel-Declare-0.006019/t/scanstr.t000644 000766 000024 00000002502 12477001527 016731 0ustar00etherstaff000000 000000 use warnings; use strict; use Devel::Declare (); use Test::More tests => 10; sub my_quote($) { $_[0] } sub my_quote_parser { my($declarator, $offset) = @_; $offset += Devel::Declare::toke_move_past_token($offset); $offset += Devel::Declare::toke_skipspace($offset); my $len = Devel::Declare::toke_scan_str($offset); my $content = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); my $linestr = Devel::Declare::get_linestr(); die "surprising len=undef" if !defined($len); die "surprising len=$len" if $len <= 0; $content =~ s/(.)/sprintf("\\x{%x}", ord($1))/seg; substr $linestr, $offset, $len, "(\"$content\")"; Devel::Declare::set_linestr($linestr); } BEGIN { Devel::Declare->setup_for(__PACKAGE__, { my_quote => { const => \&my_quote_parser }, }); } my $x; $x = my_quote[foo]; is $x, "foo"; $x = my_quote[foo ]; is $x, "foo\n"; $x = my_quote[foo x]; is $x, "foo\nx"; $x = my_quote[foo xy]; is $x, "foo\nxy"; $x = my_quote[foo xyz]; is $x, "foo\nxyz"; $x = my_quote[foo bar baz quux]; is $x, "foo\nbar baz quux"; $x = my_quote[foo bar baz quuux]; is $x, "foo\nbar baz quuux"; $x = my_quote[foo bar baz quuuux]; is $x, "foo\nbar baz quuuux"; $x = my_quote[foo bar baz quux wibble]; is $x, "foo\nbar baz quux wibble"; $x = my_quote[foo quux womble]; is $x, "foo\nquux\nwomble"; 1; Devel-Declare-0.006019/t/scanstr_fail.t000644 000766 000024 00000001072 12477001527 017725 0ustar00etherstaff000000 000000 use warnings; use strict; use Devel::Declare (); use Test::More tests => 1; sub my_quote($) { $_[0] } sub my_quote_parser { my($declarator, $offset) = @_; $offset += Devel::Declare::toke_move_past_token($offset); $offset += Devel::Declare::toke_skipspace($offset); my $len = Devel::Declare::toke_scan_str($offset); die "suprising len=$len" if defined $len; die "toke_scan_str fail\n"; } BEGIN { Devel::Declare->setup_for(__PACKAGE__, { my_quote => { const => \&my_quote_parser }, }); } eval q{ my_quote[foo }; is $@, "toke_scan_str fail\n"; 1; Devel-Declare-0.006019/t/simple.t000644 000766 000024 00000001200 12637357463 016552 0ustar00etherstaff000000 000000 use strict; use warnings; use Test::More 0.88; sub method { my ($usepack, $name, $inpack, $sub) = @_; no strict 'refs'; *{"${inpack}::${name}"} = $sub; } sub handle_method { my ($usepack, $use, $inpack, $name) = @_; return sub (&) { ($usepack, $name, $inpack, $_[0]); }; } use Devel::Declare 'method' => \&handle_method; my ($args1, $args2); method bar { $args1 = join(', ', @_); }; method # blather baz # whee { # fweet $args2 = join(', ', @_); }; __PACKAGE__->bar(qw(1 2)); __PACKAGE__->baz(qw(3 4)); is($args1, 'main, 1, 2', 'Method bar args ok'); is($args2, 'main, 3, 4', 'Method baz args ok'); done_testing; Devel-Declare-0.006019/t/statement.t000644 000766 000024 00000005047 12637357463 017302 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare (); use Test::More 0.88; { package FoomHandlers; use strict; use warnings; use B::Hooks::EndOfScope; our ($Declarator, $Offset); sub skip_declarator { $Offset += Devel::Declare::toke_move_past_token($Offset); } sub skipspace { $Offset += Devel::Declare::toke_skipspace($Offset); } sub strip_name { skipspace; if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { my $linestr = Devel::Declare::get_linestr(); my $name = substr($linestr, $Offset, $len); substr($linestr, $Offset, $len) = ''; Devel::Declare::set_linestr($linestr); return $name; } return; } sub strip_proto { skipspace; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $Offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($Offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $Offset, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } return; } sub shadow { my $pack = Devel::Declare::get_curstash_name; Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); } sub inject_str { my $linestr = Devel::Declare::get_linestr; substr($linestr, $Offset, 0) = $_[0]; Devel::Declare::set_linestr($linestr); } sub strip_str { my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, length($_[0])) eq $_[0]) { substr($linestr, $Offset, length($_[0])) = ''; Devel::Declare::set_linestr($linestr); return 1; } return 0; } sub const { local ($Declarator, $Offset) = @_; skip_declarator; skipspace; my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, 1) eq '{') { substr($linestr, $Offset+1, 0) = ' BEGIN { FoomHandlers::inject_scope }; '; Devel::Declare::set_linestr($linestr); } shadow(sub (&) { "foom?" }); } sub inject_scope { on_scope_end { my $linestr = Devel::Declare::get_linestr; my $offset = Devel::Declare::get_linestr_offset; substr($linestr, $offset, 0) = ';'; Devel::Declare::set_linestr($linestr); }; } package Foo; use strict; use warnings; sub foom (&) { } BEGIN { Devel::Declare->setup_for( __PACKAGE__, { foom => { const => \&FoomHandlers::const, } } ); } foom { 1; } ::ok(1, 'Compiled as statement ok'); } done_testing; Devel-Declare-0.006019/t/sugar.t000644 000766 000024 00000003775 12637357463 016425 0ustar00etherstaff000000 000000 use strict; use warnings; use Devel::Declare; BEGIN { Devel::Declare->install_declarator( 'DeclareTest', 'method', DECLARE_PACKAGE | DECLARE_PROTO, sub { my ($name, $proto) = @_; #no warnings 'uninitialized'; #warn "NP: ".join(', ', @_)."\n"; return 'my $self = shift;' unless defined $proto && $proto ne '@_'; return 'my ($self'.(length $proto ? ", ${proto}" : "").') = @_;'; }, sub { my ($name, $proto, $sub, @rest) = @_; #no warnings 'uninitialized'; #warn "NPS: ".join(', ', @_)."\n"; if (defined $name && length $name) { unless ($name =~ /::/) { $name = "DeclareTest::${name}"; } no strict 'refs'; *{$name} = $sub; } return wantarray ? ($sub, @rest) : $sub; } ); } my ($test_method1, $test_method2, @test_list); { package DeclareTest; method new { my $class = ref $self || $self; return bless({ @_ }, $class); }; method foo ($foo) { return (ref $self).': Foo: '.$foo; }; method upgrade(){ # no spaces to make case pathological bless($self, 'DeclareTest2'); }; method DeclareTest2::bar () { return 'DeclareTest2: bar'; }; $test_method1 = method { return join(', ', $self->{attr}, $_[1]); }; $test_method2 = method ($what) { return join(', ', ref $self, $what); }; method main () { return "main"; }; #@test_list = method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }; } use Test::More 0.88; my $o = DeclareTest->new(attr => "value"); isa_ok($o, 'DeclareTest'); is($o->{attr}, 'value', '@_ args ok'); is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); is($o->main, 'main', 'declaration of package named method ok'); $o->upgrade; isa_ok($o, 'DeclareTest2'); is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); #warn map { $_->() } @test_list; done_testing; Devel-Declare-0.006019/maint/Makefile.PL.include000644 000766 000024 00000000556 12474520440 021334 0ustar00etherstaff000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar 0.001000; # so postamble is not stomped on author 'Matt S Trout - - original author'; manifest_include( 't/smells-of-vcs' => qr{.*}, 't' => '.pm', 't' => '.pl', '' => qr{stolen_chunk_of_toke\.c|Declare\.xs}, ); Devel-Declare-0.006019/maint/Makefile.include000644 000766 000024 00000000062 12474520440 021012 0ustar00etherstaff000000 000000 upload: $(DISTVNAME).tar$(SUFFIX) cpan-upload $< Devel-Declare-0.006019/lib/Devel/000700 000766 000024 00000000000 13066406135 016417 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/lib/Devel/Declare/000700 000766 000024 00000000000 13066406135 017756 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/lib/Devel/Declare.pm000644 000766 000024 00000052121 13066351473 020333 0ustar00etherstaff000000 000000 package Devel::Declare; # ABSTRACT: (DEPRECATED) Adding keywords to perl, in perl use strict; use warnings; use 5.008001; our $VERSION = '0.006019'; use constant DECLARE_NAME => 1; use constant DECLARE_PROTO => 2; use constant DECLARE_NONE => 4; use constant DECLARE_PACKAGE => 8+1; # name implicit use vars qw(%declarators %declarator_handlers @ISA); use base qw(DynaLoader); use Scalar::Util 'set_prototype'; use B::Hooks::OP::Check 0.19; bootstrap Devel::Declare; @ISA = (); initialize(); sub import { my ($class, %args) = @_; my $target = caller; if (@_ == 1) { # "use Devel::Declare;" no strict 'refs'; foreach my $name (qw(NAME PROTO NONE PACKAGE)) { *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"}; } } else { $class->setup_for($target => \%args); } } sub unimport { my ($class) = @_; my $target = caller; $class->teardown_for($target); } sub setup_for { my ($class, $target, $args) = @_; setup(); foreach my $key (keys %$args) { my $info = $args->{$key}; my ($flags, $sub); if (ref($info) eq 'ARRAY') { ($flags, $sub) = @$info; } elsif (ref($info) eq 'CODE') { $flags = DECLARE_NAME; $sub = $info; } elsif (ref($info) eq 'HASH') { $flags = 1; $sub = $info; } else { die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref"; } $declarators{$target}{$key} = $flags; $declarator_handlers{$target}{$key} = $sub; } } sub teardown_for { my ($class, $target) = @_; delete $declarators{$target}; delete $declarator_handlers{$target}; } my $temp_name; my $temp_save; sub init_declare { my ($usepack, $use, $inpack, $name, $proto, $traits) = @_; my ($name_h, $XX_h, $extra_code) = $declarator_handlers{$usepack}{$use}->( $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits ); ($temp_name, $temp_save) = ([], []); if ($name) { $name = "${inpack}::${name}" unless $name =~ /::/; shadow_sub($name, $name_h); } if ($XX_h) { shadow_sub("${inpack}::X", $XX_h); } if (defined wantarray) { return $extra_code || '0;'; } else { return; } } sub shadow_sub { my ($name, $cr) = @_; push(@$temp_name, $name); no strict 'refs'; my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/); push(@$temp_save, $pack->can($pname)); no warnings 'redefine'; no warnings 'prototype'; *{$name} = $cr; set_in_declare(~~@{$temp_name||[]}); } sub done_declare { no strict 'refs'; my $name = shift(@{$temp_name||[]}); die "done_declare called with no temp_name stack" unless defined($name); my $saved = shift(@$temp_save); $name =~ s/(.*):://; my $temp_pack = $1; delete ${"${temp_pack}::"}{$name}; if ($saved) { no warnings 'prototype'; *{"${temp_pack}::${name}"} = $saved; } set_in_declare(~~@{$temp_name||[]}); } sub build_sub_installer { my ($class, $pack, $name, $proto) = @_; return eval " package ${pack}; my \$body; sub ${name} (${proto}) :lvalue {\n" .' if (wantarray) { goto &$body; } my $ret = $body->(@_); return $ret; }; sub { ($body) = @_; };'; } sub setup_declarators { my ($class, $pack, $to_setup) = @_; die "${class}->setup_declarators(\$pack, \\\%to_setup)" unless defined($pack) && ref($to_setup) eq 'HASH'; my %setup_for_args; foreach my $name (keys %$to_setup) { my $info = $to_setup->{$name}; my $flags = $info->{flags} || DECLARE_NAME; my $run = $info->{run}; my $compile = $info->{compile}; my $proto = $info->{proto} || '&'; my $sub_proto = $proto; # make all args optional to enable lvalue for DECLARE_NONE $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto; #my $installer = $class->build_sub_installer($pack, $name, $proto); my $installer = $class->build_sub_installer($pack, $name, '@'); $installer->(sub :lvalue { #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; } if (@_) { if (ref $_[0] eq 'HASH') { shift; if (wantarray) { my @ret = $run->(undef, undef, @_); return @ret; } my $r = $run->(undef, undef, @_); return $r; } else { return @_[1..$#_]; } } return my $sv; }); $setup_for_args{$name} = [ $flags, sub { my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_; my $extra_code = $compile->($name, $proto, $traits); my $main_handler = sub { shift if $shift_hashref; ("DONE", $run->($name, $proto, @_)); }; my ($name_h, $XX); if (defined $proto) { $name_h = sub :lvalue { return my $sv; }; $XX = $main_handler; } elsif (defined $name && length $name) { $name_h = $main_handler; } $extra_code ||= ''; $extra_code = '}, sub {'.$extra_code; return ($name_h, $XX, $extra_code); } ]; } $class->setup_for($pack, \%setup_for_args); } sub install_declarator { my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_; $class->setup_declarators($target_pack, { $target_name => { flags => $flags, compile => $filter, run => $handler, } }); } sub linestr_callback_rv2cv { my ($name, $offset) = @_; $offset += toke_move_past_token($offset); my $pack = get_curstash_name(); my $flags = $declarators{$pack}{$name}; my ($found_name, $found_proto); if ($flags & DECLARE_NAME) { $offset += toke_skipspace($offset); my $linestr = get_linestr(); if (substr($linestr, $offset, 2) eq '::') { substr($linestr, $offset, 2) = ''; set_linestr($linestr); } if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { $found_name = substr($linestr, $offset, $len); $offset += $len; } } if ($flags & DECLARE_PROTO) { $offset += toke_skipspace($offset); my $linestr = get_linestr(); if (substr($linestr, $offset, 1) eq '(') { my $length = toke_scan_str($offset); $found_proto = get_lex_stuff(); clear_lex_stuff(); my $replace = ($found_name ? ' ' : '=') .'X'.(' ' x length($found_proto)); $linestr = get_linestr(); substr($linestr, $offset, $length) = $replace; set_linestr($linestr); $offset += $length; } } my @args = ($pack, $name, $pack, $found_name, $found_proto); $offset += toke_skipspace($offset); my $linestr = get_linestr(); if (substr($linestr, $offset, 1) eq '{') { my $ret = init_declare(@args); $offset++; if (defined $ret && length $ret) { substr($linestr, $offset, 0) = $ret; set_linestr($linestr); } } else { init_declare(@args); } #warn "linestr now ${linestr}"; } sub linestr_callback_const { my ($name, $offset) = @_; my $pack = get_curstash_name(); my $flags = $declarators{$pack}{$name}; if ($flags & DECLARE_NAME) { $offset += toke_move_past_token($offset); $offset += toke_skipspace($offset); if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { my $linestr = get_linestr(); substr($linestr, $offset, 0) = '::'; set_linestr($linestr); } } } sub linestr_callback { my $type = shift; my $name = $_[0]; my $pack = get_curstash_name(); my $handlers = $declarator_handlers{$pack}{$name}; if (ref $handlers eq 'CODE') { my $meth = "linestr_callback_${type}"; __PACKAGE__->can($meth)->(@_); } elsif (ref $handlers eq 'HASH') { if ($handlers->{$type}) { $handlers->{$type}->(@_); } } else { die "PANIC: unknown thing in handlers for $pack $name: $handlers"; } } =head1 NAME Devel::Declare - Adding keywords to perl, in perl =head1 SYNOPSIS use Method::Signatures; # or ... use MooseX::Declare; # etc. # Use some new and exciting syntax like: method hello (Str :$who, Int :$age where { $_ > 0 }) { $self->say("Hello ${who}, I am ${age} years old!"); } =head1 DESCRIPTION L can install subroutines called declarators which locally take over Perl's parser, allowing the creation of new syntax. This document describes how to create a simple declarator. =head1 WARNING =for comment mst wrote this warning for MooseX::Declare, and ether adapted it for here: B Devel::Declare is a giant bag of crack originally implemented by mst with the goal of upsetting the perl core developers so much by its very existence that they implemented proper keyword handling in the core. As of perl5 version 14, this goal has been achieved, and modules such as L, L, and L provide mechanisms to mangle perl syntax that don't require hallucinogenic drugs to interpret the error messages they produce. If you are using something that uses Devel::Declare, please for the love of kittens use something else: =over 4 =item * Instead of L, use L =item * Instead of L, use L (requires perl 5.22) or L =back =head1 USAGE We'll demonstrate the usage of C with a motivating example: a new C keyword, which acts like the builtin C, but automatically unpacks C<$self> and the other arguments. package My::Methods; use Devel::Declare; =head2 Creating a declarator with C You will typically create sub import { my $class = shift; my $caller = caller; Devel::Declare->setup_for( $caller, { method => { const => \&parser } } ); no strict 'refs'; *{$caller.'::method'} = sub (&) {}; } Starting from the end of this import routine, you'll see that we're creating a subroutine called C in the caller's namespace. Yes, that's just a normal subroutine, and it does nothing at all (yet!) Note the prototype C<(&)> which means that the caller would call it like so: method { my ($self, $arg1, $arg2) = @_; ... } However we want to be able to call it like this method foo ($arg1, $arg2) { ... } That's why we call C above, to register the declarator 'method' with a custom parser, as per the next section. It acts on an optype, usually C<'const'> as above. (Other valid values are C<'check'> and C<'rv2cv'>). For a simpler way to install new methods, see also L =head2 Writing a parser subroutine This subroutine is called at I time, and allows you to read the custom syntaxes that we want (in a syntax that may or may not be valid core Perl 5) and munge it so that the result will be parsed by the C compiler. For this example, we're defining some globals for convenience: our ($Declarator, $Offset); Then we define a parser subroutine to handle our declarator. We'll look at this in a few chunks. sub parser { local ($Declarator, $Offset) = @_; C provides some very low level utility methods to parse character strings. We'll define some useful higher level routines below for convenience, and we can use these to parse the various elements in our new syntax. Notice how our parser subroutine is invoked at compile time, when the C parser is pointed just I the declarator name. skip_declarator; # step past 'method' my $name = strip_name; # strip out the name 'foo', if present my $proto = strip_proto; # strip out the prototype '($arg1, $arg2)', if present Now we can prepare some code to 'inject' into the new subroutine. For example we might want the method as above to have C injected at the beginning of it. We also do some clever stuff with scopes that we'll look at shortly. my $inject = make_proto_unwrap($proto); if (defined $name) { $inject = scope_injector_call().$inject; } inject_if_block($inject); We've now managed to change C into C. This will compile... but we've lost the name of the method! In a cute (or horrifying, depending on your perspective) trick, we temporarily change the definition of the subroutine C itself, to specialise it with the C<$name> we stripped, so that it assigns the code block to that name. Even though the I time C is compiled, it will be redefined again, C caches these definitions in its parse tree, so we'll always get the right one! Note that we also handle the case where there was no name, allowing an anonymous method analogous to an anonymous subroutine. if (defined $name) { $name = join('::', Devel::Declare::get_curstash_name(), $name) unless ($name =~ /::/); shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); } else { shadow(sub (&) { shift }); } } =head2 Parser utilities in detail For simplicity, we're using global variables like C<$Offset> in these examples. You may prefer to look at L, which encapsulates the context much more cleanly. =head3 C This simple parser just moves across a 'token'. The common case is to skip the declarator, i.e. to move to the end of the string 'method' and before the prototype and code block. sub skip_declarator { $Offset += Devel::Declare::toke_move_past_token($Offset); } =head4 C This builtin parser simply moves past a 'token' (matching C) It takes an offset into the source document, and skips past the token. It returns the number of characters skipped. =head3 C This parser skips any whitespace, then scans the next word (again matching a 'token'). We can then analyse the current line, and manipulate it (using pure Perl). In this case we take the name of the method out, and return it. sub strip_name { skipspace; if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { my $linestr = Devel::Declare::get_linestr(); my $name = substr($linestr, $Offset, $len); substr($linestr, $Offset, $len) = ''; Devel::Declare::set_linestr($linestr); return $name; } return; } =head4 C This builtin parser, given an offset into the source document, matches a 'token' as above but does not skip. It returns the length of the token matched, if any. =head4 C This builtin returns the full text of the current line of the source document. =head4 C This builtin sets the full text of the current line of the source document. Beware that injecting a newline into the middle of the line is likely to fail in surprising ways. Generally, Perl's parser can rely on the `current line' actually being only a single line. Use other kinds of whitespace instead, in the code that you inject. =head3 C This parser skips whitsepace. sub skipspace { $Offset += Devel::Declare::toke_skipspace($Offset); } =head4 C This builtin parser, given an offset into the source document, skips over any whitespace, and returns the number of characters skipped. =head3 C This is a more complex parser that checks if it's found something that starts with C<'('> and returns everything till the matching C<')'>. sub strip_proto { skipspace; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $Offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($Offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $Offset, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } return; } =head4 C This builtin parser uses Perl's own parsing routines to match a "stringlike" expression. Handily, this includes bracketed expressions (just think about things like C). Also it Does The Right Thing with nested delimiters (like C). It returns the effective length of the expression matched. Really, what it returns is the difference in position between where the string started, within the buffer, and where it finished. If the string extended across multiple lines then the contents of the buffer may have been completely replaced by the new lines, so this position difference is not the same thing as the actual length of the expression matched. However, because moving backward in the buffer causes problems, the function arranges for the effective length to always be positive, padding the start of the buffer if necessary. Use C to get the actual matched text, the content of the string. Because of the behaviour around multiline strings, you can't reliably get this from the buffer. In fact, after the function returns, you can't rely on any content of the buffer preceding the end of the string. If the string being scanned is not well formed (has no closing delimiter), C returns C. In this case you cannot rely on the contents of the buffer. =head4 C This builtin returns what was matched by C. To avoid segfaults, you should call C immediately afterwards. =head2 Munging the subroutine Let's look at what we need to do in detail. =head3 C We may have defined our method in different ways, which will result in a different value for our prototype, as parsed above. For example: method foo { # undefined method foo () { # '' method foo ($arg1) { # '$arg1' We deal with them as follows, and return the appropriate C string. sub make_proto_unwrap { my ($proto) = @_; my $inject = 'my ($self'; if (defined $proto) { $inject .= ", $proto" if length($proto); $inject .= ') = @_; '; } else { $inject .= ') = shift;'; } return $inject; } =head3 C Now we need to inject it after the opening C<'{'> of the method body. We can do this with the building blocks we defined above like C and C. sub inject_if_block { my $inject = shift; skipspace; my $linestr = Devel::Declare::get_linestr; if (substr($linestr, $Offset, 1) eq '{') { substr($linestr, $Offset+1, 0) = $inject; Devel::Declare::set_linestr($linestr); } } =head3 C We want to be able to handle both named and anonymous methods. i.e. method foo () { ... } my $meth = method () { ... }; These will then get rewritten as method { ... } my $meth = method { ... }; where 'method' is a subroutine that takes a code block. Spot the problem? The first one doesn't have a semicolon at the end of it! Unlike 'sub' which is a builtin, this is just a normal statement, so we need to terminate it. Luckily, using C, we can do this! use B::Hooks::EndOfScope; We'll add this to what gets 'injected' at the beginning of the method source. sub scope_injector_call { return ' BEGIN { MethodHandlers::inject_scope }; '; } So at the beginning of every method, we are passing a callback that will get invoked at the I of the method's compilation... i.e. exactly then the closing C<'}'> is compiled. sub inject_scope { on_scope_end { my $linestr = Devel::Declare::get_linestr; my $offset = Devel::Declare::get_linestr_offset; substr($linestr, $offset, 0) = ';'; Devel::Declare::set_linestr($linestr); }; } =head2 Shadowing each method. =head3 C We override the current definition of 'method' using C. sub shadow { my $pack = Devel::Declare::get_curstash_name; Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); } For a named method we invoked like this: shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); So in the case of a C, this call would redefine C to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>. The case of an anonymous method is also cute: shadow(sub (&) { shift }); This means that my $meth = method () { ... }; is rewritten with C taking the codeblock, and returning it as is to become the value of C<$meth>. =head4 C This returns the package name I. =head4 C Handles the details of redefining the subroutine. =head1 SEE ALSO One of the best ways to learn C is still to look at modules that use it: L. =head1 AUTHORS Matt S Trout - Emst@shadowcat.co.ukE - original author Company: http://www.shadowcat.co.uk/ Blog: http://chainsawblues.vox.com/ Florian Ragwitz Erafl@debian.orgE - maintainer osfameron Eosfameron@cpan.orgE - first draft of documentation =head1 COPYRIGHT AND LICENSE This library is free software under the same terms as perl itself Copyright (c) 2007, 2008, 2009 Matt S Trout Copyright (c) 2008, 2009 Florian Ragwitz stolen_chunk_of_toke.c based on toke.c from the perl core, which is Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others =cut 1; Devel-Declare-0.006019/lib/Devel/Declare/Context/000700 000766 000024 00000000000 13066406135 021402 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/lib/Devel/Declare/MethodInstaller/000700 000766 000024 00000000000 13066406135 023054 5ustar00etherstaff000000 000000 Devel-Declare-0.006019/lib/Devel/Declare/MethodInstaller/Simple.pm000644 000766 000024 00000003327 12760713137 024665 0ustar00etherstaff000000 000000 package Devel::Declare::MethodInstaller::Simple; use base 'Devel::Declare::Context::Simple'; use Devel::Declare (); use Sub::Name; use strict; use warnings; our $VERSION = '0.006019'; sub install_methodhandler { my $class = shift; my %args = @_; { no strict 'refs'; *{$args{into}.'::'.$args{name}} = sub (&) {}; } my $warnings = warnings::enabled("redefine"); my $ctx = $class->new(%args); Devel::Declare->setup_for( $args{into}, { $args{name} => { const => sub { $ctx->parser(@_, $warnings) } } } ); } sub code_for { my ($self, $name) = @_; if (defined $name) { my $pkg = $self->get_curstash_name; $name = join( '::', $pkg, $name ) unless( $name =~ /::/ ); return sub (&) { my $code = shift; # So caller() gets the subroutine name no strict 'refs'; my $installer = $self->warning_on_redefine ? sub { *{$name} = subname $name => $code; } : sub { no warnings 'redefine'; *{$name} = subname $name => $code; }; $installer->(); return; }; } else { return sub (&) { shift }; } } sub install { my ($self, $name ) = @_; $self->shadow( $self->code_for($name) ); } sub parser { my $self = shift; $self->init(@_); $self->skip_declarator; my $name = $self->strip_name; my $proto = $self->strip_proto; my $attrs = $self->strip_attrs; my @decl = $self->parse_proto($proto); my $inject = $self->inject_parsed_proto(@decl); if (defined $name) { $inject = $self->scope_injector_call() . $inject; } $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : ''); $self->install( $name ); return; } sub parse_proto { '' } sub inject_parsed_proto { return $_[1]; } 1; Devel-Declare-0.006019/lib/Devel/Declare/Context/Simple.pm000644 000766 000024 00000016061 12760713137 023212 0ustar00etherstaff000000 000000 package Devel::Declare::Context::Simple; use strict; use warnings; use Devel::Declare (); use B::Hooks::EndOfScope; use Carp qw/confess/; our $VERSION = '0.006019'; sub new { my $class = shift; bless {@_}, $class; } sub init { my $self = shift; @{$self}{ qw(Declarator Offset WarningOnRedefined) } = @_; return $self; } sub offset { my $self = shift; return $self->{Offset} } sub inc_offset { my $self = shift; $self->{Offset} += shift; } sub declarator { my $self = shift; return $self->{Declarator} } sub warning_on_redefine { my $self = shift; return $self->{WarningOnRedefined} } sub skip_declarator { my $self = shift; my $decl = $self->declarator; my $len = Devel::Declare::toke_scan_word($self->offset, 0); confess "Couldn't find declarator '$decl'" unless $len; my $linestr = $self->get_linestr; my $name = substr($linestr, $self->offset, $len); confess "Expected declarator '$decl', got '${name}'" unless $name eq $decl; $self->inc_offset($len); } sub skipspace { my $self = shift; $self->inc_offset(Devel::Declare::toke_skipspace($self->offset)); } sub get_linestr { my $self = shift; my $line = Devel::Declare::get_linestr(); return $line; } sub set_linestr { my $self = shift; my ($line) = @_; Devel::Declare::set_linestr($line); } sub strip_name { my $self = shift; $self->skipspace; if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) { my $linestr = $self->get_linestr(); my $name = substr( $linestr, $self->offset, $len ); substr( $linestr, $self->offset, $len ) = ''; $self->set_linestr($linestr); return $name; } $self->skipspace; return; } sub strip_ident { my $self = shift; $self->skipspace; if (my $len = Devel::Declare::toke_scan_ident( $self->offset )) { my $linestr = $self->get_linestr(); my $ident = substr( $linestr, $self->offset, $len ); substr( $linestr, $self->offset, $len ) = ''; $self->set_linestr($linestr); return $ident; } $self->skipspace; return; } sub strip_proto { my $self = shift; $self->skipspace; my $linestr = $self->get_linestr(); if (substr($linestr, $self->offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($self->offset); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = $self->get_linestr(); substr($linestr, $self->offset, defined($length) ? $length : length($linestr)) = ''; $self->set_linestr($linestr); return $proto; } return; } sub strip_names_and_args { my $self = shift; $self->skipspace; my @args; my $linestr = $self->get_linestr; if (substr($linestr, $self->offset, 1) eq '(') { # We had a leading paren, so we will now expect comma separated # arguments substr($linestr, $self->offset, 1) = ''; $self->set_linestr($linestr); $self->skipspace; # At this point we expect to have a comma-separated list of # barewords with optional protos afterward, so loop until we # run out of comma-separated values while (1) { # Get the bareword my $thing = $self->strip_name; # If there's no bareword here, bail confess "failed to parse bareword. found ${linestr}" unless defined $thing; $linestr = $self->get_linestr; if (substr($linestr, $self->offset, 1) eq '(') { # This one had a proto, pull it out push(@args, [ $thing, $self->strip_proto ]); } else { # This had no proto, so store it with an undef push(@args, [ $thing, undef ]); } $self->skipspace; $linestr = $self->get_linestr; if (substr($linestr, $self->offset, 1) eq ',') { # We found a comma, strip it out and set things up for # another iteration substr($linestr, $self->offset, 1) = ''; $self->set_linestr($linestr); $self->skipspace; } else { # No comma, get outta here last; } } # look for the final closing paren of the list if (substr($linestr, $self->offset, 1) eq ')') { substr($linestr, $self->offset, 1) = ''; $self->set_linestr($linestr); $self->skipspace; } else { # fail if it isn't there confess "couldn't find closing paren for argument. found ${linestr}" } } else { # No parens, so expect a single arg my $thing = $self->strip_name; # If there's no bareword here, bail confess "failed to parse bareword. found ${linestr}" unless defined $thing; $linestr = $self->get_linestr; if (substr($linestr, $self->offset, 1) eq '(') { # This one had a proto, pull it out push(@args, [ $thing, $self->strip_proto ]); } else { # This had no proto, so store it with an undef push(@args, [ $thing, undef ]); } } return \@args; } sub strip_attrs { my $self = shift; $self->skipspace; my $linestr = Devel::Declare::get_linestr; my $attrs = ''; if (substr($linestr, $self->offset, 1) eq ':') { while (substr($linestr, $self->offset, 1) ne '{') { if (substr($linestr, $self->offset, 1) eq ':') { substr($linestr, $self->offset, 1) = ''; Devel::Declare::set_linestr($linestr); $attrs .= ':'; } $self->skipspace; $linestr = Devel::Declare::get_linestr(); if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) { my $name = substr($linestr, $self->offset, $len); substr($linestr, $self->offset, $len) = ''; Devel::Declare::set_linestr($linestr); $attrs .= " ${name}"; if (substr($linestr, $self->offset, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($self->offset); my $arg = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); substr($linestr, $self->offset, $length) = ''; Devel::Declare::set_linestr($linestr); $attrs .= "(${arg})"; } } } $linestr = Devel::Declare::get_linestr(); } return $attrs; } sub get_curstash_name { return Devel::Declare::get_curstash_name; } sub shadow { my $self = shift; my $pack = $self->get_curstash_name; Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] ); } sub inject_if_block { my $self = shift; my $inject = shift; my $before = shift || ''; $self->skipspace; my $linestr = $self->get_linestr; if (substr($linestr, $self->offset, 1) eq '{') { substr($linestr, $self->offset + 1, 0) = $inject; substr($linestr, $self->offset, 0) = $before; $self->set_linestr($linestr); return 1; } return 0; } sub scope_injector_call { my $self = shift; my $inject = shift || ''; return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; "; } sub inject_scope { my $class = shift; my $inject = shift; on_scope_end { my $linestr = Devel::Declare::get_linestr; return unless defined $linestr; my $offset = Devel::Declare::get_linestr_offset; substr( $linestr, $offset, 0 ) = ';' . $inject; Devel::Declare::set_linestr($linestr); }; } 1; # vi:sw=2 ts=2