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