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