File Coverage

blib/lib/Business/UPC.pm
Criterion Covered Total %
statement 85 96 88.5
branch 23 48 47.9
condition 12 14 85.7
subroutine 23 25 92.0
pod 0 19 0.0
total 143 202 70.7


line stmt bran cond sub pod time code
1             package Business::UPC;
2              
3             # Copyright (c) 1998-2017 Rob Fugina
4              
5 8     8   30586 use strict;
  8         10  
  8         208  
6 8     8   24 use vars qw($VERSION);
  8         8  
  8         10186  
7              
8             $VERSION = '0.06';
9              
10             # Preloaded methods go here.
11              
12             sub new
13             {
14 54     54 0 121 my $class = shift;
15 54         51 my $value = shift;
16              
17 54 50       104 return undef if length($value) > 12;
18              
19 54         83 my ($number_system, $mfr_id, $prod_id, $check_digit) = unpack("AA5A5A", _zeropad($value));
20              
21 54 50       175 return undef unless $number_system =~ m/^\d$/;
22 54 50       107 return undef unless $mfr_id =~ m/^\d{5}$/;
23 54 50       99 return undef unless $prod_id =~ m/^\d{5}$/;
24 54 50       88 return undef unless $check_digit =~ m/^[\dx]$/i;
25              
26 54 50 100     212 return undef if ($number_system == 0 && $mfr_id == 0 && $prod_id == 0);
      66        
27              
28 54         149 my $upc = bless {
29             number_system => $number_system,
30             mfr_id => $mfr_id,
31             prod_id => $prod_id,
32             check_digit => $check_digit,
33             }, $class;
34              
35 54         142 return $upc;
36             }
37              
38             # alternate constructor: for creating from a zero-supressed (type E) value
39             sub type_e
40             {
41 13     13 0 25 my $class = shift;
42 13         10 my $value = shift;
43              
44 13 50       27 return undef if length($value) > 8;
45              
46 13         16 my $expanded = _expand_upc_e($value);
47              
48 13 50       34 return new Business::UPC($expanded) if $expanded;
49 0         0 return undef;
50             }
51              
52             sub number_system
53             {
54 69     69 0 56 my $attrname = 'number_system';
55 69         49 my $self = shift;
56 69 50       123 warn "UPC atribute '$attrname' is not settable." if (@_);
57 69         153 return $self->{$attrname};
58             }
59              
60             sub mfr_id
61             {
62 62     62 0 48 my $attrname = 'mfr_id';
63 62         44 my $self = shift;
64 62 50       80 warn "UPC atribute '$attrname' is not settable." if (@_);
65 62         128 return $self->{$attrname};
66             }
67              
68             sub prod_id
69             {
70 65     65 0 49 my $attrname = 'prod_id';
71 65         51 my $self = shift;
72 65 50       84 warn "UPC atribute '$attrname' is not settable." if (@_);
73 65         147 return $self->{$attrname};
74             }
75              
76             sub check_digit
77             {
78 63     63 0 396 my $attrname = 'check_digit';
79 63         61 my $self = shift;
80 63 50       95 warn "UPC atribute '$attrname' is not settable." if (@_);
81 63         231 return $self->{$attrname};
82             }
83              
84             sub as_upc_a
85             {
86 2     2 0 3 my $self = shift;
87 2         3 return $self->number_system . $self->mfr_id . $self->prod_id . $self->check_digit;
88             }
89              
90             sub as_upc_a_nocheck
91             {
92 0     0 0 0 my $self = shift;
93 0         0 return $self->number_system . $self->mfr_id . $self->prod_id;
94             }
95              
96             sub as_upc
97             {
98 2     2 0 3 my $self = shift;
99 2         4 return $self->as_upc_a
100             }
101              
102             sub as_upca_nocheckdigit
103             {
104 56     56 0 44 my $self = shift;
105 56         75 return $self->number_system . $self->mfr_id . $self->prod_id;
106             }
107              
108             sub number_system_description
109             {
110 1     1 0 14 my $self = shift;
111 1         2 return $Business::UPC::NumberSystems{$self->number_system};
112             }
113              
114             sub coupon_value_code
115             {
116 1     1 0 1 my $self = shift;
117 1 50       2 return undef unless $self->is_coupon;
118 1         2 return substr($self->prod_id, -2);
119             }
120              
121             sub coupon_value
122             {
123 1     1 0 2 my $self = shift;
124 1 50       3 return undef unless $self->is_coupon;
125 1         3 return $Business::UPC::CouponValues{$self->coupon_value_code};
126             }
127              
128             sub coupon_family_code
129             {
130 2     2 0 3 my $self = shift;
131 2 50       6 return undef unless $self->is_coupon;
132 2         3 return substr($self->prod_id, 0, 3);
133             }
134              
135             sub coupon_family_description
136             {
137 1     1 0 2 my $self = shift;
138 1         2 my $cfc = $self->coupon_family_code;
139 1   50     9 return $Business::UPC::CouponFamilies{$cfc} || 'Unknown';
140             }
141              
142             sub is_valid
143             {
144 53     53 0 1153 my $self = shift;
145 53         82 return (_check_digit($self->as_upca_nocheckdigit) eq $self->check_digit);
146             }
147              
148             sub is_coupon
149             {
150 6     6 0 409 my $self = shift;
151 6         12 return ($self->number_system eq '5');
152             }
153              
154             sub fix_check_digit
155             {
156 3     3 0 365 my $self = shift;
157 3         9 $self->{check_digit} = _check_digit($self->as_upca_nocheckdigit);
158 3         9 $self;
159             }
160              
161             sub as_upc_e
162             {
163 0     0 0 0 my $self = shift;
164              
165 0         0 my $upca = $self->as_upc_a;
166              
167 0 0       0 return $upca if ($upca =~ s/^0(\d{2})([012])0000(\d{3})(\d)$/0${1}${3}${2}${4}/);
168 0 0       0 return $upca if ($upca =~ s/^0(\d{2}[3-9])00000(\d{2})(\d)$/0${1}${2}3${3}/);
169 0 0       0 return $upca if ($upca =~ s/^0(\d{3}[1-9])00000(\d)(\d)$/0${1}${2}4${3}/);
170 0 0       0 return $upca if ($upca =~ s/^0(\d{4}[1-9])0000([5-9])(\d)$/0${1}${2}${3}/);
171 0         0 return undef;
172             }
173              
174             # private functions: don't use these!
175              
176             sub _check_digit
177             {
178 56     56   48 my $num = shift;
179              
180 56         144 my @digits = split(//, $num);
181              
182             # To avoid warning when summing below.
183 56         59 push @digits, 0;
184              
185 56         51 my $sum = 0;
186              
187 56         72 foreach my $i (0, 2, 4, 6, 8, 10)
188             {
189 336   100     609 $sum += 3 * ($digits[$i] || 0);
190 336   100     652 $sum += $digits[$i+1] || 0;
191             }
192              
193 56         160 return (10 - ($sum % 10)) % 10;
194             }
195              
196             sub _zeropad
197             {
198 67     67   54 my $num = shift;
199 67   100     170 my $length = shift || 12;
200 67         302 return sprintf("%0${length}s", $num);
201             }
202              
203             sub _expand_upc_e
204             {
205 13     13   18 my $upc_e = _zeropad(shift, 8);
206              
207 13 50       16 return undef if (length($upc_e) > 8);
208              
209 13 100       82 return $upc_e if ($upc_e =~ s/^0(\d{2})(\d{3})([012])([\dx])$/0${1}${3}0000${2}${4}/i);
210 8 100       23 return $upc_e if ($upc_e =~ s/^0(\d{3})(\d{2})3([\dx])$/0${1}00000${2}${3}/i);
211 7 100       21 return $upc_e if ($upc_e =~ s/^0(\d{4})(\d)4([\dx])$/0${1}00000${2}${3}/i);
212 6 50       41 return $upc_e if ($upc_e =~ s/^0(.....)([5-9])([\dx])$/0${1}0000${2}${3}/i);
213 0           return undef;
214             }
215              
216             BEGIN
217             {
218 8     8   142 %Business::UPC::NumberSystems = (
219             '0' => 'Regular Item',
220             '1' => 'Reserved',
221             '2' => 'Random-Weight Item',
222             '3' => 'National Drug/Health-Related Item',
223             '4' => 'For Private Use',
224             '5' => 'Coupon',
225             '6' => 'Regular Item',
226             '7' => 'Regular Item',
227             '8' => 'Reserved',
228             '9' => 'Reserved',
229             );
230 8         102 %Business::UPC::CouponFamilies = (
231             '000' => 'Anything from Same Manufacturer',
232             '001' => 'Reserved',
233             '002' => 'Reserved',
234             '003' => 'Reserved',
235             '004' => 'Reserved',
236             '005' => 'Reserved',
237             '006' => 'Reserved',
238             '007' => 'Reserved',
239             '008' => 'Reserved',
240             '009' => 'Reserved',
241             '990' => 'Reserved',
242             '991' => 'Reserved',
243             '992' => 'Reserved',
244             '993' => 'Reserved',
245             '994' => 'Reserved',
246             '995' => 'Reserved',
247             '996' => 'Reserved',
248             '997' => 'Reserved',
249             '998' => 'Reserved',
250             '999' => 'Reserved',
251             );
252 8         484 %Business::UPC::CouponValues = (
253             '00' => 'Checker Intervention',
254             '01' => 'Free Merchandise',
255             '02' => 'Buy 4 or more, get 1 free (same product)',
256             '03' => '$1.10',
257             '04' => '$1.35',
258             '05' => 'Reserved for Future Use',
259             '06' => '$1.60',
260             '07' => 'Reserved for Future Use',
261             '08' => 'Reserved for Future Use',
262             '09' => 'Reserved for Future Use',
263             '10' => '$0.10',
264             '11' => '$1.85',
265             '12' => '$0.12',
266             '13' => 'Reserved for Future Use',
267             '14' => 'Buy 1, get 1 free (same product)',
268             '15' => '$0.15',
269             '16' => 'Buy 2, get 1 free (same product)',
270             '17' => '$2.10',
271             '18' => '$2.60',
272             '19' => 'Buy 3, get 1 free (same product)',
273             '20' => '$0.20',
274             '21' => 'Buy 2 or more, get $0.35 off',
275             '22' => 'Buy 2 or more, get $0.40 off',
276             '23' => 'Buy 2 or more, get $0.45 off',
277             '24' => 'Buy 2, get $0.50 off',
278             '25' => '$0.25',
279             '26' => '$2.85',
280             '27' => 'Reserved for Future Use',
281             '28' => 'Buy 2, get $0.55 off',
282             '29' => '$0.29',
283             '30' => '$0.30',
284             '31' => 'Buy 2 or more, get $0.60 off',
285             '32' => 'Buy 2 or more, get $0.75 off',
286             '33' => 'Buy 2, get $1.00 off',
287             '34' => 'Buy 2 or more, get $1.25 off',
288             '35' => '$0.35',
289             '36' => 'Buy 2 or more, get $1.50 off',
290             '37' => 'Buy 3 or more, get $0.25 off',
291             '38' => 'Buy 3 or more, get $0.30 off',
292             '39' => '$0.39',
293             '40' => '$0.40',
294             '41' => 'Buy 3 or more, get $0.50 off',
295             '42' => 'Buy 3 or more, get $1.00 off',
296             '43' => 'Buy 2 or more, get $1.10 off',
297             '44' => 'Buy 2 or more, get $1.35 off',
298             '45' => '$0.45',
299             '46' => 'Buy 2 or more, get $1.60 off',
300             '47' => 'Buy 2 or more, get $1.75 off',
301             '48' => 'Buy 2 or more, get $1.85 off',
302             '49' => '$0.49',
303             '50' => '$0.50',
304             '51' => 'Buy 2 or more, get $2.00 off',
305             '52' => 'Buy 3 or more, get $0.55 off',
306             '53' => 'Buy 2 or more, get $0.10 off',
307             '54' => 'Buy 2 or more, get $0.15 off',
308             '55' => '$0.55',
309             '56' => 'Buy 2 or more, get $0.20 off',
310             '57' => 'Buy 2, get $0.25 off',
311             '58' => 'Buy 2, get $0.30 off',
312             '59' => '$0.59',
313             '60' => '$0.60',
314             '61' => '$10.00',
315             '62' => '$9.50',
316             '63' => '$9.00',
317             '64' => '$8.50',
318             '65' => '$0.65',
319             '66' => '$8.00',
320             '67' => '$7.50',
321             '68' => '$7.00',
322             '69' => '$0.69',
323             '70' => '$0.70',
324             '71' => '$6.50',
325             '72' => '$6.00',
326             '73' => '$5.50',
327             '74' => '$5.00',
328             '75' => '$0.75',
329             '76' => '$1.00',
330             '77' => '$1.25',
331             '78' => '$1.50',
332             '79' => '$0.79',
333             '80' => '$0.80',
334             '81' => '$1.75',
335             '82' => '$2.00',
336             '83' => '$2.25',
337             '84' => '$2.50',
338             '85' => '$0.85',
339             '86' => '$2.75',
340             '87' => '$3.00',
341             '88' => '$3.25',
342             '89' => '$0.89',
343             '90' => '$0.90',
344             '91' => '$3.50',
345             '92' => '$3.75',
346             '93' => '$4.00',
347             '94' => '$4.25',
348             '95' => '$0.95',
349             '96' => '$4.50',
350             '97' => '$4.75',
351             '98' => 'Buy 2 or more, get $0.65 off',
352             '99' => '$0.99',
353             );
354             }
355              
356             # Autoload methods go after =cut, and are processed by the autosplit program.
357              
358             1;
359             __END__