Import Upstream version 0.006022
This commit is contained in:
zhangyichun
commit
f1ae09397b
|
|
@ -0,0 +1,272 @@
|
|||
Revision history for Devel-Declare
|
||||
|
||||
0.006022 - 2020-04-26
|
||||
- release 0.006_021 as stable
|
||||
|
||||
0.006_021 - 2019-12-22
|
||||
- use ppport.h for compatibility with earlier perls
|
||||
|
||||
0.006_020 - 2019-11-25
|
||||
- update to work with Perl 5.31.7 (Karl Williamson, github PR#1)
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,666 @@
|
|||
#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 <stdio.h>
|
||||
#include <string.h>
|
||||
|
||||
#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;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,374 @@
|
|||
Terms of the Perl programming language system itself
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
b) the "Artistic License"
|
||||
|
||||
--- The GNU General Public License, Version 1, February 1989 ---
|
||||
|
||||
This software is Copyright (c) 2020 by Matt S Trout - <mst@shadowcat.co.uk> - original author.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The GNU General Public License, Version 1, February 1989
|
||||
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
Version 1, February 1989
|
||||
|
||||
Copyright (C) 1989 Free Software Foundation, Inc.
|
||||
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
Preamble
|
||||
|
||||
The license agreements of most software companies try to keep users
|
||||
at the mercy of those companies. By contrast, our General Public
|
||||
License is intended to guarantee your freedom to share and change free
|
||||
software--to make sure the software is free for all its users. The
|
||||
General Public License applies to the Free Software Foundation's
|
||||
software and to any other program whose authors commit to using it.
|
||||
You can use it for your programs, too.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Specifically, the General Public License is designed to make
|
||||
sure that you have the freedom to give away or sell copies of free
|
||||
software, that you receive source code or can get it if you want it,
|
||||
that you can change the software or use pieces of it in new free
|
||||
programs; and that you know you can do these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
anyone to deny you these rights or to ask you to surrender the rights.
|
||||
These restrictions translate to certain responsibilities for you if you
|
||||
distribute copies of the software, or if you modify it.
|
||||
|
||||
For example, if you distribute copies of a such a program, whether
|
||||
gratis or for a fee, you must give the recipients all the rights that
|
||||
you have. You must make sure that they, too, receive or can get the
|
||||
source code. And you must tell them their rights.
|
||||
|
||||
We protect your rights with two steps: (1) copyright the software, and
|
||||
(2) offer you this license which gives you legal permission to copy,
|
||||
distribute and/or modify the software.
|
||||
|
||||
Also, for each author's protection and ours, we want to make certain
|
||||
that everyone understands that there is no warranty for this free
|
||||
software. If the software is modified by someone else and passed on, we
|
||||
want its recipients to know that what they have is not the original, so
|
||||
that any problems introduced by others will not reflect on the original
|
||||
authors' reputations.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow.
|
||||
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any program or other work which
|
||||
contains a notice placed by the copyright holder saying it may be
|
||||
distributed under the terms of this General Public License. The
|
||||
"Program", below, refers to any such program or work, and a "work based
|
||||
on the Program" means either the Program or any work containing the
|
||||
Program or a portion of it, either verbatim or with modifications. Each
|
||||
licensee is addressed as "you".
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Program's source
|
||||
code as you receive it, in any medium, provided that you conspicuously and
|
||||
appropriately publish on each copy an appropriate copyright notice and
|
||||
disclaimer of warranty; keep intact all the notices that refer to this
|
||||
General Public License and to the absence of any warranty; and give any
|
||||
other recipients of the Program a copy of this General Public License
|
||||
along with the Program. You may charge a fee for the physical act of
|
||||
transferring a copy.
|
||||
|
||||
2. You may modify your copy or copies of the Program or any portion of
|
||||
it, and copy and distribute such modifications under the terms of Paragraph
|
||||
1 above, provided that you also do the following:
|
||||
|
||||
a) cause the modified files to carry prominent notices stating that
|
||||
you changed the files and the date of any change; and
|
||||
|
||||
b) cause the whole of any work that you distribute or publish, that
|
||||
in whole or in part contains the Program or any part thereof, either
|
||||
with or without modifications, to be licensed at no charge to all
|
||||
third parties under the terms of this General Public License (except
|
||||
that you may choose to grant warranty protection to some or all
|
||||
third parties, at your option).
|
||||
|
||||
c) If the modified program normally reads commands interactively when
|
||||
run, you must cause it, when started running for such interactive use
|
||||
in the simplest and most usual way, to print or display an
|
||||
announcement including an appropriate copyright notice and a notice
|
||||
that there is no warranty (or else, saying that you provide a
|
||||
warranty) and that users may redistribute the program under these
|
||||
conditions, and telling the user how to view a copy of this General
|
||||
Public License.
|
||||
|
||||
d) You may charge a fee for the physical act of transferring a
|
||||
copy, and you may at your option offer warranty protection in
|
||||
exchange for a fee.
|
||||
|
||||
Mere aggregation of another independent work with the Program (or its
|
||||
derivative) on a volume of a storage or distribution medium does not bring
|
||||
the other work under the scope of these terms.
|
||||
|
||||
3. You may copy and distribute the Program (or a portion or derivative of
|
||||
it, under Paragraph 2) in object code or executable form under the terms of
|
||||
Paragraphs 1 and 2 above provided that you also do one of the following:
|
||||
|
||||
a) accompany it with the complete corresponding machine-readable
|
||||
source code, which must be distributed under the terms of
|
||||
Paragraphs 1 and 2 above; or,
|
||||
|
||||
b) accompany it with a written offer, valid for at least three
|
||||
years, to give any third party free (except for a nominal charge
|
||||
for the cost of distribution) a complete machine-readable copy of the
|
||||
corresponding source code, to be distributed under the terms of
|
||||
Paragraphs 1 and 2 above; or,
|
||||
|
||||
c) accompany it with the information you received as to where the
|
||||
corresponding source code may be obtained. (This alternative is
|
||||
allowed only for noncommercial distribution and only if you
|
||||
received the program in object code or executable form alone.)
|
||||
|
||||
Source code for a work means the preferred form of the work for making
|
||||
modifications to it. For an executable file, complete source code means
|
||||
all the source code for all modules it contains; but, as a special
|
||||
exception, it need not include source code for modules which are standard
|
||||
libraries that accompany the operating system on which the executable
|
||||
file runs, or for standard header files or definitions files that
|
||||
accompany that operating system.
|
||||
|
||||
4. You may not copy, modify, sublicense, distribute or transfer the
|
||||
Program except as expressly provided under this General Public License.
|
||||
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
|
||||
the Program is void, and will automatically terminate your rights to use
|
||||
the Program under this License. However, parties who have received
|
||||
copies, or rights to use copies, from you under this General Public
|
||||
License will not have their licenses terminated so long as such parties
|
||||
remain in full compliance.
|
||||
|
||||
5. By copying, distributing or modifying the Program (or any work based
|
||||
on the Program) you indicate your acceptance of this license to do so,
|
||||
and all its terms and conditions.
|
||||
|
||||
6. Each time you redistribute the Program (or any work based on the
|
||||
Program), the recipient automatically receives a license from the original
|
||||
licensor to copy, distribute or modify the Program subject to these
|
||||
terms and conditions. You may not impose any further restrictions on the
|
||||
recipients' exercise of the rights granted herein.
|
||||
|
||||
7. The Free Software Foundation may publish revised and/or new versions
|
||||
of the General Public License from time to time. Such new versions will
|
||||
be similar in spirit to the present version, but may differ in detail to
|
||||
address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Program
|
||||
specifies a version number of the license which applies to it and "any
|
||||
later version", you have the option of following the terms and conditions
|
||||
either of that version or of any later version published by the Free
|
||||
Software Foundation. If the Program does not specify a version number of
|
||||
the license, you may choose any version ever published by the Free Software
|
||||
Foundation.
|
||||
|
||||
8. If you wish to incorporate parts of the Program into other free
|
||||
programs whose distribution conditions are different, write to the author
|
||||
to ask for permission. For software which is copyrighted by the Free
|
||||
Software Foundation, write to the Free Software Foundation; we sometimes
|
||||
make exceptions for this. Our decision will be guided by the two goals
|
||||
of preserving the free status of all derivatives of our free software and
|
||||
of promoting the sharing and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
|
||||
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
|
||||
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
|
||||
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
|
||||
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
|
||||
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
|
||||
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
|
||||
REPAIR OR CORRECTION.
|
||||
|
||||
10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
|
||||
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
|
||||
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
|
||||
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
|
||||
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
|
||||
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
|
||||
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
Appendix: How to Apply These Terms to Your New Programs
|
||||
|
||||
If you develop a new program, and you want it to be of the greatest
|
||||
possible use to humanity, the best way to achieve this is to make it
|
||||
free software which everyone can redistribute and change under these
|
||||
terms.
|
||||
|
||||
To do so, attach the following notices to the program. It is safest to
|
||||
attach them to the start of each source file to most effectively convey
|
||||
the exclusion of warranty; and each file should have at least the
|
||||
"copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the program's name and a brief idea of what it does.>
|
||||
Copyright (C) 19yy <name of author>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 1, or (at your option)
|
||||
any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
|
||||
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
If the program is interactive, make it output a short notice like this
|
||||
when it starts in an interactive mode:
|
||||
|
||||
Gnomovision version 69, Copyright (C) 19xx name of author
|
||||
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
|
||||
This is free software, and you are welcome to redistribute it
|
||||
under certain conditions; type `show c' for details.
|
||||
|
||||
The hypothetical commands `show w' and `show c' should show the
|
||||
appropriate parts of the General Public License. Of course, the
|
||||
commands you use may be called something other than `show w' and `show
|
||||
c'; they could even be mouse-clicks or menu items--whatever suits your
|
||||
program.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or your
|
||||
school, if any, to sign a "copyright disclaimer" for the program, if
|
||||
necessary. Here a sample; alter the names:
|
||||
|
||||
Yoyodyne, Inc., hereby disclaims all copyright interest in the
|
||||
program `Gnomovision' (a program to direct compilers to make passes
|
||||
at assemblers) written by James Hacker.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1989
|
||||
Ty Coon, President of Vice
|
||||
|
||||
That's all there is to it!
|
||||
|
||||
|
||||
--- The Artistic License 1.0 ---
|
||||
|
||||
This software is Copyright (c) 2020 by Matt S Trout - <mst@shadowcat.co.uk> - original author.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 1.0
|
||||
|
||||
The Artistic License
|
||||
|
||||
Preamble
|
||||
|
||||
The intent of this document is to state the conditions under which a Package
|
||||
may be copied, such that the Copyright Holder maintains some semblance of
|
||||
artistic control over the development of the package, while giving the users of
|
||||
the package the right to use and distribute the Package in a more-or-less
|
||||
customary fashion, plus the right to make reasonable modifications.
|
||||
|
||||
Definitions:
|
||||
|
||||
- "Package" refers to the collection of files distributed by the Copyright
|
||||
Holder, and derivatives of that collection of files created through
|
||||
textual modification.
|
||||
- "Standard Version" refers to such a Package if it has not been modified,
|
||||
or has been modified in accordance with the wishes of the Copyright
|
||||
Holder.
|
||||
- "Copyright Holder" is whoever is named in the copyright or copyrights for
|
||||
the package.
|
||||
- "You" is you, if you're thinking about copying or distributing this Package.
|
||||
- "Reasonable copying fee" is whatever you can justify on the basis of media
|
||||
cost, duplication charges, time of people involved, and so on. (You will
|
||||
not be required to justify it to the Copyright Holder, but only to the
|
||||
computing community at large as a market that must bear the fee.)
|
||||
- "Freely Available" means that no fee is charged for the item itself, though
|
||||
there may be fees involved in handling the item. It also means that
|
||||
recipients of the item may redistribute it under the same conditions they
|
||||
received it.
|
||||
|
||||
1. You may make and give away verbatim copies of the source form of the
|
||||
Standard Version of this Package without restriction, provided that you
|
||||
duplicate all of the original copyright notices and associated disclaimers.
|
||||
|
||||
2. You may apply bug fixes, portability fixes and other modifications derived
|
||||
from the Public Domain or from the Copyright Holder. A Package modified in such
|
||||
a way shall still be considered the Standard Version.
|
||||
|
||||
3. You may otherwise modify your copy of this Package in any way, provided that
|
||||
you insert a prominent notice in each changed file stating how and when you
|
||||
changed that file, and provided that you do at least ONE of the following:
|
||||
|
||||
a) place your modifications in the Public Domain or otherwise make them
|
||||
Freely Available, such as by posting said modifications to Usenet or an
|
||||
equivalent medium, or placing the modifications on a major archive site
|
||||
such as ftp.uu.net, or by allowing the Copyright Holder to include your
|
||||
modifications in the Standard Version of the Package.
|
||||
|
||||
b) use the modified Package only within your corporation or organization.
|
||||
|
||||
c) rename any non-standard executables so the names do not conflict with
|
||||
standard executables, which must also be provided, and provide a separate
|
||||
manual page for each non-standard executable that clearly documents how it
|
||||
differs from the Standard Version.
|
||||
|
||||
d) make other distribution arrangements with the Copyright Holder.
|
||||
|
||||
4. You may distribute the programs of this Package in object code or executable
|
||||
form, provided that you do at least ONE of the following:
|
||||
|
||||
a) distribute a Standard Version of the executables and library files,
|
||||
together with instructions (in the manual page or equivalent) on where to
|
||||
get the Standard Version.
|
||||
|
||||
b) accompany the distribution with the machine-readable source of the Package
|
||||
with your modifications.
|
||||
|
||||
c) accompany any non-standard executables with their corresponding Standard
|
||||
Version executables, giving the non-standard executables non-standard
|
||||
names, and clearly documenting the differences in manual pages (or
|
||||
equivalent), together with instructions on where to get the Standard
|
||||
Version.
|
||||
|
||||
d) make other distribution arrangements with the Copyright Holder.
|
||||
|
||||
5. You may charge a reasonable copying fee for any distribution of this
|
||||
Package. You may charge any fee you choose for support of this Package. You
|
||||
may not charge a fee for this Package itself. However, you may distribute this
|
||||
Package in aggregate with other (possibly commercial) programs as part of a
|
||||
larger (possibly commercial) software distribution provided that you do not
|
||||
advertise this Package as a product of your own.
|
||||
|
||||
6. The scripts and library files supplied as input to or produced as output
|
||||
from the programs of this Package do not automatically fall under the copyright
|
||||
of this Package, but belong to whomever generated them, and may be sold
|
||||
commercially, and may be aggregated with this Package.
|
||||
|
||||
7. C or perl subroutines supplied by you and linked into this Package shall not
|
||||
be considered part of this Package.
|
||||
|
||||
8. The name of the Copyright Holder may not be used to endorse or promote
|
||||
products derived from this software without specific prior written permission.
|
||||
|
||||
9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
The End
|
||||
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
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
|
||||
ppport.h
|
||||
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)
|
||||
LICENSE LICENSE file (added by Distar)
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
{
|
||||
"abstract" : "(DEPRECATED) Adding keywords to perl, in perl",
|
||||
"author" : [
|
||||
"Matt S Trout - <mst@shadowcat.co.uk> - original author"
|
||||
],
|
||||
"dynamic_config" : 0,
|
||||
"generated_by" : "ExtUtils::MakeMaker version 7.44, 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" : "https://github.com/p5sagit/Devel-Declare.git",
|
||||
"web" : "https://github.com/p5sagit/Devel-Declare"
|
||||
}
|
||||
},
|
||||
"version" : "0.006022",
|
||||
"x_contributors" : [
|
||||
"Florian Ragwitz <rafl@debian.org>",
|
||||
"Matt S Trout <mst@shadowcat.co.uk>",
|
||||
"Karen Etheridge <ether@cpan.org>",
|
||||
"Zefram <zefram@fysh.org>",
|
||||
"Rhesa Rozendaal <rhesa@cpan.org>",
|
||||
"Ash Berlin <ash@cpan.org>",
|
||||
"Chia-liang Kao <clkao@clkao.org>",
|
||||
"Marcus Ramberg <marcus@nordaaker.com>",
|
||||
"Christopher Nehren <apeiron@cpan.org>",
|
||||
"Yuval Kogman <nothingmuch@woobling.org>",
|
||||
"Cory Watson <gphat@cpan.org>",
|
||||
"Alexandr Ciornii <alexchorny@gmail.com>",
|
||||
"Father Chrysostomos <sprout@cpan.org>",
|
||||
"Graham Knop <haarg@haarg.org>",
|
||||
"Matthew Horsfall <WolfSage@cpan.org>",
|
||||
"Nick Perez <nperez@cpan.org>",
|
||||
"Yanick Champoux <yanick@babyl.dyndns.org>"
|
||||
],
|
||||
"x_deprecated" : 1,
|
||||
"x_serialization_backend" : "JSON::MaybeXS version 1.004"
|
||||
}
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
---
|
||||
abstract: '(DEPRECATED) Adding keywords to perl, in perl'
|
||||
author:
|
||||
- 'Matt S Trout - <mst@shadowcat.co.uk> - 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.44, 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: https://github.com/p5sagit/Devel-Declare.git
|
||||
version: '0.006022'
|
||||
x_contributors:
|
||||
- 'Florian Ragwitz <rafl@debian.org>'
|
||||
- 'Matt S Trout <mst@shadowcat.co.uk>'
|
||||
- 'Karen Etheridge <ether@cpan.org>'
|
||||
- 'Zefram <zefram@fysh.org>'
|
||||
- 'Rhesa Rozendaal <rhesa@cpan.org>'
|
||||
- 'Ash Berlin <ash@cpan.org>'
|
||||
- 'Chia-liang Kao <clkao@clkao.org>'
|
||||
- 'Marcus Ramberg <marcus@nordaaker.com>'
|
||||
- 'Christopher Nehren <apeiron@cpan.org>'
|
||||
- 'Yuval Kogman <nothingmuch@woobling.org>'
|
||||
- 'Cory Watson <gphat@cpan.org>'
|
||||
- 'Alexandr Ciornii <alexchorny@gmail.com>'
|
||||
- 'Father Chrysostomos <sprout@cpan.org>'
|
||||
- 'Graham Knop <haarg@haarg.org>'
|
||||
- 'Matthew Horsfall <WolfSage@cpan.org>'
|
||||
- 'Nick Perez <nperez@cpan.org>'
|
||||
- 'Yanick Champoux <yanick@babyl.dyndns.org>'
|
||||
x_deprecated: 1
|
||||
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
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 - <mst@shadowcat.co.uk> - 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 => {
|
||||
# GitHub mirrors from Shadowcat. We list it so we can get pull requests.
|
||||
# The canonical repo is:
|
||||
# r/o: git://git.shadowcat.co.uk/p5sagit/Devel-Declare.git
|
||||
# r/w: p5sagit@git.shadowcat.co.uk:Devel-Declare.git
|
||||
# web: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Devel-Declare.git
|
||||
repository => {
|
||||
url => 'https://github.com/p5sagit/Devel-Declare.git',
|
||||
web => 'https://github.com/p5sagit/Devel-Declare',
|
||||
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 <rafl@debian.org>',
|
||||
'Matt S Trout <mst@shadowcat.co.uk>',
|
||||
'Karen Etheridge <ether@cpan.org>',
|
||||
'Zefram <zefram@fysh.org>',
|
||||
'Rhesa Rozendaal <rhesa@cpan.org>',
|
||||
'Ash Berlin <ash@cpan.org>',
|
||||
'Chia-liang Kao <clkao@clkao.org>',
|
||||
'Marcus Ramberg <marcus@nordaaker.com>',
|
||||
'Christopher Nehren <apeiron@cpan.org>',
|
||||
'Yuval Kogman <nothingmuch@woobling.org>',
|
||||
'Cory Watson <gphat@cpan.org>',
|
||||
'Alexandr Ciornii <alexchorny@gmail.com>',
|
||||
'Father Chrysostomos <sprout@cpan.org>',
|
||||
'Graham Knop <haarg@haarg.org>',
|
||||
'Matthew Horsfall <WolfSage@cpan.org>',
|
||||
'Nick Perez <nperez@cpan.org>',
|
||||
'Yanick Champoux <yanick@babyl.dyndns.org>',
|
||||
],
|
||||
x_deprecated => 1,
|
||||
},
|
||||
|
||||
C => [ 'Declare.c' ],
|
||||
XS => { 'Declare.xs' => 'Declare.c' },
|
||||
depend => { '$(OBJECT)' => 'stolen_chunk_of_toke.c' },
|
||||
|
||||
$pkg->get_makefile_vars,
|
||||
);
|
||||
|
||||
|
|
@ -0,0 +1,406 @@
|
|||
NAME
|
||||
Devel::Declare - (DEPRECATED) 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:
|
||||
|
||||
<http://cpants.perl.org/dist/used_by/Devel-Declare>.
|
||||
|
||||
AUTHORS
|
||||
Matt S Trout - <mst@shadowcat.co.uk> - original author
|
||||
|
||||
Company: http://www.shadowcat.co.uk/ Blog: http://chainsawblues.vox.com/
|
||||
|
||||
Florian Ragwitz <rafl@debian.org> - maintainer
|
||||
|
||||
osfameron <osfameron@cpan.org> - 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
|
||||
|
||||
|
|
@ -0,0 +1,730 @@
|
|||
package Devel::Declare;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008001;
|
||||
|
||||
our $VERSION = '0.006022';
|
||||
|
||||
bootstrap Devel::Declare;
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
use constant DECLARE_NAME => 1;
|
||||
use constant DECLARE_PROTO => 2;
|
||||
use constant DECLARE_NONE => 4;
|
||||
use constant DECLARE_PACKAGE => 8+1; # name implicit
|
||||
|
||||
our (%declarators, %declarator_handlers, @ISA);
|
||||
use base qw(DynaLoader);
|
||||
use Scalar::Util 'set_prototype';
|
||||
use B::Hooks::OP::Check 0.19;
|
||||
|
||||
@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 - (DEPRECATED) 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<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.
|
||||
|
||||
=head1 WARNING
|
||||
|
||||
=for comment mst wrote this warning for MooseX::Declare, and ether adapted it for here:
|
||||
|
||||
B<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 L<Devel::CallParser>, L<Function::Parameters>, and L<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:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Instead of L<TryCatch>, use L<Try::Tiny>
|
||||
|
||||
=item *
|
||||
|
||||
Instead of L<Method::Signatures>, use
|
||||
L<real subroutine signatures|perlsub/Signatures> (requires perl 5.22) or L<Moops>
|
||||
|
||||
=back
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
We'll demonstrate the usage of C<Devel::Declare> with a motivating example: a new
|
||||
C<method> keyword, which acts like the builtin C<sub>, but automatically unpacks
|
||||
C<$self> and the other arguments.
|
||||
|
||||
package My::Methods;
|
||||
use Devel::Declare;
|
||||
|
||||
=head2 Creating a declarator with C<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 C<method> 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<setup_for> 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<Devel::Declare::MethodInstaller::Simple>
|
||||
|
||||
=head2 Writing a parser subroutine
|
||||
|
||||
This subroutine is called at I<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 C<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) = @_;
|
||||
|
||||
C<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 C<perl> parser is pointed just I<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 C<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 C<method ($arg1, $arg2) { ... }> into C<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 C<method> itself, to specialise it with
|
||||
the C<$name> we stripped, so that it assigns the code block to that name.
|
||||
|
||||
Even though the I<next> time C<method> is compiled, it will be
|
||||
redefined again, C<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 });
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=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<Devel::Declare::Context::Simple>, which
|
||||
encapsulates the context much more cleanly.
|
||||
|
||||
=head3 C<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);
|
||||
}
|
||||
|
||||
=head4 C<toke_move_past_token>
|
||||
|
||||
This builtin parser simply moves past a 'token' (matching C</[a-zA-Z_]\w*/>)
|
||||
It takes an offset into the source document, and skips past the token.
|
||||
It returns the number of characters skipped.
|
||||
|
||||
=head3 C<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;
|
||||
}
|
||||
|
||||
=head4 C<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.
|
||||
|
||||
=head4 C<get_linestr>
|
||||
|
||||
This builtin returns the full text of the current line of the source document.
|
||||
|
||||
=head4 C<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.
|
||||
|
||||
=head3 C<skipspace>
|
||||
|
||||
This parser skips whitsepace.
|
||||
|
||||
sub skipspace {
|
||||
$Offset += Devel::Declare::toke_skipspace($Offset);
|
||||
}
|
||||
|
||||
=head4 C<toke_skipspace>
|
||||
|
||||
This builtin parser, given an offset into the source document,
|
||||
skips over any whitespace, and returns the number of characters
|
||||
skipped.
|
||||
|
||||
=head3 C<strip_proto>
|
||||
|
||||
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<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 C<q(this is a quote)>).
|
||||
|
||||
Also it Does The Right Thing with nested delimiters (like C<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 C<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),
|
||||
C<toke_scan_str> returns C<undef>. In this case you cannot rely on the
|
||||
contents of the buffer.
|
||||
|
||||
=head4 C<get_lex_stuff>
|
||||
|
||||
This builtin returns what was matched by C<toke_scan_str>. To avoid segfaults,
|
||||
you should call C<clear_lex_stuff> immediately afterwards.
|
||||
|
||||
=head2 Munging the subroutine
|
||||
|
||||
Let's look at what we need to do in detail.
|
||||
|
||||
=head3 C<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 C<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;
|
||||
}
|
||||
|
||||
=head3 C<inject_if_block>
|
||||
|
||||
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<skipspace>
|
||||
and C<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);
|
||||
}
|
||||
}
|
||||
|
||||
=head3 C<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 C<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 I<end> 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<shadow>
|
||||
|
||||
We override the current definition of 'method' using C<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 C<method foo { ... }>, this call would redefine C<method>
|
||||
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<method> taking the codeblock, and returning it as is to become
|
||||
the value of C<$meth>.
|
||||
|
||||
=head4 C<get_curstash_name>
|
||||
|
||||
This returns the package name I<currently being compiled>.
|
||||
|
||||
=head4 C<shadow_sub>
|
||||
|
||||
Handles the details of redefining the subroutine.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
One of the best ways to learn C<Devel::Declare> is still to look at
|
||||
modules that use it:
|
||||
|
||||
L<http://cpants.perl.org/dist/used_by/Devel-Declare>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author
|
||||
|
||||
Company: http://www.shadowcat.co.uk/
|
||||
Blog: http://chainsawblues.vox.com/
|
||||
|
||||
Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer
|
||||
|
||||
osfameron E<lt>osfameron@cpan.orgE<gt> - 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;
|
||||
|
|
@ -0,0 +1,293 @@
|
|||
package Devel::Declare::Context::Simple;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Devel::Declare ();
|
||||
use B::Hooks::EndOfScope;
|
||||
use Carp qw/confess/;
|
||||
|
||||
our $VERSION = '0.006022';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
package Devel::Declare::MethodInstaller::Simple;
|
||||
|
||||
use base 'Devel::Declare::Context::Simple';
|
||||
|
||||
use Devel::Declare ();
|
||||
use Sub::Name;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.006022';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
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;
|
||||
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
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 - <mst@shadowcat.co.uk> - original author';
|
||||
|
||||
manifest_include(
|
||||
't/smells-of-vcs' => qr{.*},
|
||||
't' => '.pm',
|
||||
't' => '.pl',
|
||||
'' => qr{stolen_chunk_of_toke\.c|Declare\.xs|ppport.h},
|
||||
);
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
upload: $(DISTVNAME).tar$(SUFFIX)
|
||||
cpan-upload $<
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,8 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
use Test::More tests => 1;
|
||||
|
||||
BEGIN {
|
||||
$ENV{PERL_DL_NONLAZY} = 1;
|
||||
use_ok('Devel::Declare');
|
||||
}
|
||||
|
|
@ -0,0 +1,449 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,176 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
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 @{"_<t/debug.pl"};
|
||||
}
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More 0.88;
|
||||
|
||||
BEGIN {
|
||||
if("$]" eq "5.011002") {
|
||||
plan skip_all => "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;
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
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 {};
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
use Test::More tests => 1;
|
||||
use lib 't';
|
||||
use early1_x;
|
||||
class {};
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
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";
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
=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}";
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
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, [];
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
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');
|
||||
|
||||
|
|
@ -0,0 +1,183 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,167 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
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');
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
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 '<<method;
|
||||
tum ti tum
|
||||
method';
|
||||
test_eval 'my $x = { method => 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 '<method>';
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
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;
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
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;
|
||||
Loading…
Reference in New Issue