initial import, still fragile as all hell

diff --git a/Declare.xs b/Declare.xs
new file mode 100644 (file)
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 <stdio.h>
+#include <string.h>
+
+#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 (file)
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 (file)
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 - <mst@shadowcatsystems.co.uk>
+
+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 (file)
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));