0: # UPDATE: 
1: #  this is currently available as Devel::Constants on CPAN
2: #  but the name may change.  suggestions welcome.
3: #
4: # this is in response to node #117146, of course
5: 
6: package constant::flags;
7: 
8: use strict;
9: use vars qw( $VERSION );
10: 
11: $VERSION = '0.10';
12: 
13: use constant;
14: use subs ('oldimport');
15: 
16: {
17: 	local $^W = 0;
18: 	*oldimport = \&constant::import;
19: 	*constant::import = \&newimport;
20: }
21: 
22: 
23: my %flags;
24: 
25: sub import {
26: 	my $class = shift;
27: 
28: 	my $to_names;
29: 	my $pkg = caller();
30: 	my $flagholder = {};
31: 
32: 	while (my $arg = shift) {
33: 		if (ref($arg) eq 'HASH') {
34: 			$flagholder = $arg;
35: 
36: 		} elsif ($arg eq 'to_names') {
37: 			$to_names = shift || 'to_names';
38: 		} elsif ($arg eq 'package') {
39: 			$pkg = shift if @_;
40: 		}
41: 	}
42: 
43: 	$flags{$pkg} = $flagholder;
44: 
45: 	if ($to_names) {
46: 		no strict 'refs';
47: 		*{ $pkg . "::$to_names" } = \&to_names;
48: 	}
49: }
50: 
51: sub newimport {
52: 	my ($class, @args) = @_;
53: 	my $pkg = caller();
54: 
55: 	if (defined $flags{$pkg}) {
56: 		while (@args) {
57: 			my ($name, $val) = splice(@args, 0, 2);
58: 			last unless $val;
59: 			$flags{$pkg}{$val} = $name;
60: 		}
61: 	}
62: 
63: 	goto &oldimport;
64: }
65: 
66: sub to_names {
67: 	my ($val, $pkg) = @_;
68: 	$pkg ||= caller(); 
69: 	
70: 	my $flags = $flags{$pkg} or return;
71: 
72: 	my @flags;
73: 	foreach my $flag (keys %$flags) {
74: 		push @flags, $flags->{$flag} if $val & $flag;
75: 	}
76: 	return wantarray() ? @flags : join(' ', @flags);
77: }
78: 
79: 1;
80: __END__
81: 
82: =head1 NAME
83: 
84: constant::flags - Perl module to translate constants back to their named symbols
85: 
86: =head1 SYNOPSIS
87: 
88: 	# must precede use constant
89: 	use constant::flags;
90: 
91: 	use constant A => 1;
92: 	use constant B => 2;
93: 	use constant C => 4;
94: 
95: 	my $flag = A | B;
96: 	print "Flag is: ", join(' and ', to_names($flag) ), "\n";
97: 
98: =head1 DESCRIPTION
99: 
100: Declaring constants is very convenient for writing programs, but as they're
101: often inlined by Perl, retrieving their symbolic names can be tricky.  This is
102: made worse with lowlevel modules that use constants for bit-twiddling.
103: 
104: constant::flags makes this much more manageable.
105: 
106: It silently wraps around the L<constant> module, intercepting all constant
107: declarations.  It builds a hash, associating the values to their names.  The
108: names can then be retrieved as necessary.
109: 
110: Note that constant::flags B<must> be used B<before> L<constant> is, or the
111: magic will not work and you will be very disappointed.  This is very important,
112: and if you ignore this warning, the authors will feel free to laugh at you.  At
113: least a little.
114: 
115: By default, constant::flags will only intercept constant declarations within
116: the same package that used the module.  Also by default, it stores the
117: constants for a package within a private (read, otherwise inaccessible)
118: variable.  Both of these can be overridden.
119: 
120: By default, constant::flags exports one subroutine into the caller's namespace. 
121: It is normally called C<to_names>.  This may change in future versions, and it
122: may no longer be exported.  By passing the C<to_names> parameter to
123: constant::flags, it is possible to change the name of this function:
124: 
125: 	use constant::flags to_names => 'resolve';
126: 
127: 	use constant FOO => 1;
128: 	use constant BAR => 2;
129: 
130: 	print resolve(2);
131: 
132: Passing the C<package> flag to constant::flags with a valid package name will
133: make the module intercept all constants subsequently declared within that
134: package.  For example, in package main one might say:
135: 
136: 	use constant::flags package => NetPacket::TCP;
137: 	use NetPacket::TCP;
138: 
139: All of the TCP flags declared within L<NetPacket::TCP> are now available.
140: 
141: It is also possible to pass in a hash reference where the constant values and
142: names wil be stored:
143: 
144: 	my %constant_map;
145: 	use constant::flags \%constant_map;
146: 
147: 	use constant NAME	=> 1;
148: 	use constant RANK	=> 2;
149: 	use constant SERIAL	=> 4;
150: 
151: 	print join(' ', values %constant_map), "\n";
152: 
153: =head2 EXPORT
154: 
155: C<to_names>, currently.  This may change in the future.  Note that L<constant>
156: also exports, by design.
157: 
158: =head1 FUNCTIONS
159: 
160: =over 4
161: 
162: =item C<to_names($flag, [ $package ])>
163: 
164: This function resolves a flag into its component named bits.  This is generally
165: only useful for flags known to be composed of named constants logically
166: combined.  It can be very handy though.  The first parameter is required, and
167: must be the flag to decompose.  It is not modified.  The second parameter is
168: optional.  If provided, it will use flags set in another package.  In the
169: L<NetPacket::TCP> example above, it could be used to find the symbolic names of
170: TCP packets, such as SYN or RST set on a NetPacket::TCP object.
171: 
172: =back
173: 
174: =head1 HISTORY
175: 
176: =over 4
177: 
178: =item * 0.10 (7 October 2001)
179: 
180: Initial version.
181: 
182: =back
183: 
184: =head1 TODO
185: 
186: =over 4
187: 
188: =item * figure out a better way to handle C<to_names>
189: 
190: =item * allow potential capture lists?
191: 
192: =item * access only one constant at a time (more general than flags)
193: 
194: =item * sync up better with allowed constant names in C<constant>
195: 
196: =back
197: 
198: =head1 AUTHOR
199: 
200: chromatic <chromatic@wgz.org>, with thanks to "Benedict" at Perlmonks.org for
201: the germ of the idea (L<http://perlmonks.org/index.pl?node_id=117146>).
202: 
203: Thanks also to Tim Potter and Stephanie Wehner for C<NetPacket::TCP>, though
204: they don't know it yet.  :)
205: 
206: =head1 SEE ALSO
207: 
208: L<constant>
209: 
210: =cut