File Coverage

blib/lib/PDF/API2/Resource/XObject/Form/BarCode/code128.pm
Criterion Covered Total %
statement 83 95 87.3
branch 36 56 64.2
condition 6 11 54.5
subroutine 9 9 100.0
pod 1 6 16.6
total 135 177 76.2


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