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