From: Vincent Pit Date: Fri, 1 Jan 2010 16:28:19 +0000 (+0100) Subject: Initial commit X-Git-Tag: v0.01~23 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a4ea0141e593c7b7afc86b15fb96d7f0ec5ab38a;p=perl%2Fmodules%2FSub-Op.git Initial commit --- a4ea0141e593c7b7afc86b15fb96d7f0ec5ab38a diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0d8ccef --- /dev/null +++ b/.gitignore @@ -0,0 +1,29 @@ +blib* +pm_to_blib* + +Makefile +Makefile.old +Build +_build* + +*.tar.gz +Sub-Op-* + +Files.pm + +core.* +*.[co] +*.so +*.bs +*.out +*.def +*.exp + +args.dat + +cover_db +*.gcda +*.gcov +*.gcno + +Debian_CPANTS.txt diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3764369 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,13 @@ +Changes +MANIFEST +Makefile.PL +META.yml +Op.xs +README +configure_test.pl +lib/Sub/Op.pm +sub_op.h +t/10-base.t +t/Sub-Op-Test/Makefile.PL +t/Sub-Op-Test/Test.xs +t/Sub-Op-Test/lib/Sub/Op/Test.pm diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..35a3059 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,100 @@ +use 5.010; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $dist = 'Sub-Op'; + +(my $name = $dist) =~ s{-}{::}g; + +(my $file = $dist) =~ s{-}{/}g; +$file = "lib/$file.pm"; + +my %PREREQ_PM = ( + 'B::Hooks::EndOfScope' => 0, + 'DynaLoader' => 0, + 'Variable::Magic' => '0.39', +); + +my %META = ( + configure_requires => { + 'ExtUtils::Depends' => 0, + 'ExtUtils::MakeMaker' => 0, + }, + build_requires => { + 'Cwd' => 0, + 'ExtUtils::Depends' => 0, + 'ExtUtils::MakeMaker' => 0, + 'File::Spec' => 0, + 'POSIX' => 0, + 'Test::More' => 0, + 'blib' => 0, + %PREREQ_PM, + }, + dynamic_config => 1, + resources => { + bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist", + homepage => "http://search.cpan.org/dist/$dist/", + license => 'http://dev.perl.org/licenses/', + repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", + }, +); + +use ExtUtils::Depends; + +my $ed = ExtUtils::Depends->new($name); +$ed->add_xs('Op.xs'); +$ed->add_pm($file => do { local $_ = $file; s/^lib/\$(INST_LIB)/; $_ }); +$ed->install('sub_op.h'); +$ed->save_config('Files.pm'); + +my %ed_vars = $ed->get_makefile_vars; +$ed_vars{clean}->{FILES} .= ' ' . join ' ', + "$dist-*", + 'Files.pm', + qw{*.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt}; + +WriteMakefile( + NAME => $name, + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => $file, +# ABSTRACT_FROM => $file, + PL_FILES => {}, + PREREQ_PM => \%PREREQ_PM, + MIN_PERL_VERSION => 5.010, + META_MERGE => \%META, + dist => { + PREOP => "pod2text $file > \$(DISTVNAME)/README", + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + FUNCLIST => [ qw/sub_op_register boot_Sub__Op/ ], + %ed_vars, +); + +{ + my $args_dat = './args.dat'; + + open my $fh, '>', $args_dat or die "open(>$args_dat): $!"; + for (@ARGV) { + my $arg = $_; + $arg =~ s{([^=/.a-zA-Z0-9-])}{sprintf "[%d]", ord $1}ge; + print $fh "$arg\n"; + } +} + +sub MY::postamble { + <<' POSTAMBLE'; +configure_test.pl: args.dat + +t/Sub-Op-Test/Makefile: configure_test.pl + $(FULLPERLRUN) configure_test.pl + +all clean:: t/Sub-Op-Test/Makefile + cd t/Sub-Op-Test && $(MAKE) $@ + +clean:: + $(RM_RF) args.dat + POSTAMBLE +} diff --git a/Op.xs b/Op.xs new file mode 100644 index 0000000..490dc2d --- /dev/null +++ b/Op.xs @@ -0,0 +1,373 @@ +/* This file is part of the Sub::Op Perl module. + * See http://search.cpan.org/dist/Sub-Op/ */ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define __PACKAGE__ "Sub::Op" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) + +/* --- Compatibility wrappers ---------------------------------------------- */ + +#define SO_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) + +/* ... Thread safety and multiplicity ...................................... */ + +#ifndef SO_MULTIPLICITY +# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# define SO_MULTIPLICITY 1 +# else +# define SO_MULTIPLICITY 0 +# endif +#endif +#if SO_MULTIPLICITY && !defined(tTHX) +# define tTHX PerlInterpreter* +#endif + +#if SO_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) +# define SO_THREADSAFE 1 +# ifndef MY_CXT_CLONE +# define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +# endif +#else +# define SO_THREADSAFE 0 +# undef dMY_CXT +# define dMY_CXT dNOOP +# undef MY_CXT +# define MY_CXT indirect_globaldata +# undef START_MY_CXT +# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# undef MY_CXT_INIT +# define MY_CXT_INIT NOOP +# undef MY_CXT_CLONE +# define MY_CXT_CLONE NOOP +#endif + +/* --- Global data --------------------------------------------------------- */ + +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION + +typedef struct { + HV *map; + AV *next_pkg; + AV *next_name; + CV *placeholder; +#if SO_THREADSAFE + tTHX owner; +#endif /* SO_THREADSAFE */ +} my_cxt_t; + +START_MY_CXT + +#if SO_THREADSAFE + +STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) { +#define so_clone(S, O) so_clone(aTHX_ (S), (O)) + CLONE_PARAMS param; + AV *stashes = NULL; + SV *dupsv; + + if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) + stashes = newAV(); + + param.stashes = stashes; + param.flags = 0; + param.proto_perl = owner; + + dupsv = sv_dup(sv, ¶m); + + if (stashes) { + av_undef(stashes); + SvREFCNT_dec(stashes); + } + + return SvREFCNT_inc(dupsv); +} + +#endif /* SO_THREADSAFE */ + +/* --- Public API ---------------------------------------------------------- */ + +#include "sub_op.h" + +void sub_op_register(pTHX_ const sub_op_keyword *k) { + SV *key = newSViv(PTR2IV(k->pp)); + + if (!PL_custom_op_names) + PL_custom_op_names = newHV(); + (void) hv_store_ent(PL_custom_op_names, key, newSVpv(k->name, k->len), 0); + + if (!PL_custom_op_descs) + PL_custom_op_descs = newHV(); + (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(k->name, k->len), 0); + + { + dMY_CXT; + (void) hv_store(MY_CXT.map, k->name, k->len, key, 0); + } +} + +/* --- Private helpers ----------------------------------------------------- */ + +#define SO_LINKLIST(O) ((O)->op_next ? (O)->op_next : sub_op_linklist(O)) + +STATIC OP *sub_op_linklist(pTHX_ OP *o) { +#define sub_op_linklist(O) sub_op_linklist(aTHX_ (O)) + OP *first; + + if (o->op_next) + return o->op_next; + + /* establish postfix order */ + first = cUNOPo->op_first; + if (first) { + register OP *kid; + o->op_next = SO_LINKLIST(first); + kid = first; + for (;;) { + if (kid->op_sibling) { + kid->op_next = SO_LINKLIST(kid->op_sibling); + kid = kid->op_sibling; + } else { + kid->op_next = o; + break; + } + } + } + else + o->op_next = o; + + return o->op_next; +} + +STATIC IV sub_op_hint(pTHX) { +#define sub_op_hint() sub_op_hint(aTHX) + SV *hint; + +#if SO_HAS_PERL(5, 9, 5) + hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, + NULL, + __PACKAGE__, __PACKAGE_LEN__, + 0, + 0); +#else + { + SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); + if (!val) + return 0; + hint = *val; + } +#endif + + return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0; +} + +STATIC OP *(*sub_op_old_ck_entersub)(pTHX_ OP *) = 0; + +STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) { + dMY_CXT; + + o = CALL_FPTR(sub_op_old_ck_entersub)(aTHX_ o); + + if (sub_op_hint()) { + dMY_CXT; + U32 hash = 0; + SV *pkg, *name, *pp_sv; + + pkg = av_pop(MY_CXT.next_pkg); + if (!SvOK(pkg)) + return o; + + name = av_pop(MY_CXT.next_name); + if (!SvOK(name)) { + SvREFCNT_dec(pkg); + return o; + } + + { + HV *stash = gv_stashsv(pkg, 0); + + if (stash) { + HE *he = hv_fetch_ent(stash, name, 0, 0); + + if (he) { + CV *cv; + SV *gv = HeVAL(he); + hash = HeHASH(he); + + if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder){ + SvREFCNT_dec(cv); + GvCV(gv) = NULL; + if (!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIO(gv) && !GvFORM(gv)) + (void) hv_delete_ent(stash, name, G_DISCARD, hash); + } + } + } + } + + { + HE *he = hv_fetch_ent(MY_CXT.map, name, 0, hash); + if (!he) + goto skip; + + pp_sv = HeVAL(he); + if (!SvOK(pp_sv)) + goto skip; + } + + if (o->op_type != OP_ENTERSUB) + goto skip; + if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */ + goto skip; + + { + OP *ex_list = cUNOPo->op_first; + OP *rv2cv, *gvop; + OP *last_arg = NULL; + + /* pushmark when a method call */ + if (!ex_list || ex_list->op_type != OP_NULL) + goto skip; + + rv2cv = cUNOPx(ex_list)->op_first; + if (!rv2cv) + goto skip; + + while (1) { + OP *next = rv2cv->op_sibling; + if (!next) + break; + last_arg = rv2cv; + rv2cv = next; + } + + if (!(rv2cv->op_flags & OPf_KIDS)) + goto skip; + + gvop = cUNOPx(rv2cv)->op_first; + if (!gvop || gvop->op_type != OP_GV) + goto skip; + + { + GV *gv = cGVOPx_gv(gvop); + STRLEN len; + const char *s = SvPV_const(name, len); + + if (GvNAMELEN(gv) == len && strnEQ(GvNAME(gv), s, len)) { + o->op_type = OP_CUSTOM; + o->op_ppaddr = INT2PTR(Perl_ppaddr_t, SvIVX(pp_sv)); + + if (last_arg) + last_arg->op_sibling = NULL; + op_free(rv2cv); + + sub_op_linklist(o); + } + } + } + +skip: + SvREFCNT_dec(pkg); + SvREFCNT_dec(name); + } + + return o; +} + +/* --- XS ------------------------------------------------------------------ */ + +MODULE = Sub::Op PACKAGE = Sub::Op + +PROTOTYPES: ENABLE + +BOOT: +{ + MY_CXT_INIT; + MY_CXT.map = newHV(); + MY_CXT.next_pkg = newAV(); + MY_CXT.next_name = newAV(); + MY_CXT.placeholder = NULL; +#if SO_THREADSAFE + MY_CXT.owner = aTHX; +#endif /* SO_THREADSAFE */ + + sub_op_old_ck_entersub = PL_check[OP_ENTERSUB]; + PL_check[OP_ENTERSUB] = sub_op_ck_entersub; +} + +#if SO_THREADSAFE + +void +CLONE(...) +PROTOTYPE: DISABLE +PREINIT: + HV *map; + CV *placeholder; + tTHX owner; +CODE: + { + dMY_CXT; + owner = MY_CXT.owner; + map = (HV *) so_clone((SV *) MY_CXT.map, owner); + placeholder = (CV *) so_clone((SV *) MY_CXT.placeholder, owner); + } + { + MY_CXT_CLONE; + MY_CXT.map = map; + MY_CXT.next_pkg = newAV(); + MY_CXT.next_name = newAV(); + MY_CXT.placeholder = placeholder; + MY_CXT.owner = aTHX; + } + +#endif /* SO_THREADSAFE */ + +void +_placeholder(SV *sv) +PROTOTYPE: $ +PPCODE: + if (SvROK(sv)) { + sv = SvRV(sv); + if (SvTYPE(sv) >= SVt_PVCV) { + dMY_CXT; + SvREFCNT_dec(MY_CXT.placeholder); + MY_CXT.placeholder = (CV *) SvREFCNT_inc(sv); + } + } + XSRETURN(0); + +void +_incoming(SV *name, SV *pkg) +PROTOTYPE: $$ +PPCODE: + dMY_CXT; + av_push(MY_CXT.next_pkg, SvREFCNT_inc(pkg)); + av_push(MY_CXT.next_name, SvREFCNT_inc(name)); + XSRETURN(0); + +void +_custom_name(SV *op) +PROTOTYPE: $ +PREINIT: + OP *o; + SV *key; + HE *he; +PPCODE: + if (!SvROK(op)) + XSRETURN_UNDEF; + o = INT2PTR(OP *, SvIV(SvRV(op))); + if (!o || o->op_type != OP_CUSTOM) + XSRETURN_UNDEF; + key = newSViv(PTR2IV(o->op_ppaddr)); + he = hv_fetch_ent(PL_custom_op_names, key, 0, 0); + SvREFCNT_dec(key); + if (!he) + XSRETURN_UNDEF; + ST(0) = sv_mortalcopy(HeVAL(he)); + XSRETURN(1); diff --git a/configure_test.pl b/configure_test.pl new file mode 100644 index 0000000..447376d --- /dev/null +++ b/configure_test.pl @@ -0,0 +1,50 @@ +#!perl + +use strict; +use warnings; + +use POSIX qw/WIFEXITED WEXITSTATUS EXIT_FAILURE/; + +BEGIN { + no warnings 'redefine'; + local $@; + *WIFEXITED = sub { 1 } unless eval { WIFEXITED(0); 1 }; + *WEXITSTATUS = sub { shift() >> 8 } unless eval { WEXITSTATUS(0); 1 }; +} + +my @args; +{ + my $args_dat = './args.dat'; + + open my $fh, '<', $args_dat or die "open(<$args_dat): $!"; + + { + local $/ = "\n"; + @args = <$fh>; + } + for (@args) { + 1 while chomp; + s{\[([0-9]+)\]}{chr $1}ge; + } +} + +my $ret = EXIT_FAILURE; +{ + sub CwdSaver::DESTROY { + my $cwd = $_[0]->{cwd}; + chdir $cwd or die "chdir('$cwd'): $!"; + } + + my $guard = bless { cwd => do { require Cwd; Cwd::cwd() } }, 'CwdSaver'; + + chdir 't/Sub-Op-Test' or die "chdir('t/Sub-Op-Test'): $!"; + + system { $^X } $^X, 'Makefile.PL', @args; + if ($? == -1) { + die "$^X Makefile.PL @args: $!"; + } elsif (WIFEXITED($?)) { + $ret = WEXITSTATUS($?); + } +} + +exit $ret; diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm new file mode 100644 index 0000000..94cfe95 --- /dev/null +++ b/lib/Sub/Op.pm @@ -0,0 +1,201 @@ +package Sub::Op; + +use 5.010; + +use strict; +use warnings; + +our ($VERSION, @ISA); + +sub dl_load_flags { 0x01 } + +BEGIN { + $VERSION = '0.01'; + require DynaLoader; + push @ISA, 'DynaLoader'; + __PACKAGE__->bootstrap($VERSION); +} + +use B::Hooks::EndOfScope; +use Variable::Magic 0.08; + +my $placeholder; +BEGIN { + $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') }; + _placeholder($placeholder); +} + +my $sw = Variable::Magic::wizard( + data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } }, + fetch => sub { + my ($var, $data, $name) = @_; + + return if $data->{guard}; + local $data->{guard} = 1; + + return unless $data->{map}->{$name}; + + my $pkg = $data->{pkg}; + my $fqn = join '::', $pkg, $name; + + _incoming($name, $pkg); + + no strict 'refs'; + *$fqn = $placeholder unless exists &$fqn; + + return; + }, +); + +sub _map { + my ($pkg) = @_; + + my $data = do { + no strict 'refs'; + Variable::Magic::getdata(%{"${pkg}::"}, $sw); + }; + + defined $data ? $data->{map} : undef; +} + +sub _cast { + my ($pkg, $name) = @_; + + no strict 'refs'; + Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 }); +} + +sub _dispell { + my ($pkg) = @_; + + no strict 'refs'; + Variable::Magic::dispell(%{"${pkg}::"}, $sw); +} + +sub enable { + my $name = shift; + + my $pkg = @_ > 0 ? $_[0] : caller; + my $fqn = "${pkg}::$name"; + + my $map = _map($pkg); + + if (defined $map) { + $map->{$name} = 1; + } else { + _cast($pkg, $name); + } + + $^H |= 0x00020000; + $^H{+(__PACKAGE__)} = 1; + + on_scope_end { disable($name, $pkg) }; + + return; +} + +sub disable { + my $name = shift; + + my $pkg = @_ > 0 ? $_[0] : caller; + my $fqn = "${pkg}::$name"; + + my $map = _map($pkg); + + if (defined $map) { + delete $map->{$name}; + unless (keys %$map) { + _dispell($pkg); + } + } + + return; +} + +sub _inject { + my ($pkg, $inject) = @_; + + my $stash = do { no strict 'refs'; \%{"${pkg}::"} }; + + while (my ($meth, $code) = each %$inject) { + next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code; + no strict 'refs'; + *{"${pkg}::$meth"} = $code; + } +} + +{ + my $injector; + BEGIN { + $injector = Variable::Magic::wizard( + data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } }, + store => sub { + my ($stash, $data, $key) = @_; + + return if $data->{guard}; + local $data->{guard} = 1; + + _inject($data->{pkg}, $data->{subs}); + + return; + }, + ); + } + + sub _monkeypatch { + my %B_OP_inject; + + $B_OP_inject{first} = sub { + if (defined _custom_name($_[0])) { + $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP'); + goto $_[0]->can('first') || die 'oops'; + } + require Carp; + Carp::confess('Calling B::OP->first for something that isn\'t a custom op'); + }; + + $B_OP_inject{can} = sub { + my ($obj, $meth) = @_; + if ($meth eq 'first') { + return undef unless defined _custom_name($obj); + } + $obj->SUPER::can($meth); + }; + + if (%B:: and %B::OP:: and *B::OP::type{CODE}) { + _inject('B::OP', \%B_OP_inject); + } else { + Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject; + } + + my $B_Deparse_inject = { + pp_custom => sub { + my ($self, $op, $cx) = @_; + my $name = _custom_name($op); + die 'unhandled custom op' unless defined $name; + if ($op->flags & B::OPf_STACKED()) { + my $kid = $op->first; + $kid = $kid->first->sibling; # skip ex-list, pushmark + my @exprs; + for (; not B::Deparse::null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + my $args = join(", ", @exprs); + return "$name($args)"; + } else { + return $name; + } + }, + }; + + if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) { + _inject('B::Deparse', $B_Deparse_inject); + } else { + Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject; + } + } +} + +BEGIN { _monkeypatch() } + +1; # End of Sub::Op diff --git a/sub_op.h b/sub_op.h new file mode 100644 index 0000000..161d147 --- /dev/null +++ b/sub_op.h @@ -0,0 +1,16 @@ +/* This file is part of the Sub::Op Perl module. + * See http://search.cpan.org/dist/Sub-Op/ */ + +#ifndef SUB_OP_H +#define SUB_OP_H 1 + +typedef struct { + const char *name; + STRLEN len; + Perl_ppaddr_t pp; + void (*check)(pTHX_ OP *); +} sub_op_keyword; + +void sub_op_register(pTHX_ const sub_op_keyword *k); + +#endif /* SUB_OP_H */ diff --git a/t/10-base.t b/t/10-base.t new file mode 100644 index 0000000..86042b3 --- /dev/null +++ b/t/10-base.t @@ -0,0 +1,122 @@ +#!perl + +use strict; +use warnings; + +use blib 't/Sub-Op-Test'; + +use Test::More tests => 2 * 15 + 21; + +our $called; + +{ + local $/ = "####\n"; + while () { + my ($code, $params) = split /----\s*/, $_; + my ($name, $ret, $exp) = split /\s*#\s*/, $params; + + my @exp = eval $exp; + if ($@) { + fail "unable to get expected values: $@"; + next; + } + my $calls = @exp; + + $code = <<" WRAPPER"; + { + use Sub::Op::Test $name => sub { + ++\$called; + my \$exp = shift \@exp; + is_deeply \\\@_, \$exp, '$name: arguments are correct'; + $ret; + }; + { + $code + } + BEGIN { + no warnings 'uninitialized'; # Test::Builder can't get the file name + is *main::${name}{CODE}, undef, '$name: no symbol table vivification'; + } + } + WRAPPER + + local $called = 0; + eval $code; + if ($@) { + fail "$name: unable to evaluate test case: $@"; + diag $code; + } + + is $called, $calls, "$name: the hook was called the right number of times"; + if ($called < $calls) { + fail for $called + 1 .. $calls; + } + } +} + +__DATA__ +foo(); +---- +foo # () # [ ] +#### +bar; +---- +bar # () # [ ] +#### +baz(1); +---- +baz # () # [ 1 ] +#### +zap 2; +---- +zap # () # [ 2 ] +#### +package X; +main::flap 7, 8; +---- +flap # () # [ 7, 8 ] +#### +wut; wut 1; wut 2, 3 +---- +wut # () # [ ], [ 1 ], [ 2, 3 ] +#### +qux(qux(1)); +---- +qux # @_ # [ 1 ], [ 1 ] +#### +wat 1, wat, 2, wat(3, 4), 5 +---- +wat # @_ # [ ], [ 3, 4 ], [ 1, 2, 3, 4, 5 ] +#### +sum sum sum(1, 2), sum(3, 4) +---- +sum # do { my $s = 0; $s += $_ for @_; $s } # [ 1, 2 ], [ 3, 4 ], [ 3, 7 ], [ 10 ] +#### +return; +my $x = \&func +---- +func # () # () +#### +return; +__PACKAGE__->meth +---- +meth # () # () +#### +fetch 1, do { no strict 'refs'; *{__PACKAGE__.'::fetch'}{CODE} }, 2 +---- +fetch # () # [ 1, undef, 2 ] +#### +our $scalr = 1; +scalr $scalr; +---- +scalr # () # [ 1 ] +#### +our @array = (2, 3); +array @array; +---- +array # () # [ 2, 3 ] +#### +our %hash = (x => 4); +hash $hash{x}; +---- +hash # () # [ 4 ] diff --git a/t/Sub-Op-Test/Makefile.PL b/t/Sub-Op-Test/Makefile.PL new file mode 100644 index 0000000..b25c324 --- /dev/null +++ b/t/Sub-Op-Test/Makefile.PL @@ -0,0 +1,39 @@ +use 5.010; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $dist = 'Sub-Op-Test'; + +(my $name = $dist) =~ s{-}{::}g; + +(my $file = $dist) =~ s{-}{/}g; +$file = "lib/$file.pm"; + +my $top; +BEGIN { + require File::Spec; + my $up = File::Spec->updir; + $top = File::Spec->rel2abs(File::Spec->catdir($up, $up)); +} + +use ExtUtils::Depends; + +use blib $top; + +my $ed = ExtUtils::Depends->new($name => 'Sub::Op'); + +my %ed_vars = $ed->get_makefile_vars; +$ed_vars{clean}->{FILES} .= ' ' . join ' ', + "$dist-*", qw{*.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt}; + +WriteMakefile( + NAME => $name, + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => $file, + PL_FILES => {}, + MIN_PERL_VERSION => 5.010, + %ed_vars, +); diff --git a/t/Sub-Op-Test/Test.xs b/t/Sub-Op-Test/Test.xs new file mode 100644 index 0000000..4750507 --- /dev/null +++ b/t/Sub-Op-Test/Test.xs @@ -0,0 +1,68 @@ +/* This file is part of the Sub::Op Perl module. + * See http://search.cpan.org/dist/Sub-Op/ */ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define __PACKAGE__ "Sub::Op::Test" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) + +#include "sub_op.h" + +STATIC SV *sub_op_test_cb = NULL; + +STATIC OP *sub_op_test_pp(pTHX) { + dSP; + dMARK; + int i, items; + + ENTER; + SAVETMPS; + + PUSHMARK(MARK); + + items = call_sv(sub_op_test_cb, G_ARRAY); + + SPAGAIN; + for (i = 0; i < items; ++i) + SvREFCNT_inc(SP[-i]); + PUTBACK; + + FREETMPS; + LEAVE; + + return NORMAL; +} + +/* --- XS ------------------------------------------------------------------ */ + +MODULE = Sub::Op::Test PACKAGE = Sub::Op::Test + +PROTOTYPES: ENABLE + +void +_init(SV *name) +PROTOTYPE: $ +PREINIT: + sub_op_keyword k; +PPCODE: + k.name = SvPV_const(name, k.len); + k.check = 0; + k.pp = sub_op_test_pp; + sub_op_register(aTHX_ &k); + XSRETURN(0); + +void +_callback(SV *cb) +PROTOTYPE: $ +PPCODE: + if (SvROK(cb)) { + cb = SvRV(cb); + if (SvTYPE(cb) >= SVt_PVCV) { + SvREFCNT_dec(sub_op_test_cb); + sub_op_test_cb = SvREFCNT_inc(cb); + } + } + XSRETURN(0); diff --git a/t/Sub-Op-Test/lib/Sub/Op/Test.pm b/t/Sub-Op-Test/lib/Sub/Op/Test.pm new file mode 100644 index 0000000..a8bd2bf --- /dev/null +++ b/t/Sub-Op-Test/lib/Sub/Op/Test.pm @@ -0,0 +1,28 @@ +package Sub::Op::Test; + +use strict; +use warnings; + +our ($VERSION, @ISA); + +use Sub::Op; + +BEGIN { + $VERSION = '0.01'; + require DynaLoader; + push @ISA, 'DynaLoader'; + __PACKAGE__->bootstrap($VERSION); +} + +sub import { + shift; + + my ($name, $cb) = @_; + + _init($name); + _callback($cb); + + Sub::Op::enable($name => scalar caller); +} + +1;