From: Matt S Trout Date: Thu, 28 Jun 2007 20:18:47 +0000 (+0000) Subject: initial import, still fragile as all hell X-Git-Tag: 0.005000~142 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=94caac6e9e3af7e002f7eef2bed2e2bf2bb6d2a8;p=p5sagit%2FDevel-Declare.git initial import, still fragile as all hell --- 94caac6e9e3af7e002f7eef2bed2e2bf2bb6d2a8 diff --git a/Declare.xs b/Declare.xs new file mode 100644 index 0000000..d513b9a --- /dev/null +++ b/Declare.xs @@ -0,0 +1,127 @@ +#define PERL_DECL_PROT +#define PERL_CORE +#define PERL_NO_GET_CONTEXT +#include "/home/matthewt/tmp/perl-5.8.8/toke.c" +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#undef printf +#include +#include + +#define LEX_NORMAL 10 +#define LEX_INTERPNORMAL 9 + +/* placeholders for PL_check entries we wrap */ + +STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op); +STATIC OP *(*dd_old_ck_nextstate)(pTHX_ OP *op); + +/* flag to trigger removal of temporary declaree sub */ + +static int in_declare = 0; + +/* replacement PL_check rv2cv entry */ + +STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) { + OP* kid; + char* s; + char tmpbuf[sizeof PL_tokenbuf]; + STRLEN len; + HV *stash; + HV* is_declarator; + SV** is_declarator_pack_ref; + HV* is_declarator_pack_hash; + SV** is_declarator_flag_ref; + char* cb_args[4]; + + o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */ + + if (in_declare) { + cb_args[0] = NULL; + call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args); + in_declare = 0; + return o; + } + + kid = cUNOPo->op_first; + + if (kid->op_type != OP_GV) /* not a GV so ignore */ + return o; + + if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL) + return o; /* not lexing? */ + + stash = GvSTASH(kGVOP_gv); + + /* printf("Checking GV %s -> %s\n", HvNAME(stash), GvNAME(kGVOP_gv)); */ + + is_declarator = get_hv("Devel::Declare::declarators", FALSE); + + if (!is_declarator) + return o; + + is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(stash), + strlen(HvNAME(stash)), FALSE); + + if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref)) + return o; /* not a hashref */ + + is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref); + + is_declarator_flag_ref = hv_fetch(is_declarator_pack_hash, GvNAME(kGVOP_gv), + strlen(GvNAME(kGVOP_gv)), FALSE); + + if (!is_declarator_flag_ref || !SvTRUE(*is_declarator_flag_ref)) + return o; + + s = PL_bufptr; /* copy the current buffer pointer */ + + while (s < PL_bufend && isSPACE(*s)) s++; + if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf))) + s += strlen(PL_tokenbuf); + else + return o; + + /* find next word */ + + s = skipspace(s); + + /* 0 in arg 4 is allow_package - not trying that yet :) */ + + s = scan_word(s, tmpbuf, sizeof tmpbuf, 0, &len); + + if (len) { + cb_args[0] = HvNAME(stash); + cb_args[1] = GvNAME(kGVOP_gv); + cb_args[2] = tmpbuf; + cb_args[3] = NULL; + call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args); + in_declare = 1; + } + + return o; +} + +static int initialized = 0; + +MODULE = Devel::Declare PACKAGE = Devel::Declare + +PROTOTYPES: DISABLE + +void +setup() + CODE: + if (!initialized++) { + dd_old_ck_rv2cv = PL_check[OP_RV2CV]; + PL_check[OP_RV2CV] = dd_ck_rv2cv; + } + +void +teardown() + CODE: + /* ensure we only uninit when number of teardown calls matches + number of setup calls */ + if (initialized && !--initialized) { + PL_check[OP_RV2CV] = dd_old_ck_rv2cv; + } diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..09df2f6 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,12 @@ +use inc::Module::Install 0.67; + +name 'Devel-Declare'; +all_from 'lib/Devel/Declare.pm'; + +build_requires 'Test::More'; + +WriteMakefile( + dist => { + PREOP => 'pod2text lib/Devel/Declare.pm >$(DISTVNAME)/README' + } +); diff --git a/lib/Devel/Declare.pm b/lib/Devel/Declare.pm new file mode 100644 index 0000000..01bb7d7 --- /dev/null +++ b/lib/Devel/Declare.pm @@ -0,0 +1,101 @@ +package Devel::Declare; + +use strict; +use warnings; +use 5.008001; + +our $VERSION = 0.001000; + +use vars qw(%declarators); +use base qw(DynaLoader); + +bootstrap Devel::Declare; + +sub import { + my ($class, @args) = @_; + my $target = caller; + $class->setup_for($target => \@args); +} + +sub unimport { + my ($class) = @_; + my $target = caller; + $class->teardown_for($target); +} + +sub setup_for { + my ($class, $target, $args) = @_; + setup(); + $declarators{$target}{$_} = 1 for @$args; +} + +sub teardown_for { + my ($class, $target) = @_; + delete $declarators{$target}; + teardown(); +} + +my $temp_pack; +my $temp_name; + +sub init_declare { + my ($pack, $use, $name) = @_; + no strict 'refs'; + *{"${pack}::${name}"} = sub (&) { ($pack, $name, $_[0]); }; + ($temp_pack, $temp_name) = ($pack, $name); +} + +sub done_declare { + no strict 'refs'; + delete ${"${temp_pack}::"}{$temp_name}; +} + +=head1 NAME + +Devel::Declare - + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head2 import + + use Devel::Declare qw(list of subs); + +Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs); + +=head2 unimport + + no Devel::Declare; + +Calls Devel::Declare->teardown_for(__PACKAGE__); + +=head2 setup_for + + Devel::Declare->setup_for($package => \@subnames); + +Installs declarator magic (unless already installed) and registers +"${package}::$name" for each member of @subnames + +=head2 teardown_for + + Devel::Declare->teardown_for($package); + +Deregisters all subs currently registered for $package and uninstalls +declarator magic if number of teardown_for calls matches number of setup_for +calls. + +=head1 AUTHOR + +Matt S Trout - + +Company: http://www.shadowcatsystems.co.uk/ +Blog: http://chainsawblues.vox.com/ + +=head1 LICENSE + +This library is free software under the same terms as perl itself + +=cut + +1; diff --git a/t/simple.t b/t/simple.t new file mode 100644 index 0000000..266bb8b --- /dev/null +++ b/t/simple.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +print "1..1\n"; + +sub method { + my ($pack, $name, $sub) = @_; + no strict 'refs'; + *{"${pack}::${name}"} = $sub; +} + +use Devel::Declare 'method'; + +method bar { + my $str = join(', ', @_); + if ($str eq 'main, baz, quux') { + print "ok 1\n"; + } else { + print "not ok 1\n"; + } +}; + +__PACKAGE__->bar(qw(baz quux));