enum.pm
上传用户:market2
上传日期:2018-11-18
资源大小:18786k
文件大小:12k
源码类别:

外挂编程

开发平台:

Windows_Unix

  1. package enum;
  2. use strict;
  3. no strict 'refs';  # Let's just make this very clear right off
  4. use Carp;
  5. use vars qw($VERSION);
  6. $VERSION = do { my @r = (q$Revision: 1.16 $ =~ /d+/g); sprintf '%d.%03d'.'%02d' x ($#r-1), @r};
  7. my $Ident = '[^W_0-9]w*';
  8. sub ENUM    () { 1 }
  9. sub BITMASK () { 2 }
  10. sub import {
  11.     my $class   = shift;
  12.     @_ or return;       # Ignore 'use enum;'
  13.     my $pkg     = caller() . '::';
  14.     my $prefix  = '';   # default no prefix 
  15.     my $index   = 0;    # default start index
  16.     my $mode    = ENUM; # default to enum
  17.     ## Pragmas should be as fast as they can be, so we inline some
  18.     ## pieces.
  19.     foreach (@_) {
  20.         ## Plain tag is most common case
  21.         if (/^$Ident$/o) {
  22.             my $n = $index;
  23.             if ($mode == ENUM) {
  24.                 $index++;
  25.             }
  26.             elsif ($mode == BITMASK) {
  27.                 $index ||= 1;
  28.                 $index *= 2;
  29.                 if ( $index & ($index - 1) ) {
  30.                     croak (
  31.                         "$index is not a valid single bitmask "
  32.                         . " (Maybe you overflowed your system's max int value?)"
  33.                     );
  34.                 }
  35.             }
  36.             else {
  37.                 confess qq(Can't Happen: mode $mode invalid);
  38.             }
  39.             *{"$pkg$prefix$_"} = sub () { $n };
  40.         }
  41.         ## Index change
  42.         elsif (/^($Ident)=(-?)(.+)$/o) {
  43.             my $name= $1;
  44.             my $neg = $2;
  45.             $index  = $3;
  46.             ## Convert non-decimal numerics to decimal
  47.             if ($index =~ /^0x[da-f]+$/i) {    ## Hex
  48.                 $index = hex $index;
  49.             }
  50.             elsif ($index =~ /^0d/) {          ## Octal
  51.                 $index = oct $index;
  52.             }
  53.             elsif ($index !~ /[^d_]/) {        ## 123_456 notation
  54.                 $index =~ s/_//g;
  55.             }
  56.             ## Force numeric context, but only in numeric context
  57.             if ($index =~ /D/) {
  58.                 $index  = "$neg$index";
  59.             }
  60.             else {
  61.                 $index  = "$neg$index";
  62.                 $index  += 0;
  63.             }
  64.             my $n   = $index;
  65.             if ($mode == BITMASK) {
  66.                 ($index & ($index - 1))
  67.                     and croak "$index is not a valid single bitmask";
  68.                 $index *= 2;
  69.             }
  70.             elsif ($mode == ENUM) {
  71.                 $index++;
  72.             }
  73.             else {
  74.                 confess qq(Can't Happen: mode $mode invalid);
  75.             }
  76.             *{"$pkg$prefix$name"} = sub () { $n };
  77.         }
  78.         ## Prefix/option change
  79.         elsif (/^([A-Z]*):($Ident)?(=?)(-?)(.*)/) {
  80.             ## Option change
  81.             if ($1) {
  82.                 if      ($1 eq 'ENUM')      { $mode = ENUM;     $index = 0 }
  83.                 elsif   ($1 eq 'BITMASK')   { $mode = BITMASK;  $index = 1 }
  84.                 else    { croak qq(Invalid enum option '$1') }
  85.             }
  86.             my $neg = $4;
  87.             ## Index change too?
  88.             if ($3) {
  89.                 if (length $5) {
  90.                     $index = $5;
  91.                     ## Convert non-decimal numerics to decimal
  92.                     if ($index =~ /^0x[da-f]+$/i) {    ## Hex
  93.                         $index = hex $index;
  94.                     }
  95.                     elsif ($index =~ /^0d/) {          ## Oct
  96.                         $index = oct $index;
  97.                     }
  98.                     elsif ($index !~ /[^d_]/) {        ## 123_456 notation
  99.                         $index =~ s/_//g;
  100.                     }
  101.                     ## Force numeric context, but only in numeric context
  102.                     if ($index =~ /D/) {
  103.                         $index  = "$neg$index";
  104.                     }
  105.                     else {
  106.                         $index  = "$neg$index";
  107.                         $index  += 0;
  108.                     }
  109.                     ## Bitmask mode must check index changes
  110.                     if ($mode == BITMASK) {
  111.                         ($index & ($index - 1))
  112.                             and croak "$index is not a valid single bitmask";
  113.                     }
  114.                 }
  115.                 else {
  116.                     croak qq(No index value defined after "=");
  117.                 }
  118.             }
  119.             ## Incase it's a null prefix
  120.             $prefix = defined $2 ? $2 : '';
  121.         }
  122.         ## A..Z case magic lists
  123.         elsif (/^($Ident)..($Ident)$/o) {
  124.             ## Almost never used, so check last
  125.             foreach my $name ("$1" .. "$2") {
  126.                 my $n = $index;
  127.                 if ($mode == BITMASK) {
  128.                     ($index & ($index - 1))
  129.                         and croak "$index is not a valid single bitmask";
  130.                     $index *= 2;
  131.                 }
  132.                 elsif ($mode == ENUM) {
  133.                     $index++;
  134.                 }
  135.                 else {
  136.                     confess qq(Can't Happen: mode $mode invalid);
  137.                 }
  138.                 *{"$pkg$prefix$name"} = sub () { $n };
  139.             }
  140.         }
  141.         else {
  142.             croak qq(Can't define "$_" as enum type (name contains invalid characters));
  143.         }
  144.     }
  145. }
  146. 1;
  147. __END__
  148. =head1 NAME
  149. enum - C style enumerated types and bitmask flags in Perl
  150. =head1 SYNOPSIS
  151.   use enum qw(Sun Mon Tue Wed Thu Fri Sat);
  152.   # Sun == 0, Mon == 1, etc
  153.   use enum qw(Forty=40 FortyOne Five=5 Six Seven);
  154.   # Yes, you can change the start indexs at any time as in C
  155.   use enum qw(:Prefix_ One Two Three);
  156.   ## Creates Prefix_One, Prefix_Two, Prefix_Three
  157.   use enum qw(:Letters_ A..Z);
  158.   ## Creates Letters_A, Letters_B, Letters_C, ...
  159.   use enum qw(
  160.       :Months_=0 Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
  161.       :Days_=0   Sun Mon Tue Wed Thu Fri Sat
  162.       :Letters_=20 A..Z
  163.   );
  164.   ## Prefixes can be changed mid list and can have index changes too
  165.   use enum qw(BITMASK:LOCK_ SH EX NB UN);
  166.   ## Creates bitmask constants for LOCK_SH == 1, LOCK_EX == 2,
  167.   ## LOCK_NB == 4, and LOCK_UN == 8.
  168.   ## NOTE: This example is only valid on FreeBSD-2.2.5 however, so don't
  169.   ## actually do this.  Import from Fnctl instead.
  170. =head1 DESCRIPTION
  171. Defines a set of symbolic constants with ordered numeric values ala B<C> B<enum> types.
  172. Now capable of creating creating ordered bitmask constants as well.  See the B<BITMASKS>
  173. section for details.
  174. What are they good for?  Typical uses would be for giving mnemonic names to indexes of
  175. arrays.  Such arrays might be a list of months, days, or a return value index from
  176. a function such as localtime():
  177.   use enum qw(
  178.       :Months_=0 Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
  179.       :Days_=0   Sun Mon Tue Wed Thu Fri Sat
  180.       :LC_=0     Sec Min Hour MDay Mon Year WDay YDay Isdst
  181.   );
  182.   if ((localtime)[LC_Mon] == Months_Jan) {
  183.       print "It's January!n";
  184.   }
  185.   if ((localtime)[LC_WDay] == Days_Fri) {
  186.       print "It's Friday!n";
  187.   }
  188. This not only reads easier, but can also be typo-checked at compile time when
  189. run under B<use strict>.  That is, if you misspell B<Days_Fri> as B<Days_Fry>,
  190. you'll generate a compile error.
  191. =head1 BITMASKS, bitwise operations, and bitmask option values
  192. The B<BITMASK> option allows the easy creation of bitmask constants such as
  193. functions like flock() and sysopen() use.  These are also very useful for your
  194. own code as they allow you to efficiently store many true/false options within
  195. a single integer.
  196.     use enum qw(BITMASK: MY_ FOO BAR CAT DOG);
  197.     my $foo = 0;
  198.     $foo |= MY_FOO;
  199.     $foo |= MY_DOG;
  200.     
  201.     if ($foo & MY_DOG) {
  202.         print "foo has the MY_DOG option setn";
  203.     }
  204.     if ($foo & (MY_BAR | MY_DOG)) {
  205.         print "foo has either the MY_BAR or MY_DOG option setn"
  206.     }
  207.     $foo ^= MY_DOG;  ## Turn MY_DOG option off (set its bit to false)
  208. When using bitmasks, remember that you must use the bitwise operators, B<|>, B<&>, B<^>,
  209. and B<~>.  If you try to do an operation like C<$foo += MY_DOG;> and the B<MY_DOG> bit
  210. has already been set, you'll end up setting other bits you probably didn't want to set.
  211. You'll find the documentation for these operators in the B<perlop> manpage.
  212. You can set a starting index for bitmasks just as you can for normal B<enum> values,
  213. but if the given index isn't a power of 2 it won't resolve to a single bit and therefor
  214. will generate a compile error.  Because of this, whenever you set the B<BITFIELD:>
  215. directive, the index is automatically set to 1.  If you wish to go back to normal B<enum>
  216. mode, use the B<ENUM:> directive.  Similarly to the B<BITFIELD> directive, the B<ENUM:>
  217. directive resets the index to 0.  Here's an example:
  218.   use enum qw(
  219.       BITMASK:BITS_ FOO BAR CAT DOG
  220.       ENUM: FALSE TRUE
  221.       ENUM: NO YES
  222.       BITMASK: ONE TWO FOUR EIGHT SIX_TEEN
  223.   );
  224. In this case, B<BITS_FOO, BITS_BAR, BITS_CAT, and BITS_DOG> equal 1, 2, 4 and
  225. 8 respectively.  B<FALSE and TRUE> equal 0 and 1.  B<NO and YES> also equal
  226. 0 and 1.  And B<ONE, TWO, FOUR, EIGHT, and SIX_TEEN> equal, you guessed it, 1,
  227. 2, 4, 8, and 16.
  228. =head1 BUGS
  229. Enum names can not be the same as method, function, or constant names.  This
  230. is probably a Good Thing[tm].
  231. No way (that I know of) to cause compile time errors when one of these enum names get
  232. redefined.  IMHO, there is absolutely no time when redefining a sub is a Good Thing[tm],
  233. and should be taken out of the language, or at least have a pragma that can cause it
  234. to be a compile time error.
  235. Enumerated types are package scoped just like constants, not block scoped as some
  236. other pragma modules are.
  237. It supports A..Z nonsense.  Can anyone give me a Real World[tm] reason why anyone would
  238. ever use this feature...?
  239. =head1 HISTORY
  240.   $Log: enum.pm,v $
  241.   Revision 1.16  1999/05/27 16:00:35  byron
  242.   Fixed bug that caused bitwise operators to treat enum types as strings
  243.   instead of numbers.
  244.   Revision 1.15  1999/05/27 15:51:27  byron
  245.   Add support for negative values.
  246.   Added stricter hex value checks.
  247.   Revision 1.14  1999/05/13 15:58:18  byron
  248.   Fixed bug in hex index code that broke on 0xA.
  249.   Revision 1.13  1999/05/13 10:52:30  byron
  250.   Fixed auto-index bugs in new non-decimal numeric support.
  251.   Revision 1.12  1999/05/13 10:00:45  byron
  252.   Added support for non-decimal numeric representations ala 0x123, 0644, and
  253.   123_456.
  254.   First version committed to CVS.
  255.   Revision 1.11  1998/07/18 17:53:05  byron
  256.     -Added BITMASK and ENUM directives.
  257.     -Revamped documentation.
  258.   Revision 1.10  1998/06/12 20:12:50  byron
  259.     -Removed test code
  260.     -Released to CPAN
  261.   Revision 1.9  1998/06/12 00:21:00  byron
  262.     -Fixed -w warning when a null tag is used
  263.   Revision 1.8  1998/06/11 23:04:53  byron
  264.     -Fixed documentation bugs
  265.     -Moved A..Z case to last as it's not going to be used
  266.      as much as the other cases.
  267.   Revision 1.7  1998/06/10 12:25:04  byron
  268.     -Changed interface to match original design by Tom Phoenix
  269.      as implemented in an early version of enum.pm by Benjamin Holzman.
  270.     -Changed tag syntax to not require the 'PREFIX' string of Tom's
  271.      interface.
  272.     -Allow multiple prefix tags to be used at any point.
  273.     -Allowed index value changes from tags.
  274.   Revision 1.6  1998/06/10 03:37:57  byron
  275.     -Fixed superfulous -w warning
  276.   Revision 1.4  1998/06/10 01:07:03  byron
  277.     -Changed behaver to closer resemble C enum types
  278.     -Changed docs to match new behaver
  279. =head1 AUTHOR
  280. Zenin <zenin@archive.rhps.org>
  281. aka Byron Brummer <byron@omix.com>.
  282. Based off of the B<constant> module by Tom Phoenix.
  283. Original implementation of an interface of Tom Phoenix's
  284. design by Benjamin Holzman, for which we borrow the basic
  285. parse algorithm layout.
  286. =head1 COPYRIGHT
  287. Copyright 1998 (c) Byron Brummer.
  288. Copyright 1998 (c) OMIX, Inc.
  289. Permission to use, modify, and redistribute this module granted under
  290. the same terms as B<Perl>.
  291. =head1 SEE ALSO
  292. constant(3), perl(1).
  293. =cut