use strict;
use warnings;
+use 5.008001;
+
+our $VERSION = 0.001001;
use vars qw(%lift);
+use base qw(DynaLoader);
+use B::Hooks::OP::Check::EntersubForCV;
-use Inline C => <<'EOC';
-#include <stdio.h>
-#include <string.h>
-#include "proto.h"
+bootstrap Devel::BeginLift;
-/* lifted from op.c (w/linklist -> Perl_linklist) */
+sub import {
+ my ($class, @args) = @_;
+ my $target = caller;
+ $class->setup_for($target => \@args);
+}
-#define LINKLIST(o) ((o)->op_next ? (o)->op_next : Perl_linklist((OP*)o))
+sub unimport {
+ my ($class) = @_;
+ my $target = caller;
+ $class->teardown_for($target);
+}
-/* pointer to old PL_check entersub entry to be populated in init */
+sub setup_for {
+ my ($class, $target, $args) = @_;
+ $lift{$target} ||= [];
+ push @{ $lift{$target} }, map {
+ $class->setup_for_cv($_);
+ } map {
+ ref $_ eq 'CODE'
+ ? $_
+ : \&{ "${target}::${_}" }
+ } @{ $args };
+}
-STATIC OP *(*dbl_old_ck_entersub)(pTHX_ OP *op);
+sub teardown_for {
+ my ($class, $target) = @_;
+ $class->teardown_for_cv($_) for @{ $lift{$target} };
+ delete $lift{$target};
+}
-/* replacement PL_check entersub entry */
+=head1 NAME
+
+Devel::BeginLift - make selected sub calls evaluate at compile time
+
+=head1 SYNOPSIS
+
+ use Devel::BeginLift qw(foo baz);
+
+ use vars qw($i);
+
+ BEGIN { $i = 0 }
+
+ sub foo { "foo: $_[0]\n"; }
+
+ sub bar { "bar: $_[0]\n"; }
+
+ for (1 .. 3) {
+ print foo($i++);
+ print bar($i++);
+ }
+
+ no Devel::BeginLift;
+
+ print foo($i++);
-STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
- OP *kid;
- OP *last;
- OP *curop;
- HV *stash;
- I32 type = o->op_type;
- SV *sv;
- char* stack_save;
- HV* to_lift;
- SV** to_lift_pack_ref;
- HV* to_lift_pack_hash;
- SV** to_lift_flag_ref;
+outputs -
- o = dbl_old_ck_entersub(aTHX_ o); /* let the original do its job */
+foo: 0
+bar: 1
+foo: 0
+bar: 2
+foo: 0
+bar: 3
+foo: 4
- kid = cUNOPo->op_first;
+=head1 DESCRIPTION
- if (kid->op_type != OP_NULL) /* pushmark for method call ... */
- return o;
+Devel::BeginLift 'lifts' arbitrary sub calls to running at compile time
+- sort of a souped up version of "use constant". It does this via some
+slightly insane perlguts magic.
- last = kLISTOP->op_last;
+=head2 import
- if (last->op_type != OP_NULL) /* not what we expected */
- return o;
+ use Devel::BeginLift qw(list of subs);
- kid = cUNOPx(last)->op_first;
+Calls Devel::BeginLift->setup_for(__PACKAGE__ => \@list_of_subs);
- if (kid->op_type != OP_GV) /* not a GV so ignore */
- return o;
+=head2 unimport
- stash = GvSTASH(kGVOP_gv);
+ no Devel::BeginLift;
- /* printf("Calling GV %s -> %s\n",
- HvNAME(stash), GvNAME(kGVOP_gv)); */
+Calls Devel::BeginLift->teardown_for(__PACKAGE__);
- to_lift = get_hv("Devel::BeginLift::lift", FALSE);
+=head2 setup_for
- if (!to_lift)
- return o;
+ Devel::BeginLift->setup_for($package => \@subnames);
- to_lift_pack_ref = hv_fetch(to_lift, HvNAME(stash), strlen(HvNAME(stash)),
- FALSE);
+Installs begin lifting magic (unless already installed) and registers
+"${package}::$name" for each member of @subnames to be executed when parsed
+and replaced with its output rather than left for runtime.
- if (!to_lift_pack_ref || !SvROK(*to_lift_pack_ref))
- return o; /* not a hashref */
+=head2 teardown_for
- to_lift_pack_hash = (HV*) SvRV(*to_lift_pack_ref);
+ Devel::BeginLift->teardown_for($package);
- to_lift_flag_ref = hv_fetch(to_lift_pack_hash, GvNAME(kGVOP_gv),
- strlen(GvNAME(kGVOP_gv)), FALSE);
+Deregisters all subs currently registered for $package and uninstalls begin
+lifting magic is number of teardown_for calls matches number of setup_for
+calls.
- if (!to_lift_flag_ref || !SvTRUE(*to_lift_flag_ref))
- return o;
+=head2 setup_for_cv
- /* shamelessly lifted from fold_constants in op.c */
+ $id = Devel::BeginLift->setup_for_cv(\&code);
- stack_save = PL_stack_sp;
- curop = LINKLIST(o);
- o->op_next = 0;
- PL_op = curop;
- CALLRUNOPS(aTHX);
+Same as C<setup_for>, but only registers begin lifting magic for one code
+reference. Returns an id to be used in C<teardown_for_cv>.
- if (PL_stack_sp > stack_save) { /* sub returned something */
- sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ, FALSE);
- else if (SvTEMP(sv)) { /* grab mortal temp? */
- (void)SvREFCNT_inc(sv);
- SvTEMP_off(sv);
- }
- op_free(o);
- if (type == OP_RV2GV)
- return newGVOP(OP_GV, 0, (GV*)sv);
- return newSVOP(OP_CONST, 0, sv);
- } else {
- /* this bit not lifted, handles the 'sub doesn't return stuff' case
- which fold_constants can ignore */
- op_free(o);
- return newSVOP(OP_CONST, 0, &PL_sv_undef);
- }
-}
+=head2 teardown_for_cv
-static int initialized = 0;
+ Devel::BeginLift->teardown_for_cv($id);
-void setup() {
- if (!initialized++) {
- dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
- PL_check[OP_ENTERSUB] = dbl_ck_entersub;
- }
-}
+Deregisters begin lifting magic referred to by C<$id>.
-void teardown() {
- /* ensure we only uninit when number of teardown calls matches
- number of setup calls */
- if (initialized && !--initialized) {
- PL_check[OP_ENTERSUB] = dbl_old_ck_entersub;
- }
-}
-EOC
+=head1 AUTHOR
-# C code done, now for the perl.
+Matt S Trout - <mst@shadowcatsystems.co.uk>
-sub import {
- my ($class, @args) = @_;
- my $target = caller;
- $class->setup_for($target => \@args);
-}
+Company: http://www.shadowcatsystems.co.uk/
+Blog: http://chainsawblues.vox.com/
-sub unimport {
- my ($class) = @_;
- my $target = caller;
- $class->teardown_for($target);
-}
+=head1 LICENSE
-sub setup_for {
- my ($class, $target, $args) = @_;
- setup();
- $lift{$target}{$_} = 1 for @$args;
-}
+This library is free software under the same terms as perl itself
-sub teardown_for {
- my ($class, $target) = @_;
- delete $lift{$target};
- teardown();
-}
+=cut
1;
projects / p5sagit/Devel-BeginLift.git / blobdiff