lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = 0.001000;
   8
   9 # mirrored in Declare.xs as DD_HANDLE_*
  10
  11 use constant DECLARE_NAME => 1;
  12 use constant DECLARE_PROTO => 2;
  13 use constant DECLARE_NONE => 4;
  14 use constant DECLARE_PACKAGE => 8+1; # name implicit
  15
  16 use vars qw(%declarators %declarator_handlers);
  17 use base qw(DynaLoader);
  18 use Scalar::Util 'set_prototype';
  19
  20 bootstrap Devel::Declare;
  21
  22 sub import {
  23   my ($class, %args) = @_;
  24   my $target = caller;
  25   if (@_ == 1) { # "use Devel::Declare;"
  26     no strict 'refs';
  27     foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
  28       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  29     }
  30   } else {
  31     $class->setup_for($target => \%args);
  32   }
  33 }
  34
  35 sub unimport {
  36   my ($class) = @_;
  37   my $target = caller;
  38   $class->teardown_for($target);
  39 }
  40
  41 sub setup_for {
  42   my ($class, $target, $args) = @_;
  43   setup();
  44   foreach my $key (keys %$args) {
  45     my $info = $args->{$key};
  46     my ($flags, $sub);
  47     if (ref($info) eq 'ARRAY') {
  48       ($flags, $sub) = @$info;
  49     } elsif (ref($info) eq 'CODE') {
  50       $flags = DECLARE_NAME;
  51       $sub = $info;
  52     } else {
  53       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub";
  54     }
  55     $declarators{$target}{$key} = $flags;
  56     $declarator_handlers{$target}{$key} = $sub;
  57   }
  58 }
  59
  60 sub teardown_for {
  61   my ($class, $target) = @_;
  62   delete $declarators{$target};
  63   delete $declarator_handlers{$target};
  64   teardown();
  65 }
  66
  67 my $temp_name;
  68 my $temp_save;
  69
  70 sub init_declare {
  71   my ($usepack, $use, $inpack, $name, $proto) = @_;
  72   my ($name_h, $XX_h, $extra_code)
  73        = $declarator_handlers{$usepack}{$use}->(
  74            $usepack, $use, $inpack, $name, $proto, defined(wantarray)
  75          );
  76   ($temp_name, $temp_save) = ([], []);
  77   if ($name) {
  78     $name = "${inpack}::${name}" unless $name =~ /::/;
  79     push(@$temp_name, $name);
  80     no strict 'refs';
  81     push(@$temp_save, \&{$name});
  82     no warnings 'redefine';
  83     no warnings 'prototype';
  84     *{$name} = $name_h;
  85   }
  86   if ($XX_h) {
  87     push(@$temp_name, "${inpack}::X");
  88     no strict 'refs';
  89     push(@$temp_save, \&{"${inpack}::X"});
  90     no warnings 'redefine';
  91     no warnings 'prototype';
  92     *{"${inpack}::X"} = $XX_h;
  93   }
  94   if (defined wantarray) {
  95     return $extra_code || '0;';
  96   } else {
  97     return;
  98   }
  99 }
 100
 101 sub done_declare {
 102   no strict 'refs';
 103   my $name = pop(@{$temp_name||[]});
 104   die "done_declare called with no temp_name stack" unless defined($name);
 105   my $saved = pop(@$temp_save);
 106   $name =~ s/(.*):://;
 107   my $temp_pack = $1;
 108   delete ${"${temp_pack}::"}{$name};
 109   if ($saved) {
 110     no warnings 'prototype';
 111     *{"${temp_pack}::${name}"} = $saved;
 112   }
 113 }
 114
 115 sub build_sub_installer {
 116   my ($class, $pack, $name, $proto) = @_;
 117   return eval "
 118     package ${pack};
 119     my \$body;
 120     sub ${name} (${proto}) :lvalue {\n"
 121     .'$body->(@_);
 122     };
 123     sub { ($body) = @_; };';
 124 }
 125
 126 sub setup_declarators {
 127   my ($class, $pack, $to_setup) = @_;
 128   die "${class}->setup_declarator(\$pack, \\\%to_setup)"
 129     unless defined($pack) && ref($to_setup eq 'HASH');
 130   foreach my $name (keys %$to_setup) {
 131     my $info = $to_setup->{$name};
 132     my $flags = $info->{flags} || DECLARE_NAME;
 133     my $run = $info->{run};
 134     my $compile = $info->{compile};
 135     my $proto = $info->{proto} || '&';
 136     my $sub_proto = $proto;
 137     # make all args optional to enable lvalue for DECLARE_NONE
 138     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 139     my $installer = $class->build_sub_installer($pack, $name, $proto);
 140     # XXX UNCLEAN
 141   }
 142 }
 143
 144 =head1 NAME
 145
 146 Devel::Declare -
 147
 148 =head1 SYNOPSIS
 149
 150 =head1 DESCRIPTION
 151
 152 =head2 import
 153
 154   use Devel::Declare qw(list of subs);
 155
 156 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 157
 158 =head2 unimport
 159
 160   no Devel::Declare;
 161
 162 Calls Devel::Declare->teardown_for(__PACKAGE__);
 163
 164 =head2 setup_for
 165
 166   Devel::Declare->setup_for($package => \@subnames);
 167
 168 Installs declarator magic (unless already installed) and registers
 169 "${package}::$name" for each member of @subnames
 170
 171 =head2 teardown_for
 172
 173   Devel::Declare->teardown_for($package);
 174
 175 Deregisters all subs currently registered for $package and uninstalls
 176 declarator magic if number of teardown_for calls matches number of setup_for
 177 calls.
 178
 179 =head1 AUTHOR
 180
 181 Matt S Trout - <mst@shadowcatsystems.co.uk>
 182
 183 Company: http://www.shadowcatsystems.co.uk/
 184 Blog: http://chainsawblues.vox.com/
 185
 186 =head1 LICENSE
 187
 188 This library is free software under the same terms as perl itself
 189
 190 =cut
 191
 192 1;