File Coverage

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