File Coverage

blib/lib/PDF/Builder/Resource/XObject/Form/BarCode/code128.pm
Criterion Covered Total %
statement 87 101 86.1
branch 39 62 62.9
condition 9 20 45.0
subroutine 9 9 100.0
pod 1 6 16.6
total 145 198 73.2


line stmt bran cond sub pod time code
1             package PDF::Builder::Resource::XObject::Form::BarCode::code128;
2              
3 2     2   1600 use base 'PDF::Builder::Resource::XObject::Form::BarCode';
  2         6  
  2         274  
4              
5 2     2   15 use strict;
  2         4  
  2         42  
6 2     2   10 use warnings;
  2         5  
  2         3756  
7              
8             our $VERSION = '3.025'; # VERSION
9             our $LAST_UPDATE = '3.024'; # manually update whenever code is changed
10              
11             =head1 NAME
12              
13             PDF::Builder::Resource::XObject::Form::BarCode::code128 - Code 128 and EAN-128 barcode support
14              
15             =head1 METHODS
16              
17             =over
18              
19             =item $res = PDF::Builder::Resource::XObject::Form::BarCode::code128->new($pdf, %options)
20              
21             Returns a code128 object. Use 'ean' option to encode using EAN128 mode.
22              
23             =back
24              
25             =cut
26              
27             sub new {
28 1     1 1 5 my ($class, $pdf, %options) = @_;
29             # copy dashed option names to preferred undashed names
30 1 50 33     7 if (defined $options{'-ean'} && !defined $options{'ean'}) { $options{'ean'} = delete($options{'-ean'}); }
  0         0  
31 1 50 33     7 if (defined $options{'-code'} && !defined $options{'code'}) { $options{'code'} = delete($options{'-code'}); }
  1         3  
32 1 50 33     4 if (defined $options{'-type'} && !defined $options{'type'}) { $options{'type'} = delete($options{'-type'}); }
  0         0  
33              
34 1 50       2 $class = ref($class) if ref($class);
35              
36 1         8 my $self = $class->SUPER::new($pdf, %options);
37              
38 1         3 my @bars;
39 1 50       14 if ($options{'ean'}) {
40 0         0 @bars = $self->encode_ean128($options{'code'});
41             } else {
42 1         5 @bars = $self->encode_128($options{'type'}, $options{'code'});
43             }
44              
45 1         11 $self->drawbar(\@bars, $options{'caption'});
46              
47 1         6 return $self;
48             }
49              
50             # CODE-A Encoding Table
51             my $code128a = q| !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_| . join('', map { chr($_) } (0..31)) . qq/\xf3\xf2\x80\xcc\xcb\xf4\xf1\x8a\x8b\x8c\xff/;
52              
53             # CODE-B Encoding Table
54             my $code128b = q| !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|.qq/|}~\x7f\xf3\xf2\x80\xcc\xf4\xca\xf1\x8a\x8b\x8c\xff/;
55              
56             # CODE-C Encoding Table (00-99 are placeholders)
57             my $code128c = ("\xfe" x 100) . qq/\xcb\xca\xf1\x8a\x8b\x8c\xff/;
58              
59             # START A-C
60             my $bar128Sa = "\x8a";
61             my $bar128Sb = "\x8b";
62             my $bar128Sc = "\x8c";
63              
64             # FNC1-FNC4
65             my $bar128F1 = "\xf1";
66             my $bar128F2 = "\xf2";
67             my $bar128F3 = "\xf3";
68             my $bar128F4 = "\xf4";
69              
70             # CODE A-C
71             my $bar128Ca = "\xca";
72             my $bar128Cb = "\xcb";
73             my $bar128Cc = "\xcc";
74              
75             # SHIFT
76             my $bar128sh = "\x80";
77              
78             # STOP
79             my $bar128St = "\xff";
80              
81             # Note: The stop code (last position) is longer than the other codes because
82             # it also has the termination bar appended, rather than requiring it be added
83             # as a separate call.
84             my @bar128 = qw(
85             212222 222122 222221 121223 121322 131222 122213 122312 132212 221213
86             221312 231212 112232 122132 122231 113222 123122 123221 223211 221132
87             221231 213212 223112 312131 311222 321122 321221 312212 322112 322211
88             212123 212321 232121 111323 131123 131321 112313 132113 132311 211313
89             231113 231311 112133 112331 132131 113123 113321 133121 313121 211331
90             231131 213113 213311 213131 311123 311321 331121 312113 312311 332111
91             314111 221411 431111 111224 111422 121124 121421 141122 141221 112214
92             112412 122114 122411 142112 142211 241211 221114 413111 241112 134111
93             111242 121142 121241 114212 124112 124211 411212 421112 421211 212141
94             214121 412121 111143 111341 131141 114113 114311 411113 411311 113141
95             114131 311141 411131 b1a4a2 b1a2a4 b1a2c2 b3c1a1b
96             );
97              
98             sub encode_128_char_idx {
99 37     37 0 79 my ($code, $char) = @_;
100              
101 37         52 my $index;
102              
103 37 100       110 if (lc($code) eq 'a') {
    100          
    50          
104             # Ignore CODE-A request if we're already in CODE-A
105 6 50       14 return if $char eq $bar128Ca;
106              
107 6         11 $index = index($code128a, $char);
108             } elsif (lc($code) eq 'b') {
109             # Ignore CODE-B request if we're already in CODE-B
110 10 50       26 return if $char eq $bar128Cb;
111 10         19 $index = index($code128b, $char);
112             } elsif (lc($code) eq 'c') {
113             # Ignore CODE-C request if we're already in CODE-C
114 21 50       37 return if $char eq $bar128Cc;
115              
116 21 100       53 if ($char =~ /^([0-9][0-9])$/) {
117 15         32 $index = $1;
118             } else {
119 6         12 $index = index($code128c, $char);
120             }
121             }
122              
123 37         109 return ($bar128[$index], $index);
124             }
125              
126             sub encode_128_char {
127 10     10 0 23 my ($code, $char) = @_;
128              
129 10         23 my ($b) = encode_128_char_idx($code, $char);
130 10         22 return $b;
131             }
132              
133             sub encode_128_string {
134 5     5 0 12 my ($code, $string) = @_;
135              
136 5         10 my ($bar, $index, @bars, @checksum);
137 5         22 my @characters = split(//, $string);
138              
139 5         14 my $character;
140 5         28 while (defined($character = shift @characters)) {
141 26 100       72 if ($character =~ /[\xf1-\xf4]/) {
    50          
142             # CODE-C doesn't have FNC2-FNC4
143 1 50 33     5 if ($character =~ /[\xf2-\xf4]/ and $code eq 'c') {
144 0         0 ($bar, $index) = encode_128_char_idx($code, "\xCB");
145 0         0 push @bars, $bar;
146 0         0 push @checksum, $index;
147 0         0 $code = 'b';
148             }
149              
150 1         5 ($bar, $index) = encode_128_char_idx($code, $character);
151             } elsif ($character =~ /[\xCA-\xCC]/) {
152 0         0 ($bar, $index) = encode_128_char_idx($code, $character);
153 0 0       0 $code = ($character eq "\xCA"? 'a':
    0          
154             $character eq "\xCB"? 'b': 'c');
155             } else {
156 25 100       42 if ($code ne 'c') {
157             # SHIFT: Switch codes for the following character only
158 9 50       18 if ($character eq $bar128sh) {
159 0         0 ($bar, $index) = encode_128_char_idx($code, $character);
160 0         0 push @bars, $bar;
161 0         0 push @checksum, $index;
162 0         0 $character = shift(@characters);
163 0 0       0 ($bar, $index) = encode_128_char_idx($code eq 'a'? 'b': 'a', $character);
164             } else {
165 9         17 ($bar, $index) = encode_128_char_idx($code, $character);
166             }
167             } else {
168 16 100 50     76 $character .= shift(@characters) if $character =~ /\d/ and scalar @characters;
169 16 100 66     79 if ($character =~ /^[^\d]*$/ or $character =~ /^\d[^\d]*$/) {
170 1         6 ($bar, $index) = encode_128_char_idx($code, "\xCB");
171 1         4 push @bars, $bar;
172 1         4 push @checksum, $index;
173 1         4 $code = 'b';
174             }
175 16 100       42 if ($character =~ /^\d[^\d]*$/) {
176 1 50       7 unshift(@characters, substr($character, 1, 1)) if length($character) > 1;
177 1         3 $character = substr($character, 0, 1);
178             }
179 16         29 ($bar, $index) = encode_128_char_idx($code, $character);
180             }
181             }
182 26 100       70 $character = '' if $character =~ /[^\x20-\x7e]/;
183 26         57 push @bars, [$bar, $character];
184 26         61 push @checksum, $index;
185             }
186 5         25 return ([@bars], @checksum);
187             }
188              
189             sub encode_128 {
190 5     5 0 2119 my ($self, $code, $string) = @_;
191 5         12 my @bars;
192             my $checksum_value;
193              
194             # Default to Code C if all characters are digits (and there are at
195             # least two of them). Otherwise, default to Code B.
196 5 50 66     20 $code ||= $string =~ /^\d{2,}$/? 'c': 'b';
197              
198             # Allow the character set to be passed as a capital letter
199             # (consistent with the specification).
200 5 50       22 $code = lc($code) if $code =~ /^[A-C]$/;
201              
202             # Ensure a valid character set has been chosen.
203 5 50       18 die "Character set must be A, B, or C (not '$code')" unless $code =~ /^[a-c]$/;
204              
205 5 100       23 if ($code eq 'a') {
    100          
    50          
206 1         4 push @bars, encode_128_char($code, $bar128Sa);
207 1         2 $checksum_value = 103;
208             } elsif ($code eq 'b') {
209 2         6 push @bars, encode_128_char($code, $bar128Sb);
210 2         6 $checksum_value = 104;
211             } elsif ($code eq 'c') {
212 2         8 push @bars, encode_128_char($code, $bar128Sc);
213 2         5 $checksum_value = 105;
214             }
215 5         14 my ($bar, @checksum_values) = encode_128_string($code, $string);
216              
217 5         11 push @bars, @{$bar};
  5         11  
218              
219             # Calculate the checksum value
220 5         17 foreach my $i (1 .. scalar @checksum_values) {
221 27         44 $checksum_value += $i * $checksum_values[$i - 1];
222             }
223 5         11 $checksum_value %= 103;
224 5         13 push @bars, $bar128[$checksum_value];
225 5         11 push @bars, encode_128_char($code, $bar128St);
226              
227 5         27 return @bars;
228             }
229              
230             sub encode_ean128 {
231 1     1 0 730 my ($self, $string) = @_;
232              
233 1         5 $string =~ s/[^a-zA-Z\d]+//g;
234 1         7 $string =~ s/(\d+)([a-zA-Z]+)/$1\xcb$2/g;
235 1         3 $string =~ s/([a-zA-Z]+)(\d+)/$1\xcc$2/g;
236              
237 1         6 return $self->encode_128('c', "\xf1$string");
238             }
239              
240             1;