File Coverage

blib/lib/enum.pm
Criterion Covered Total %
statement 59 85 69.4
branch 29 60 48.3
condition 0 2 0.0
subroutine 6 6 100.0
pod n/a
total 94 153 61.4


line stmt bran cond sub pod time code
1             package enum;
2              
3 5     5   3925 use 5.006;
  5         17  
  5         184  
4 5     5   23 use strict;
  5         7  
  5         128  
5 5     5   23 use warnings;
  5         11  
  5         135  
6 5     5   23 no strict 'refs'; # Let's just make this very clear right off
  5         7  
  5         163  
7              
8 5     5   25 use Carp;
  5         7  
  5         5873  
9             our $VERSION = '1.10';
10              
11             my $Ident = '[^\W_0-9]\w*';
12              
13             sub ENUM () { 1 }
14             sub BITMASK () { 2 }
15              
16             sub import {
17 16     16   102 my $class = shift;
18 16 100       208 @_ or return; # Ignore 'use enum;'
19 11         26 my $pkg = caller() . '::';
20 11         17 my $prefix = ''; # default no prefix
21 11         12 my $index = 0; # default start index
22 11         16 my $mode = ENUM; # default to enum
23              
24             ## Pragmas should be as fast as they can be, so we inline some
25             ## pieces.
26 11         22 foreach (@_) {
27             ## Plain tag is most common case
28 204 100       9053 if (/^$Ident$/o) {
    100          
    100          
    50          
29 139         170 my $n = $index;
30              
31 139 50       240 if ($mode == ENUM) {
    0          
32 139         156 $index++;
33             }
34             elsif ($mode == BITMASK) {
35 0   0     0 $index ||= 1;
36 0         0 $index *= 2;
37 0 0       0 if ( $index & ($index - 1) ) {
38 0         0 croak (
39             "$index is not a valid single bitmask "
40             . " (Maybe you overflowed your system's max int value?)"
41             );
42             }
43             }
44             else {
45 0         0 confess qq(Can't Happen: mode $mode invalid);
46             }
47              
48 139         7424 *{"$pkg$prefix$_"} = eval "sub () { $n }";
  139         1212  
49             }
50              
51             ## Index change
52             elsif (/^($Ident)=(-?)(.+)$/o) {
53 25         50 my $name= $1;
54 25         42 my $neg = $2;
55 25         35 $index = $3;
56              
57             ## Convert non-decimal numerics to decimal
58 25 50       123 if ($index =~ /^0x[0-9a-f]+$/i) { ## Hex
    50          
    50          
59 0         0 $index = hex $index;
60             }
61             elsif ($index =~ /^0[0-9]/) { ## Octal
62 0         0 $index = oct $index;
63             }
64             elsif ($index !~ /[^0-9_]/) { ## 123_456 notation
65 25         39 $index =~ s/_//g;
66             }
67              
68             ## Force numeric context, but only in numeric context
69 25 50       61 if ($index =~ /\D/) {
70 0         0 $index = "$neg$index";
71             }
72             else {
73 25         44 $index = "$neg$index";
74 25         45 $index += 0;
75             }
76              
77 25         34 my $n = $index;
78              
79 25 50       71 if ($mode == BITMASK) {
    50          
80 0 0       0 ($index & ($index - 1))
81             and croak "$index is not a valid single bitmask";
82 0         0 $index *= 2;
83             }
84             elsif ($mode == ENUM) {
85 25         30 $index++;
86             }
87             else {
88 0         0 confess qq(Can't Happen: mode $mode invalid);
89             }
90              
91 25         1303 *{"$pkg$prefix$name"} = eval "sub () { $n }";
  25         190  
92             }
93              
94             ## Prefix/option change
95             elsif (/^([A-Z]*):($Ident)?(=?)(-?)(.*)/) {
96             ## Option change
97 30 50       94 if ($1) {
98 0 0       0 if ($1 eq 'ENUM') { $mode = ENUM; $index = 0 }
  0 0       0  
  0         0  
99 0         0 elsif ($1 eq 'BITMASK') { $mode = BITMASK; $index = 1 }
  0         0  
100 0         0 else { croak qq(Invalid enum option '$1') }
101             }
102              
103 30         58 my $neg = $4;
104              
105             ## Index change too?
106 30 100       84 if ($3) {
107 20 50       50 if (length $5) {
108 20         72 $index = $5;
109              
110             ## Convert non-decimal numerics to decimal
111 20 50       109 if ($index =~ /^0x[0-9a-f]+$/i) { ## Hex
    50          
    50          
112 0         0 $index = hex $index;
113             }
114             elsif ($index =~ /^0[0-9]/) { ## Oct
115 0         0 $index = oct $index;
116             }
117             elsif ($index !~ /[^0-9_]/) { ## 123_456 notation
118 20         34 $index =~ s/_//g;
119             }
120              
121             ## Force numeric context, but only in numeric context
122 20 50       53 if ($index =~ /[^0-9]/) {
123 0         0 $index = "$neg$index";
124             }
125             else {
126 20         38 $index = "$neg$index";
127 20         47 $index += 0;
128             }
129              
130             ## Bitmask mode must check index changes
131 20 50       49 if ($mode == BITMASK) {
132 0 0       0 ($index & ($index - 1))
133             and croak "$index is not a valid single bitmask";
134             }
135             }
136             else {
137 0         0 croak qq(No index value defined after "=");
138             }
139             }
140              
141             ## Incase it's a null prefix
142 30 100       729 $prefix = defined $2 ? $2 : '';
143             }
144              
145             ## A..Z case magic lists
146             elsif (/^($Ident)\.\.($Ident)$/o) {
147             ## Almost never used, so check last
148 10         47 foreach my $name ("$1" .. "$2") {
149 260         319 my $n = $index;
150              
151 260 50       697 if ($mode == BITMASK) {
    50          
152 0 0       0 ($index & ($index - 1))
153             and croak "$index is not a valid single bitmask";
154 0         0 $index *= 2;
155             }
156             elsif ($mode == ENUM) {
157 260         310 $index++;
158             }
159             else {
160 0         0 confess qq(Can't Happen: mode $mode invalid);
161             }
162              
163 260         18015 *{"$pkg$prefix$name"} = eval "sub () { $n }";
  260         2053  
164             }
165             }
166              
167             else {
168 0           croak qq(Can't define "$_" as enum type (name contains invalid characters));
169             }
170             }
171             }
172              
173             1;
174              
175             __END__