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; |