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