1: ### UPDATES ###
   2: #
   3: # 4-3-2002: per petral's feedback, "use define;" is back in
   4: # 9-4-2004: updated to match CPAN version
   5: #
   6: 
   7: package define;
   8: 
   9: use 5.008004;
  10: use strict;
  11: use warnings;
  12: 
  13: our $VERSION = '1.02';
  14: 
  15: my %AllPkgs;
  16: my %DefPkgs;
  17: my %Vals;
  18: 
  19: my %Forbidden = map { $_ => 1 } qw{ 
  20:   BEGIN INIT CHECK END DESTROY AUTOLOAD 
  21:   STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG 
  22: };
  23: 
  24: sub import {
  25:   my $class = shift;
  26:   my $pkg = (caller)[0];
  27:   if( @_ ) {
  28:     if( ref $_[0] eq 'HASH' ) {
  29:       while( my( $name, $val ) = each %{$_[0]} ) {
  30:         do_import( $pkg, $name, $val );
  31:       }
  32:     }
  33:     else {
  34:       do_import( $pkg, @_ );
  35:     }
  36:   }
  37:   else {
  38:     require Carp;
  39:     Carp::croak "Must call 'use define' with parameters";
  40:   }
  41: }
  42: 
  43: sub unimport {
  44:   my $class = shift;
  45:   my $pkg = (caller)[0];
  46:   if( @_ ) {
  47:     check_name( my $name = shift );
  48:     $DefPkgs{$name}{$pkg} = 1;
  49:     if( $Vals{$name} ) {
  50:       makedef( $pkg, $name, @{$Vals{$name}} );
  51:     }
  52:     else {
  53:       makedef( $pkg, $name );
  54:     }
  55:   }
  56:   else {
  57:     # export all Declared to pkg
  58:     $AllPkgs{$pkg} = 1;
  59:     while( my( $name, $val ) = each %Vals ) {
  60:       # warn "Defining ALL $pkg:$name:$val";
  61:       makedef( $pkg, $name, @$val );
  62:     }
  63:   }
  64: }
  65: 
  66: sub check_name {
  67:   my $name = shift;
  68:   if( $name =~ /^__/ 
  69:       or $name !~ /^_?[^\W_0-9]\w*\z/ 
  70:       or $Forbidden{$name} ) {
  71:     require Carp;
  72:     Carp::croak "Define name '$name' is invalid";
  73:   }
  74: }
  75: 
  76: sub do_import {
  77:   my( $pkg, $name, @vals ) = @_;
  78:   check_name( $name );
  79:   $DefPkgs{$name}{$pkg} = 1;
  80:   $Vals{$name} = [ @vals ];
  81:   my %pkgs = ( $pkg => 1, %AllPkgs, %{$DefPkgs{$name}} );
  82:   for (keys %pkgs) {
  83:     makedef( $_, $name, @vals );
  84:   }
  85: }
  86: 
  87: sub makedef {
  88:   my ($pkg, $name, @Vals) = @_;
  89:   my $subname = "${pkg}::$name";
  90: 
  91:   no strict 'refs';
  92: 
  93:   if (defined *{$subname}{CODE}) {
  94:     require Carp;
  95:     Carp::carp "Global constant $subname redefined";
  96:   }
  97: 
  98:   if (@Vals > 1) {
  99:     *$subname = sub () { @Vals };
 100:   }
 101:   elsif (@Vals == 1) {
 102:     my $val = $Vals[0];
 103:     *$subname = sub () { $val };
 104:   }
 105:   else {
 106:     *$subname = sub () { };
 107:   }
 108: }
 109:   
 110: 1;
 111: 
 112: __END__
 113: 
 114: =head1 NAME
 115: 
 116: define - Perl pragma to declare global constants
 117: 
 118: =head1 SYNOPSIS
 119: 
 120:     #--- in package/file main ---#
 121:     package main;
 122:     
 123:     # the most frequenly used application of this pragma
 124:     use define DEBUG => 0;
 125:     
 126:     # define a constant list
 127:     use define DWARVES => qw(happy sneezy grumpy);
 128:     
 129:     # define several at a time via a hashref list, like constant.pm
 130:     use define {
 131:       FOO => 1,
 132:       BAR => 2,
 133:       BAZ => 3,
 134:     };
 135: 
 136:     use Some::Module;
 137:     use My::Module;
 138:     
 139:     #--- in package/file Some::Module ---#
 140:     package Some::Module
 141:     no define DEBUG =>;
 142:     no define DWARVES =>;
 143: 
 144:     # define a master object that any package can import
 145:     sub new { ... }
 146:     use define OBJECT => __PACKAGE__->new;
 147: 
 148:     # if DEBUG is false, the following statement isn't even compiled
 149:     warn "debugging stuff here" if DEBUG;
 150:     
 151:     my $title = "Snow white and the " . scalar DWARVES . " dwarves";
 152: 
 153:     #--- in package/file My::Module ---#
 154:     package My::Module
 155:     no define;
 156: 
 157:     warn "I prefer these dwarves: " join " ", DWARVES if DEBUG;
 158:     OBJECT->method(DWARVES);
 159: 
 160: =head1 DESCRIPTION
 161: 
 162: Use this pragma to define global constants.
 163: 
 164: =head1 USAGE
 165: 
 166: =head2 Defining constants
 167: 
 168: Global constants are defined through the same calling conventions 
 169: as C<constant.pm>:
 170: 
 171:   use define FOO => 3;
 172:   use define BAR => ( 1, 2, 3 );
 173:   use define { 
 174:     BAZ => 'dogs',
 175:     QUX => 'cats',
 176:   };
 177: 
 178: =head2 Importing constants by name
 179: 
 180: To use a global constant, you import it into your package as follows:
 181: 
 182:   no define FOO =>;
 183: 
 184: If FOO has been defined, it gets set to its defined value, otherwise it is set
 185: to undef. Note that the reason for the '=>' operator here is to parse FOO as 
 186: a string literal rather than a bareword (you could also do C<no define 'FOO'>).
 187: 
 188: =head2 Importing constants willy-nilly
 189: 
 190: To import ALL defined constants into your package, you can do the following:
 191: 
 192:   no define;
 193: 
 194: This is quick, but messy, as you can't predict what symbols may clash with
 195: those in your package's namespace.
 196: 
 197: =head1 NOTES
 198: 
 199: See L<constant/"constant.pm">. Most of the same caveats apply here.
 200: 
 201: Your code should be arranged so that any C<no define> statements are executed 
 202: after the C<use define> statement for a given symbol. If the order is reversed,
 203: a warning will be emitted.
 204: 
 205: As a rule, modules shouldn't be defining global constants; they should import
 206: constants defined by the main body of your program.
 207: 
 208: If a module does define a global constant (eg. a master object), the module 
 209: should be use'd before any other modules (or lines of code) that refer to the
 210: constant.
 211: 
 212: If you <use define> the same symbol more than once, a warning will be emitted.
 213: 
 214: =head1 AUTHOR
 215: 
 216:   Gary Gurevich (garygurevich at gmail)
 217: 
 218: =head1 COPYRIGHT AND LICENSE
 219: 
 220: Copyright (C) 2004 by Gary Gurevich
 221: 
 222: This library is free software; you can redistribute it and/or modify it under 
 223: the same terms as Perl itself.
 224: 
 225: =head1 SEE ALSO
 226: 
 227: constant(3), perl(1).
 228: 
 229: =cut