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