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
  15 use vars qw(%declarators %declarator_handlers @next_pad_inject);
  16 use base qw(DynaLoader);
  17
  18 bootstrap Devel::Declare;
  19
  20 sub import {
  21   my ($class, %args) = @_;
  22   my $target = caller;
  23   if (@_ == 1) { # "use Devel::Declare;"
  24     no strict 'refs';
  25     foreach my $name (qw(NAME PROTO NONE)) {
  26       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  27     }
  28   } else {
  29     $class->setup_for($target => \%args);
  30   }
  31 }
  32
  33 sub unimport {
  34   my ($class) = @_;
  35   my $target = caller;
  36   $class->teardown_for($target);
  37 }
  38
  39 sub setup_for {
  40   my ($class, $target, $args) = @_;
  41   setup();
  42   foreach my $key (keys %$args) {
  43     my $info = $args->{$key};
  44     my ($flags, $sub);
  45     if (ref($info) eq 'ARRAY') {
  46       ($flags, $sub) = @$info;
  47     } elsif (ref($info) eq 'CODE') {
  48       $flags = DECLARE_NAME;
  49       $sub = $info;
  50     } else {
  51       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub";
  52     }
  53     $declarators{$target}{$key} = $flags;
  54     $declarator_handlers{$target}{$key} = $sub;
  55   }
  56 }
  57
  58 sub teardown_for {
  59   my ($class, $target) = @_;
  60   delete $declarators{$target};
  61   delete $declarator_handlers{$target};
  62   teardown();
  63 }
  64
  65 my $temp_pack;
  66 my $temp_name;
  67 my $temp_save;
  68
  69 sub init_declare {
  70   my ($pack, $use, $name, $proto) = @_;
  71   my ($name_h, $XX_h, $extra_code)
  72        = $declarator_handlers{$pack}{$use}->(
  73            $pack, $use, $name, $proto, defined(wantarray)
  74          );
  75   ($temp_pack, $temp_name, $temp_save) = ($pack, [], []);
  76   if ($name) {
  77     push(@$temp_name, $name);
  78     no strict 'refs';
  79     push(@$temp_save, \&{"${pack}::${name}"});
  80     no warnings 'redefine';
  81     no warnings 'prototype';
  82     *{"${pack}::${name}"} = $name_h;
  83   }
  84   if ($XX_h) {
  85     push(@$temp_name, 'X');
  86     no strict 'refs';
  87     push(@$temp_save, \&{"${pack}::X"});
  88     no warnings 'redefine';
  89     no warnings 'prototype';
  90     *{"${pack}::X"} = $XX_h;
  91   }
  92   if (defined wantarray) {
  93     return $extra_code || '0;';
  94   } else {
  95     return;
  96   }
  97 }
  98
  99 sub done_declare {
 100   no strict 'refs';
 101   my $name = pop(@{$temp_name||[]});
 102   die "done_declare called with no temp_name stack" unless defined($name);
 103   my $saved = pop(@$temp_save);
 104   delete ${"${temp_pack}::"}{$name};
 105   if ($saved) {
 106     no warnings 'prototype';
 107     *{"${temp_pack}::${name}"} = $saved;
 108   }
 109 }
 110
 111 sub inject_into_next_pad {
 112   shift; @next_pad_inject = @_;
 113 }
 114
 115 =head1 NAME
 116
 117 Devel::Declare -
 118
 119 =head1 SYNOPSIS
 120
 121 =head1 DESCRIPTION
 122
 123 =head2 import
 124
 125   use Devel::Declare qw(list of subs);
 126
 127 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 128
 129 =head2 unimport
 130
 131   no Devel::Declare;
 132
 133 Calls Devel::Declare->teardown_for(__PACKAGE__);
 134
 135 =head2 setup_for
 136
 137   Devel::Declare->setup_for($package => \@subnames);
 138
 139 Installs declarator magic (unless already installed) and registers
 140 "${package}::$name" for each member of @subnames
 141
 142 =head2 teardown_for
 143
 144   Devel::Declare->teardown_for($package);
 145
 146 Deregisters all subs currently registered for $package and uninstalls
 147 declarator magic if number of teardown_for calls matches number of setup_for
 148 calls.
 149
 150 =head1 AUTHOR
 151
 152 Matt S Trout - <mst@shadowcatsystems.co.uk>
 153
 154 Company: http://www.shadowcatsystems.co.uk/
 155 Blog: http://chainsawblues.vox.com/
 156
 157 =head1 LICENSE
 158
 159 This library is free software under the same terms as perl itself
 160
 161 =cut
 162
 163 1;