line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
require 5.010; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
Barcode::Code128 - Generate CODE 128 bar codes |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 SYNOPSIS |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
use Barcode::Code128; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
$code = new Barcode::Code128; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=head1 REQUIRES |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
Perl 5.004, Carp, Exporter, GD (optional) |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 EXPORTS |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
By default, nothing. However there are a number of constants that |
20
|
|
|
|
|
|
|
represent special characters used in the CODE 128 symbology that you |
21
|
|
|
|
|
|
|
may wish to include. For example if you are using the EAN-128 or |
22
|
|
|
|
|
|
|
UCC-128 code, the string to encode begins with the FNC1 character. To |
23
|
|
|
|
|
|
|
encode the EAN-128 string "00 0 0012345 555555555 8", you would do the |
24
|
|
|
|
|
|
|
following: |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
use Barcode::Code128 'FNC1'; |
27
|
|
|
|
|
|
|
$code = new Barcode::Code128; |
28
|
|
|
|
|
|
|
$code->text(FNC1.'00000123455555555558'); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
To have this module export one or more of these characters, specify |
31
|
|
|
|
|
|
|
them on the C |
32
|
|
|
|
|
|
|
to include all of them. Examples: |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
use Barcode::Code128 qw(FNC1 FNC2 FNC3 FNC4 Shift); |
35
|
|
|
|
|
|
|
use Barcode::Code128 qw(:all); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
Here is the complete list of the exportable characters. They are |
38
|
|
|
|
|
|
|
assigned to high-order ASCII characters purely arbitrarily for the |
39
|
|
|
|
|
|
|
purposes of this module; the values used do not reflect any part of |
40
|
|
|
|
|
|
|
the CODE 128 standard. B: Using the C, C, |
41
|
|
|
|
|
|
|
C, C, C, C, and C codes may cause |
42
|
|
|
|
|
|
|
your barcodes to be invalid, and be rejected by scanners. They are |
43
|
|
|
|
|
|
|
inserted automatically as needed by this module. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
CodeA 0xf4 CodeB 0xf5 CodeC 0xf6 |
46
|
|
|
|
|
|
|
FNC1 0xf7 FNC2 0xf8 FNC3 0xf9 |
47
|
|
|
|
|
|
|
FNC4 0xfa Shift 0xfb StartA 0xfc |
48
|
|
|
|
|
|
|
StartB 0xfd StartC 0xfe Stop 0xff |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head1 DESCRIPTION |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
Barcode::Code128 generates bar codes using the CODE 128 symbology. It |
53
|
|
|
|
|
|
|
can generate images in PNG or GIF format using the GD package, or it |
54
|
|
|
|
|
|
|
can generate a text string representing the barcode that you can |
55
|
|
|
|
|
|
|
render using some other technology if desired. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
The intended use of this module is to create a web page with a bar |
58
|
|
|
|
|
|
|
code on it, which can then be printed out and faxed or mailed to |
59
|
|
|
|
|
|
|
someone who will scan the bar code. The application which spurred its |
60
|
|
|
|
|
|
|
creation was an expense report tool, where the employee submitting the |
61
|
|
|
|
|
|
|
report would print out the web page and staple the receipts to it, and |
62
|
|
|
|
|
|
|
the Accounts Payable clerk would scan the bar code to indicate that |
63
|
|
|
|
|
|
|
the receipts were received. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
The default settings for this module produce a large image that can |
66
|
|
|
|
|
|
|
safely be FAXed several times and still scanned easily. If this |
67
|
|
|
|
|
|
|
requirement is not important you can generate smaller image using |
68
|
|
|
|
|
|
|
optional parameters, described below. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
If you wish to generate images with this module you must also have the |
71
|
|
|
|
|
|
|
GD module (written by Lincoln Stein, and available from CPAN) |
72
|
|
|
|
|
|
|
installed. Using the libgd library, GD can generate files in PNG |
73
|
|
|
|
|
|
|
(Portable Network Graphics) or GIF (Graphic Interchange Format) |
74
|
|
|
|
|
|
|
formats. |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
Starting with version 1.20, and ending with 2.0.28 (released July |
77
|
|
|
|
|
|
|
21st, 2004), GD and the underlying libgd library could not generate |
78
|
|
|
|
|
|
|
GIF files due to patent issues, but any modern version of libgd (since |
79
|
|
|
|
|
|
|
2004) can do GIF as the patent has expired. Most browsers have no |
80
|
|
|
|
|
|
|
trouble with PNG files. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
In order to ensure you have a sufficiently modern installation of the |
83
|
|
|
|
|
|
|
GD module to do both GIF and PNG formats, we require version 2.18 of |
84
|
|
|
|
|
|
|
GD (which in turn requires libgd 2.0.28) or higher. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
If the GD module is not present, you can still use the module, but you |
87
|
|
|
|
|
|
|
will not be able to use its functions for generating images. You can |
88
|
|
|
|
|
|
|
use the barcode() method to get a string of "#" and " " (hash and |
89
|
|
|
|
|
|
|
space) characters, and use your own image-generating routine with that |
90
|
|
|
|
|
|
|
as input. |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
To use the the GD module, you will need to install it along with this |
93
|
|
|
|
|
|
|
module. You can obtain it from the CPAN (Comprehensive Perl Archive |
94
|
|
|
|
|
|
|
Network) repository of your choice under the directory |
95
|
|
|
|
|
|
|
C. Visit http://www.cpan.org/ for more information |
96
|
|
|
|
|
|
|
about CPAN. The GD home page is: |
97
|
|
|
|
|
|
|
http://stein.cshl.org/WWW/software/GD/GD.html |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=head1 METHODS |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=over 4 |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=cut |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
package Barcode::Code128; |
106
|
|
|
|
|
|
|
|
107
|
3
|
|
|
3
|
|
89906
|
use strict; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
131
|
|
108
|
|
|
|
|
|
|
|
109
|
3
|
|
|
|
|
460
|
use vars qw($GD_VERSION $VERSION %CODE_CHARS %CODE @ENCODING @EXPORT_OK |
110
|
3
|
|
|
3
|
|
16
|
%EXPORT_TAGS %FUNC_CHARS @ISA %OPTIONS); |
|
3
|
|
|
|
|
4
|
|
111
|
|
|
|
|
|
|
|
112
|
3
|
|
|
3
|
|
25
|
use constant CodeA => chr(0xf4); |
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
261
|
|
113
|
3
|
|
|
3
|
|
112
|
use constant CodeB => chr(0xf5); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
146
|
|
114
|
3
|
|
|
3
|
|
13
|
use constant CodeC => chr(0xf6); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
137
|
|
115
|
3
|
|
|
3
|
|
14
|
use constant FNC1 => chr(0xf7); |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
132
|
|
116
|
3
|
|
|
3
|
|
15
|
use constant FNC2 => chr(0xf8); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
133
|
|
117
|
3
|
|
|
3
|
|
14
|
use constant FNC3 => chr(0xf9); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
141
|
|
118
|
3
|
|
|
3
|
|
14
|
use constant FNC4 => chr(0xfa); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
131
|
|
119
|
3
|
|
|
3
|
|
27
|
use constant Shift => chr(0xfb); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
242
|
|
120
|
3
|
|
|
3
|
|
13
|
use constant StartA => chr(0xfc); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
121
|
|
121
|
3
|
|
|
3
|
|
15
|
use constant StartB => chr(0xfd); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
138
|
|
122
|
3
|
|
|
3
|
|
20
|
use constant StartC => chr(0xfe); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
130
|
|
123
|
3
|
|
|
3
|
|
25
|
use constant Stop => chr(0xff); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
116
|
|
124
|
|
|
|
|
|
|
|
125
|
3
|
|
|
3
|
|
15
|
use Carp; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
376
|
|
126
|
3
|
|
|
3
|
|
15
|
use Exporter; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
310
|
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# Try to load GD. If it succeeds, set $GD_VERSION accordingly. |
129
|
|
|
|
|
|
|
BEGIN { |
130
|
3
|
|
|
3
|
|
6
|
$GD_VERSION = undef; |
131
|
3
|
|
|
3
|
|
197
|
eval "use GD 2.18"; |
|
3
|
|
|
|
|
1571
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
132
|
3
|
50
|
|
|
|
3845
|
$GD_VERSION = $GD::VERSION |
133
|
|
|
|
|
|
|
unless $@; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
%OPTIONS = |
137
|
|
|
|
|
|
|
( |
138
|
|
|
|
|
|
|
width => undef, |
139
|
|
|
|
|
|
|
height => undef, |
140
|
|
|
|
|
|
|
border => 2, |
141
|
|
|
|
|
|
|
scale => 2, |
142
|
|
|
|
|
|
|
font => 'large', |
143
|
|
|
|
|
|
|
show_text => 1, |
144
|
|
|
|
|
|
|
font_margin => 2, |
145
|
|
|
|
|
|
|
top_margin => 0, |
146
|
|
|
|
|
|
|
bottom_margin => 0, |
147
|
|
|
|
|
|
|
left_margin => 0, |
148
|
|
|
|
|
|
|
right_margin => 0, |
149
|
|
|
|
|
|
|
padding => 20, |
150
|
|
|
|
|
|
|
font_align => 'left', |
151
|
|
|
|
|
|
|
transparent_text => 1, |
152
|
|
|
|
|
|
|
); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
@EXPORT_OK = qw(CodeA CodeB CodeC FNC1 FNC2 FNC3 FNC4 Shift StartA |
155
|
|
|
|
|
|
|
StartB StartC Stop); |
156
|
|
|
|
|
|
|
%EXPORT_TAGS = (all => \@EXPORT_OK); |
157
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# Version information |
160
|
|
|
|
|
|
|
$VERSION = '2.21'; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
@ENCODING = qw(11011001100 11001101100 11001100110 10010011000 |
163
|
|
|
|
|
|
|
10010001100 10001001100 10011001000 10011000100 |
164
|
|
|
|
|
|
|
10001100100 11001001000 11001000100 11000100100 |
165
|
|
|
|
|
|
|
10110011100 10011011100 10011001110 10111001100 |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
10011101100 10011100110 11001110010 11001011100 |
168
|
|
|
|
|
|
|
11001001110 11011100100 11001110100 11101101110 |
169
|
|
|
|
|
|
|
11101001100 11100101100 11100100110 11101100100 |
170
|
|
|
|
|
|
|
11100110100 11100110010 11011011000 11011000110 |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
11000110110 10100011000 10001011000 10001000110 |
173
|
|
|
|
|
|
|
10110001000 10001101000 10001100010 11010001000 |
174
|
|
|
|
|
|
|
11000101000 11000100010 10110111000 10110001110 |
175
|
|
|
|
|
|
|
10001101110 10111011000 10111000110 10001110110 |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
11101110110 11010001110 11000101110 11011101000 |
178
|
|
|
|
|
|
|
11011100010 11011101110 11101011000 11101000110 |
179
|
|
|
|
|
|
|
11100010110 11101101000 11101100010 11100011010 |
180
|
|
|
|
|
|
|
11101111010 11001000010 11110001010 10100110000 |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
10100001100 10010110000 10010000110 10000101100 |
183
|
|
|
|
|
|
|
10000100110 10110010000 10110000100 10011010000 |
184
|
|
|
|
|
|
|
10011000010 10000110100 10000110010 11000010010 |
185
|
|
|
|
|
|
|
11001010000 11110111010 11000010100 10001111010 |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
10100111100 10010111100 10010011110 10111100100 |
188
|
|
|
|
|
|
|
10011110100 10011110010 11110100100 11110010100 |
189
|
|
|
|
|
|
|
11110010010 11011011110 11011110110 11110110110 |
190
|
|
|
|
|
|
|
10101111000 10100011110 10001011110 10111101000 |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
10111100010 11110101000 11110100010 10111011110 |
193
|
|
|
|
|
|
|
10111101110 11101011110 11110101110 11010000100 |
194
|
|
|
|
|
|
|
11010010000 11010011100 1100011101011); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
%CODE_CHARS = ( A => [ (map { chr($_) } 040..0137, 000..037), |
197
|
|
|
|
|
|
|
FNC3, FNC2, Shift, CodeC, CodeB, FNC4, FNC1, |
198
|
|
|
|
|
|
|
StartA, StartB, StartC, Stop ], |
199
|
|
|
|
|
|
|
B => [ (map { chr($_) } 040..0177), |
200
|
|
|
|
|
|
|
FNC3, FNC2, Shift, CodeC, FNC4, CodeA, FNC1, |
201
|
|
|
|
|
|
|
StartA, StartB, StartC, Stop ], |
202
|
|
|
|
|
|
|
C => [ ("00".."99"), |
203
|
|
|
|
|
|
|
CodeB, CodeA, FNC1, StartA, StartB, StartC, Stop ]); |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# Provide string equivalents to the constants |
206
|
|
|
|
|
|
|
%FUNC_CHARS = ('CodeA' => CodeA, |
207
|
|
|
|
|
|
|
'CodeB' => CodeB, |
208
|
|
|
|
|
|
|
'CodeC' => CodeC, |
209
|
|
|
|
|
|
|
'FNC1' => FNC1, |
210
|
|
|
|
|
|
|
'FNC2' => FNC2, |
211
|
|
|
|
|
|
|
'FNC3' => FNC3, |
212
|
|
|
|
|
|
|
'FNC4' => FNC4, |
213
|
|
|
|
|
|
|
'Shift' => Shift, |
214
|
|
|
|
|
|
|
'StartA' => StartA, |
215
|
|
|
|
|
|
|
'StartB' => StartB, |
216
|
|
|
|
|
|
|
'StartC' => StartC, |
217
|
|
|
|
|
|
|
'Stop' => Stop ); |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# Convert the above into a 2-dimensional hash |
220
|
|
|
|
|
|
|
%CODE = ( A => { map { $CODE_CHARS{A}[$_] => $_ } 0..106 }, |
221
|
|
|
|
|
|
|
B => { map { $CODE_CHARS{B}[$_] => $_ } 0..106 }, |
222
|
|
|
|
|
|
|
C => { map { $CODE_CHARS{C}[$_] => $_ } 0..106 } ); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=item new |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
Usage: |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
$object = new Barcode::Code128 |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
Creates a new barcode object. |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=cut |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub new |
237
|
|
|
|
|
|
|
{ |
238
|
1
|
|
|
1
|
1
|
11
|
my $type = shift; |
239
|
1
|
|
|
|
|
4
|
my $self = bless { @_ }, $type; |
240
|
1
|
|
50
|
|
|
13
|
$self->{encoded} ||= []; |
241
|
1
|
|
50
|
|
|
10
|
$self->{text} ||= ''; |
242
|
1
|
|
|
|
|
8
|
$self; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=item option |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
Sets or retreives various options. If called with only one parameter, |
248
|
|
|
|
|
|
|
retrieves the value for that parameter. If called with more than one |
249
|
|
|
|
|
|
|
parameter, treats the parameters as name/value pairs and sets those |
250
|
|
|
|
|
|
|
option values accordingly. If called with no parameters, returns a |
251
|
|
|
|
|
|
|
hash consisting of the values of all the options (hash ref in scalar |
252
|
|
|
|
|
|
|
context). When an option has not been set, its default value is |
253
|
|
|
|
|
|
|
returned. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
You can also set or retrieve any of these options by using it as a |
256
|
|
|
|
|
|
|
method name. For example, to set the value of the padding option, you |
257
|
|
|
|
|
|
|
can use either of these: |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
$barcode->padding(10); |
260
|
|
|
|
|
|
|
$barcode->option("padding", 10); |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
The valid options, and the default value and meaning of each, are: |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
width undef Width of the image (*) |
265
|
|
|
|
|
|
|
height undef Height of the image (*) |
266
|
|
|
|
|
|
|
border 2 Size of the black border around the barcode |
267
|
|
|
|
|
|
|
scale 2 How many pixels for the smallest barcode stripe |
268
|
|
|
|
|
|
|
font "large" Font (**) for the text at the bottom |
269
|
|
|
|
|
|
|
show_text 1 True/False: display the text at the bottom? |
270
|
|
|
|
|
|
|
font_margin 2 Pixels above, below, and to left of the text |
271
|
|
|
|
|
|
|
font_align "left" Align the text ("left", "right", or "center") |
272
|
|
|
|
|
|
|
transparent_text 1/0(***) True/False: use transparent background for text? |
273
|
|
|
|
|
|
|
top_margin 0 No. of pixels above the barcode |
274
|
|
|
|
|
|
|
bottom_margin 0 No. of pixels below the barcode (& text) |
275
|
|
|
|
|
|
|
left_margin 0 No. of pixels to the left of the barcode |
276
|
|
|
|
|
|
|
right_margin 0 No. of pixels to the right of the barcode |
277
|
|
|
|
|
|
|
padding 20 Size of whitespace before & after barcode |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
* Width and height are the default values for the $x and $y arguments |
280
|
|
|
|
|
|
|
to the png, gif, or gd_image method (q.v.) |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
** Font may be one of the following: "giant", "large", "medium", |
283
|
|
|
|
|
|
|
"small", or "tiny". Or, it may be any valid GD font name, such as |
284
|
|
|
|
|
|
|
"gdMediumFont". |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
*** The "transparent_text" option is "1" (true) by default for GIF |
287
|
|
|
|
|
|
|
output, but "0" (false) for PNG. This is because PNG transparency is |
288
|
|
|
|
|
|
|
not supported well by many viewing software The background color is |
289
|
|
|
|
|
|
|
grey (#CCCCCC) when not transparent. |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=cut |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
sub AUTOLOAD |
294
|
|
|
|
|
|
|
{ |
295
|
0
|
|
|
0
|
|
0
|
my($self, @args) = @_; |
296
|
3
|
|
|
3
|
|
20
|
use vars qw($AUTOLOAD); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
527
|
|
297
|
0
|
|
|
|
|
0
|
(my $opt = lc $AUTOLOAD) =~ s/^.*:://; |
298
|
0
|
0
|
|
|
|
0
|
return if $opt eq 'destroy'; |
299
|
0
|
|
|
|
|
0
|
$self->option($opt, @args); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
sub option |
303
|
|
|
|
|
|
|
{ |
304
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
305
|
0
|
|
|
|
|
0
|
my $class = ref $self; # do this so others can inherit from us |
306
|
0
|
|
|
|
|
0
|
my $defaults; |
307
|
3
|
|
|
3
|
|
16
|
{ no strict 'refs'; $defaults = \%{$class.'::OPTIONS'}; } |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
8775
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
308
|
|
|
|
|
|
|
|
309
|
0
|
0
|
|
|
|
0
|
if (!@_) { |
|
|
0
|
|
|
|
|
|
310
|
0
|
|
|
|
|
0
|
my %all; |
311
|
0
|
|
|
|
|
0
|
while (my($opt, $def_value) = each %$defaults) { |
312
|
0
|
0
|
|
|
|
0
|
if (exists $self->{OPTIONS}{$opt}) { |
313
|
0
|
|
|
|
|
0
|
$all{$opt} = $self->{OPTIONS}{$opt}; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
else { |
316
|
0
|
|
|
|
|
0
|
$all{$opt} = $def_value; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
} |
319
|
0
|
0
|
|
|
|
0
|
wantarray ? %all : \%all; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
elsif (@_ == 1) { # return requested value |
322
|
0
|
|
|
|
|
0
|
my $opt = shift; |
323
|
0
|
0
|
|
|
|
0
|
croak "Unrecognized option ($opt) for $class" |
324
|
|
|
|
|
|
|
unless exists $defaults->{$opt}; |
325
|
0
|
0
|
|
|
|
0
|
if (exists $self->{OPTIONS}{$opt}) { |
326
|
0
|
|
|
|
|
0
|
return $self->{OPTIONS}{$opt}; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
else { |
329
|
0
|
|
|
|
|
0
|
return $defaults->{$opt}; |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
else { |
333
|
0
|
|
|
|
|
0
|
my $count = 0; |
334
|
0
|
|
|
|
|
0
|
while(my($opt, $value) = splice(@_, 0, 2)) { |
335
|
0
|
0
|
|
|
|
0
|
croak "Unrecognized option ($opt) for $class" |
336
|
|
|
|
|
|
|
unless exists $defaults->{$opt}; |
337
|
0
|
|
|
|
|
0
|
$self->{OPTIONS}{$opt} = $value; |
338
|
0
|
|
|
|
|
0
|
$count++; |
339
|
|
|
|
|
|
|
} |
340
|
0
|
|
|
|
|
0
|
return $count; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=item gif |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
=item png |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=item gd_image |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Usage: |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
$object->png($text) |
355
|
|
|
|
|
|
|
$object->png($text, $x, $y) |
356
|
|
|
|
|
|
|
$object->png($text, { options... }) |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
$object->gif($text) |
359
|
|
|
|
|
|
|
$object->gif($text, $x, $y) |
360
|
|
|
|
|
|
|
$object->gif($text, { options... }) |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
$object->gd_image($text) |
363
|
|
|
|
|
|
|
$object->gd_image($text, $x, $y) |
364
|
|
|
|
|
|
|
$object->gd_image($text, { options... }) |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
These methods generate an image using the GD module. The gd_image() |
367
|
|
|
|
|
|
|
method returns a GD object, which is useful if you want to do |
368
|
|
|
|
|
|
|
additional processing to it using the GD object methods. The other |
369
|
|
|
|
|
|
|
two create actual images. NOTE: GIF files require an old version of |
370
|
|
|
|
|
|
|
GD, and so you probably are not able to create them - see below. |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
The gif() and png() methods are wrappers around gd_image() that create |
373
|
|
|
|
|
|
|
the GD object and then run the corresponding GD method to create |
374
|
|
|
|
|
|
|
output that can be displayed or saved to a file. Note that only one |
375
|
|
|
|
|
|
|
of these two methods will work, depending on which version of GD you |
376
|
|
|
|
|
|
|
have - see below. The return value from gif() or png() is a binary |
377
|
|
|
|
|
|
|
file, so if you are working on an operating system (e.g. Microsoft |
378
|
|
|
|
|
|
|
Windows) that makes a distinction between text and binary files be |
379
|
|
|
|
|
|
|
sure to call binmode(FILEHANDLE) before writing the image to it, or |
380
|
|
|
|
|
|
|
the file may get corrupted. Example: |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
open(PNG, ">code128.png") or die "Can't write code128.png: $!\n"; |
383
|
|
|
|
|
|
|
binmode(PNG); |
384
|
|
|
|
|
|
|
print PNG $object->png("CODE 128"); |
385
|
|
|
|
|
|
|
close(PNG); |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
If you have GD version 1.20 or newer, the PNG file format is the only |
388
|
|
|
|
|
|
|
allowed option. Conversely if you have GD version prior to 1.20, then |
389
|
|
|
|
|
|
|
the GIF format is the only option. Check the $object->image_format() |
390
|
|
|
|
|
|
|
method to find out which you have (q.v.). |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
Note: All of the arguments to this function are optional. If you have |
393
|
|
|
|
|
|
|
previously specified C<$text> to the C, C, or |
394
|
|
|
|
|
|
|
C methods, you do not need to specify it again. The C<$x> and |
395
|
|
|
|
|
|
|
C<$y> variables specify the size of the barcode within the image in |
396
|
|
|
|
|
|
|
pixels. If size(s) are not specified, they will be set to the minimum |
397
|
|
|
|
|
|
|
size, which is the length of the barcode plus 40 pixels horizontally, |
398
|
|
|
|
|
|
|
and 15% of the length of the barcode vertically. See also the |
399
|
|
|
|
|
|
|
$object->width() and $object->height() methods for another way of |
400
|
|
|
|
|
|
|
specifying this. |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
If instead of specifying $x and $y, you pass a reference to a hash of |
403
|
|
|
|
|
|
|
name/value pairs, these will be used as the options, overriding |
404
|
|
|
|
|
|
|
anything set using the $object->option() (or width/height) method |
405
|
|
|
|
|
|
|
(q.v.). However, this will not set the options so any future barcodes |
406
|
|
|
|
|
|
|
using the same object will revert to the option list of the object. |
407
|
|
|
|
|
|
|
If you want to set the options permanently use the option, width, |
408
|
|
|
|
|
|
|
and/or height methods instead. |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
=cut |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
sub gd_image |
413
|
|
|
|
|
|
|
{ |
414
|
0
|
|
|
0
|
1
|
0
|
my($self, $text, $x, $y) = @_; |
415
|
0
|
|
|
|
|
0
|
my %opts; |
416
|
0
|
0
|
0
|
|
|
0
|
if (ref($x) && !defined($y)) { |
417
|
0
|
|
|
|
|
0
|
%opts = ($self->option, %$x); |
418
|
0
|
|
|
|
|
0
|
$x = $opts{width}; |
419
|
0
|
|
|
|
|
0
|
$y = $opts{height}; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
else { |
422
|
0
|
|
|
|
|
0
|
%opts = $self->option; |
423
|
0
|
0
|
|
|
|
0
|
$opts{width} = $x if $x; |
424
|
0
|
0
|
|
|
|
0
|
$opts{height} = $y if $y; |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
0
|
0
|
|
|
|
0
|
croak "The gd_image() method of Barcode::Code128 requires the GD module" |
428
|
|
|
|
|
|
|
unless $GD_VERSION; |
429
|
|
|
|
|
|
|
|
430
|
0
|
|
|
|
|
0
|
my $scale = $opts{scale}; |
431
|
0
|
0
|
0
|
|
|
0
|
croak "Scale ($scale) must be a positive integer" |
432
|
|
|
|
|
|
|
unless $scale > 0 && int($scale) == $scale; |
433
|
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
0
|
my $border = $opts{border}; |
435
|
0
|
0
|
0
|
|
|
0
|
croak "Border ($border) must be a positive integer or zero" |
436
|
|
|
|
|
|
|
unless $border >= 0 && int($border) == $border; |
437
|
0
|
|
|
|
|
0
|
$border *= $scale; |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
0
|
|
|
0
|
$x ||= $opts{width}; |
440
|
0
|
|
0
|
|
|
0
|
$y ||= $opts{height}; |
441
|
|
|
|
|
|
|
|
442
|
0
|
|
|
|
|
0
|
my($font, $font_margin, $font_height, $font_width) = (undef, 0, 0, 0); |
443
|
0
|
0
|
|
|
|
0
|
if ($opts{show_text}) { |
444
|
0
|
|
|
|
|
0
|
$font = $opts{font}; |
445
|
0
|
|
|
|
|
0
|
my %fontTable = (giant => 'gdGiantFont', |
446
|
|
|
|
|
|
|
large => 'gdLargeFont', |
447
|
|
|
|
|
|
|
medium => 'gdMediumBoldFont', |
448
|
|
|
|
|
|
|
small => 'gdSmallFont', |
449
|
|
|
|
|
|
|
tiny => 'gdTinyFont'); |
450
|
0
|
0
|
|
|
|
0
|
$font = $fontTable{$font} if exists $fontTable{$font}; |
451
|
0
|
0
|
|
|
|
0
|
croak "Invalid font $font" unless GD->can($font); |
452
|
0
|
0
|
|
|
|
0
|
$font = eval "GD->$font"; die $@ if $@; |
|
0
|
|
|
|
|
0
|
|
453
|
0
|
|
|
|
|
0
|
$font_margin = $opts{font_margin}; |
454
|
0
|
|
|
|
|
0
|
$font_height = $font->height + $font_margin * 2; |
455
|
0
|
|
|
|
|
0
|
$font_width = $font->width; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
0
|
|
|
|
|
0
|
my($lm, $rm, $tm, $bm) = map { $opts{$_."_margin"} } |
|
0
|
|
|
|
|
0
|
|
459
|
|
|
|
|
|
|
qw(left right top bottom); |
460
|
|
|
|
|
|
|
|
461
|
0
|
|
|
|
|
0
|
my @barcode = split //, $self->barcode($text); |
462
|
0
|
|
|
|
|
0
|
my $n = scalar(@barcode); # width of string |
463
|
0
|
|
|
|
|
0
|
my $min_x = ($n + $opts{padding}) * $scale + 2 * $border; |
464
|
0
|
|
|
|
|
0
|
my $min_y = $n * $scale * 0.15 + 2 * $border; # 15% of width in pixels |
465
|
0
|
|
0
|
|
|
0
|
$x ||= $min_x; |
466
|
0
|
|
0
|
|
|
0
|
$y ||= $min_y; |
467
|
0
|
0
|
|
|
|
0
|
croak "Image width $x is too small for bar code" if $x < $min_x; |
468
|
0
|
0
|
|
|
|
0
|
croak "Image height $y is too small for bar code" if $y < $min_y; |
469
|
0
|
0
|
|
|
|
0
|
my $image = new GD::Image($x + $lm + $rm, $y + $tm + $bm + $font_height) |
470
|
|
|
|
|
|
|
or croak "Unable to create $x x $y image"; |
471
|
0
|
|
|
|
|
0
|
my $grey = $image->colorAllocate(0xCC, 0xCC, 0xCC); |
472
|
0
|
|
|
|
|
0
|
my $white = $image->colorAllocate(0xFF, 0xFF, 0xFF); |
473
|
0
|
|
|
|
|
0
|
my $black = $image->colorAllocate(0x00, 0x00, 0x00); |
474
|
0
|
|
|
|
|
0
|
my $red = $image->colorAllocate(0xFF, 0x00, 0x00); |
475
|
0
|
0
|
|
|
|
0
|
$image->transparent($grey) |
476
|
|
|
|
|
|
|
if $opts{transparent_text}; |
477
|
0
|
0
|
|
|
|
0
|
if ($border) { |
478
|
0
|
|
|
|
|
0
|
$image->rectangle($lm, $tm, $lm+$x-1, $tm+$y-1, $black); |
479
|
0
|
|
|
|
|
0
|
$image->rectangle($lm+$border, $tm+$border, |
480
|
|
|
|
|
|
|
$lm+$x-$border-1, $tm+$y-$border-1, $black); |
481
|
0
|
|
|
|
|
0
|
$image->fill($lm+1, $tm+1, $black); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
else { |
484
|
0
|
|
|
|
|
0
|
$image->rectangle($lm, $tm, $lm+$x-1, $tm+$y-1, $white); |
485
|
|
|
|
|
|
|
} |
486
|
0
|
|
|
|
|
0
|
$image->fill($lm+$border+1, $tm+$border+1, $white); |
487
|
0
|
|
|
|
|
0
|
for (my $i = 0; $i < $n; ++$i) |
488
|
|
|
|
|
|
|
{ |
489
|
0
|
0
|
|
|
|
0
|
next unless $barcode[$i] eq '#'; |
490
|
0
|
|
|
|
|
0
|
my $pos = $x/2 - $n * ($scale/2) + $i * $scale; |
491
|
0
|
|
|
|
|
0
|
$image->rectangle($lm+$pos, $tm+$border, |
492
|
|
|
|
|
|
|
$lm+$pos+$scale-1, $tm+$y-$border-1, $black); |
493
|
0
|
0
|
|
|
|
0
|
$image->fill($lm+$pos+1, $tm+$border+1, $black) |
494
|
|
|
|
|
|
|
if $scale > 2; |
495
|
|
|
|
|
|
|
} |
496
|
0
|
0
|
|
|
|
0
|
if (defined $font) { |
497
|
0
|
|
|
|
|
0
|
my ($font_x,$font_y); |
498
|
0
|
0
|
|
|
|
0
|
if ($opts{font_align} eq "center") { |
|
|
0
|
|
|
|
|
|
499
|
0
|
|
|
|
|
0
|
$font_x = int(($x+$lm+$rm-($font_width*length $self->{text}))/2); |
500
|
|
|
|
|
|
|
} elsif ($opts{font_align} eq "right") { |
501
|
0
|
|
|
|
|
0
|
$font_x = $x +$lm-($font_width * length $self->{text}); |
502
|
|
|
|
|
|
|
} else { # Assume left |
503
|
0
|
|
|
|
|
0
|
$font_x = $lm+$font_margin; |
504
|
|
|
|
|
|
|
} |
505
|
0
|
|
|
|
|
0
|
$font_y = $tm+$y+$font_margin; |
506
|
0
|
|
|
|
|
0
|
$image->string($font, $font_x, $font_y, $self->{text}, $black) |
507
|
|
|
|
|
|
|
} |
508
|
0
|
|
|
|
|
0
|
return $image; |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
sub gif |
512
|
|
|
|
|
|
|
{ |
513
|
0
|
|
|
0
|
1
|
0
|
my($self, $text, $x, $y, $scale) = @_; |
514
|
0
|
0
|
|
|
|
0
|
croak "The gif() method of Barcode::Code128 requires the GD module" |
515
|
|
|
|
|
|
|
unless $GD_VERSION; |
516
|
0
|
|
|
|
|
0
|
my $image = $self->gd_image($text, $x, $y, $scale); |
517
|
0
|
|
|
|
|
0
|
return $image->gif(); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
sub png |
521
|
|
|
|
|
|
|
{ |
522
|
0
|
|
|
0
|
1
|
0
|
my($self, $text, $x, $y, $scale) = @_; |
523
|
0
|
0
|
|
|
|
0
|
croak "The png() method of Barcode::Code128 requires the GD module" |
524
|
|
|
|
|
|
|
unless $GD_VERSION; |
525
|
0
|
|
|
|
|
0
|
my $image = $self->gd_image($text, $x, $y, $scale); |
526
|
0
|
|
|
|
|
0
|
return $image->png(); |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=item barcode |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
Usage: |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
$object->barcode($text) |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
Computes the bar code for the specified text. The result will be a |
538
|
|
|
|
|
|
|
string of '#' and space characters representing the dark and light |
539
|
|
|
|
|
|
|
bands of the bar code. You can use this if you have an alternate |
540
|
|
|
|
|
|
|
printing system besides using GD to create the images. |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
Note: The C<$text> parameter is optional. If you have previously |
543
|
|
|
|
|
|
|
specified C<$text> to the C or C methods, you do not |
544
|
|
|
|
|
|
|
need to specify it again. |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
=cut |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
sub barcode |
549
|
|
|
|
|
|
|
{ |
550
|
1
|
|
|
1
|
1
|
3
|
my($self, $text) = @_; |
551
|
1
|
50
|
|
|
|
10
|
$self->encode($text) if defined $text; |
552
|
1
|
|
|
|
|
2
|
my @encoded = @{ $self->{encoded} }; |
|
1
|
|
|
|
|
3
|
|
553
|
1
|
50
|
|
|
|
4
|
croak "No encoded text found" unless @encoded; |
554
|
1
|
|
|
|
|
3
|
join '', map { $_ = $ENCODING[$_]; tr/01/ \#/; $_ } @encoded; |
|
11
|
|
|
|
|
18
|
|
|
11
|
|
|
|
|
14
|
|
|
11
|
|
|
|
|
21
|
|
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
###--------------------------------------------------------------------------- |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
=back |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
=head2 Housekeeping Functions |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
The rest of the methods defined here are only for internal use, or if |
564
|
|
|
|
|
|
|
you really know what you are doing. Some of them may be useful to |
565
|
|
|
|
|
|
|
authors of classes that inherit from this one, or may be overridden by |
566
|
|
|
|
|
|
|
subclasses. If you just want to use this module to generate bar |
567
|
|
|
|
|
|
|
codes, you can stop reading here. |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
=over 4 |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=cut |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
=item encode |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
Usage: |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
$object->encode |
580
|
|
|
|
|
|
|
$object->encode($text) |
581
|
|
|
|
|
|
|
$object->encode($text, $preferred_code) |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
Do the encoding. If C<$text> is supplied, will automatically call the |
584
|
|
|
|
|
|
|
text() method to set that as the text value first. If |
585
|
|
|
|
|
|
|
C<$preferred_code> is supplied, will try that code first. Otherwise, |
586
|
|
|
|
|
|
|
the codes will be tried in the following manner: |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
1. If it is possible to use Code C for any of the text, use that for |
589
|
|
|
|
|
|
|
as much of it as possible. |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
2. Check how many characters would be converted using codes A or B, |
592
|
|
|
|
|
|
|
and use that code to convert them. If the amount is equal, code A is |
593
|
|
|
|
|
|
|
used. |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
3. Repeat steps 1 and 2 until the text string has been completely encoded. |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
=cut |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
sub encode |
600
|
|
|
|
|
|
|
{ |
601
|
1
|
|
|
1
|
1
|
3
|
my($self, $text, $preferred_code) = @_; |
602
|
1
|
50
|
|
|
|
7
|
$self->text($text) if defined $text; |
603
|
1
|
50
|
|
|
|
3
|
croak "No text defined" unless defined($text = $self->text); |
604
|
1
|
50
|
33
|
|
|
7
|
croak "Invalid preferred code ``$preferred_code''" |
605
|
|
|
|
|
|
|
if defined $preferred_code && !exists $CODE{$preferred_code}; |
606
|
|
|
|
|
|
|
# Reset internal variables |
607
|
1
|
|
|
|
|
3
|
my $encoded = $self->{encoded} = []; |
608
|
1
|
|
|
|
|
11
|
$self->{code} = undef; |
609
|
1
|
|
|
|
|
3
|
my $sanity = 0; |
610
|
1
|
|
|
|
|
5
|
while(length $text) |
611
|
|
|
|
|
|
|
{ |
612
|
2
|
50
|
|
|
|
6
|
confess "Sanity Check Overflow" if $sanity++ > 1000; |
613
|
2
|
|
|
|
|
2
|
my @chars; |
614
|
2
|
50
|
33
|
|
|
12
|
if ($preferred_code && (@chars = _encodable($preferred_code, $text))) |
|
|
100
|
|
|
|
|
|
615
|
|
|
|
|
|
|
{ |
616
|
0
|
|
|
|
|
0
|
$self->start($preferred_code); |
617
|
0
|
|
|
|
|
0
|
push @$encoded, map { $CODE{$preferred_code}{$_} } @chars; |
|
0
|
|
|
|
|
0
|
|
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
elsif (@chars = _encodable('C', $text)) |
620
|
|
|
|
|
|
|
{ |
621
|
1
|
|
|
|
|
4
|
$self->start('C'); |
622
|
1
|
|
|
|
|
2
|
push @$encoded, map { $CODE{C}{$_} } @chars; |
|
2
|
|
|
|
|
7
|
|
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
else |
625
|
|
|
|
|
|
|
{ |
626
|
1
|
|
|
|
|
2
|
my %x = map { $_ => [ _encodable($_, $text) ] } qw(A B); |
|
2
|
|
|
|
|
6
|
|
627
|
1
|
50
|
|
|
|
3
|
my $code = (@{$x{A}} >= @{$x{B}} ? 'A' : 'B'); # prefer A if equal |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
628
|
1
|
|
|
|
|
3
|
$self->start($code); |
629
|
1
|
|
|
|
|
1
|
@chars = @{ $x{$code} }; |
|
1
|
|
|
|
|
3
|
|
630
|
1
|
|
|
|
|
3
|
push @$encoded, map { $CODE{$code}{$_} } @chars; |
|
5
|
|
|
|
|
14
|
|
631
|
|
|
|
|
|
|
} |
632
|
2
|
50
|
|
|
|
6
|
croak "Unable to find encoding for ``$text''" unless @chars; |
633
|
2
|
|
|
|
|
11
|
substr($text, 0, length join '', @chars) = ''; |
634
|
|
|
|
|
|
|
} |
635
|
1
|
|
|
|
|
4
|
$self->stop; |
636
|
1
|
50
|
|
|
|
3
|
wantarray ? @$encoded : $encoded; |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
=item text |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
Usage: |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
$object->text($text) |
646
|
|
|
|
|
|
|
$text = $object->text |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
Set or retrieve the text for this barcode. This will be called |
649
|
|
|
|
|
|
|
automatically by encode() or barcode() so typically this will not be |
650
|
|
|
|
|
|
|
used directly by the user. |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
=cut |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
sub text |
655
|
|
|
|
|
|
|
{ |
656
|
2
|
|
|
2
|
1
|
4
|
my($self, $text) = @_; |
657
|
2
|
100
|
|
|
|
6
|
$self->{text} = $text if defined $text; |
658
|
2
|
|
|
|
|
7
|
$self->{text}; |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
=item start |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
Usage: |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
$object->start($code) |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
If the code (see code()) is already defined, then adds the CodeA, |
670
|
|
|
|
|
|
|
CodeB, or CodeC character as appropriate to the encoded message inside |
671
|
|
|
|
|
|
|
the object. Typically for internal use only. |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
=cut |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
sub start |
676
|
|
|
|
|
|
|
{ |
677
|
2
|
|
|
2
|
1
|
3
|
my($self, $new_code) = @_; |
678
|
2
|
|
|
|
|
12
|
my $old_code = $self->code; |
679
|
2
|
100
|
|
|
|
5
|
if (defined $old_code) |
680
|
|
|
|
|
|
|
{ |
681
|
1
|
50
|
|
|
|
6
|
my $func = $FUNC_CHARS{"Code$new_code"} or |
682
|
|
|
|
|
|
|
confess "Unable to switch from ``$old_code'' to ``$new_code''"; |
683
|
1
|
|
|
|
|
2
|
push @{ $self->{encoded} }, $CODE{$old_code}{$func}; |
|
1
|
|
|
|
|
5
|
|
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
else |
686
|
|
|
|
|
|
|
{ |
687
|
1
|
50
|
|
|
|
6
|
my $func = $FUNC_CHARS{"Start$new_code"} or |
688
|
|
|
|
|
|
|
confess "Unable to start with ``$new_code''"; |
689
|
1
|
|
|
|
|
4
|
@{ $self->{encoded} } = $CODE{$new_code}{$func}; |
|
1
|
|
|
|
|
3
|
|
690
|
|
|
|
|
|
|
} |
691
|
2
|
|
|
|
|
6
|
$self->code($new_code); |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
=item stop |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
Usage: |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
$object->stop() |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
Computes the check character and appends it along with the Stop |
703
|
|
|
|
|
|
|
character, to the encoded string. Typically for internal use only. |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
=cut |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
sub stop |
708
|
|
|
|
|
|
|
{ |
709
|
1
|
|
|
1
|
1
|
1
|
my($self) = @_; |
710
|
1
|
|
|
|
|
3
|
my $sum = $self->{encoded}[0]; |
711
|
1
|
|
|
|
|
2
|
for (my $i = 1; $i < @{ $self->{encoded} }; ++$i) |
|
9
|
|
|
|
|
22
|
|
712
|
|
|
|
|
|
|
{ |
713
|
8
|
|
|
|
|
13
|
$sum += $i * $self->{encoded}[$i]; |
714
|
|
|
|
|
|
|
} |
715
|
1
|
|
|
|
|
2
|
my $stop = Stop; |
716
|
1
|
|
|
|
|
2
|
push @{ $self->{encoded} }, ($sum % 103), $CODE{C}{$stop}; |
|
1
|
|
|
|
|
6
|
|
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
=item code |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
Usage: |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
$object->code($code) |
726
|
|
|
|
|
|
|
$code = $object->code |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
Set or retrieve the code for this barcode. C<$code> may be 'A', 'B', |
729
|
|
|
|
|
|
|
or 'C'. Typically for internal use only. Not particularly meaningful |
730
|
|
|
|
|
|
|
unless called during the middle of encoding. |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
=cut |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub code |
735
|
|
|
|
|
|
|
{ |
736
|
4
|
|
|
4
|
1
|
6
|
my($self, $new_code) = @_; |
737
|
4
|
100
|
|
|
|
10
|
if (defined $new_code) |
738
|
|
|
|
|
|
|
{ |
739
|
2
|
|
|
|
|
4
|
$new_code = uc $new_code; |
740
|
2
|
50
|
66
|
|
|
18
|
croak "Unknown code ``$new_code'' (should be A, B, or C)" |
|
|
|
66
|
|
|
|
|
741
|
|
|
|
|
|
|
unless $new_code eq 'A' || $new_code eq 'B' || $new_code eq 'C'; |
742
|
2
|
|
|
|
|
5
|
$self->{code} = $new_code; |
743
|
|
|
|
|
|
|
} |
744
|
4
|
|
|
|
|
10
|
$self->{code}; |
745
|
|
|
|
|
|
|
} |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
748
|
|
|
|
|
|
|
## _encodable($code, $string) |
749
|
|
|
|
|
|
|
## |
750
|
|
|
|
|
|
|
## Internal use only. Returns array of characters from $string that |
751
|
|
|
|
|
|
|
## can be encoded using the specified $code (A B or C). Note: not an |
752
|
|
|
|
|
|
|
## object-oriented method. |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
sub _encodable |
755
|
|
|
|
|
|
|
{ |
756
|
4
|
|
|
4
|
|
5
|
my($code, $string) = @_; |
757
|
4
|
|
|
|
|
4
|
my @chars; |
758
|
4
|
|
|
|
|
10
|
while (length $string) |
759
|
|
|
|
|
|
|
{ |
760
|
6
|
|
|
|
|
7
|
my $old = $string; |
761
|
6
|
|
100
|
|
|
39
|
push @chars, $1 while($code eq 'C' && $string =~ s/^(\d\d)//); |
762
|
6
|
|
|
|
|
6
|
my $char; |
763
|
6
|
|
|
|
|
26
|
while(defined($char = substr($string, 0, 1))) |
764
|
|
|
|
|
|
|
{ |
765
|
12
|
50
|
66
|
|
|
44
|
last if $code ne 'C' && $string =~ /^\d\d\d\d\d\d/; |
766
|
12
|
100
|
|
|
|
36
|
last unless exists $CODE{$code}{$char}; |
767
|
6
|
|
|
|
|
9
|
push @chars, $char; |
768
|
6
|
|
|
|
|
82
|
$string =~ s/^\Q$char\E//; |
769
|
|
|
|
|
|
|
} |
770
|
6
|
100
|
|
|
|
16
|
last if $old eq $string; # stop if no more changes made to $string |
771
|
|
|
|
|
|
|
} |
772
|
4
|
|
|
|
|
20
|
@chars; |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
=back |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
=head1 CLASS VARIABLES |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
None. |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
=head1 DIAGNOSTICS |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
=over 4 |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
=item Unrecognized option ($opt) for $class |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
The specified option is not valid for the module. C<$class> should be |
788
|
|
|
|
|
|
|
"Barcode::Code128" but if it has been inherited into another module, |
789
|
|
|
|
|
|
|
that module will show instead. C<$opt> is the attempted option. |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
=item The gd_image() method of Barcode::Code128 requires the GD module |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
To call the C, C, or C methods, the GD |
794
|
|
|
|
|
|
|
module must be present. This module is used to create the actual |
795
|
|
|
|
|
|
|
image. Without it, you can only use the C method. |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
=item Scale must be a positive integer |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
The scale factor for the C, C, or C methods |
800
|
|
|
|
|
|
|
must be a positive integer. |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
=item Border ($border) must be a positive integer or zero |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
The border option cannot be a fractional or negative number. |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
=item Invalid font $font |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
The specified font is not valid. Note that this is tested using |
809
|
|
|
|
|
|
|
GD->can(), and so any subroutine in GD.pm will pass this test - but |
810
|
|
|
|
|
|
|
only the fonts will actually work. See the GD module documentation |
811
|
|
|
|
|
|
|
for more. |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
=item Image width $x is too small for bar code |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
You have specified an image width that does not allow enough space for |
816
|
|
|
|
|
|
|
the bar code to be displayed. The minimum allowable is the size of |
817
|
|
|
|
|
|
|
the bar code itself plus 40 pixels. If in doubt, just omit the width |
818
|
|
|
|
|
|
|
value when calling C, C, or C and it will |
819
|
|
|
|
|
|
|
use the minimum. |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
=item Image height $y is too small for bar code |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
You have specified an image height that does not allow enough space |
824
|
|
|
|
|
|
|
for the bar code to be displayed. The minimum allowable is 15% of the |
825
|
|
|
|
|
|
|
width of the bar code. If in doubt, just omit the height value when |
826
|
|
|
|
|
|
|
calling C, C, or C and it will use the |
827
|
|
|
|
|
|
|
minimum. |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
=item Unable to create $x x $y image |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
An error occurred when initializing a GD::Image object for the |
832
|
|
|
|
|
|
|
specified size. Perhaps C<$x> and C<$y> are too large for memory? |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
=item The gif() method of Barcode::Code128 requires the GD module |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
=item The gif() method of Barcode::Code128 requires version less than 1.20 of GD |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
=item The png() method of Barcode::Code128 requires the GD module |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
=item The png() method of Barcode::Code128 requires at least version 1.20 of GD |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
These errors indicate that the GD module, or the correct version of |
843
|
|
|
|
|
|
|
the GD module for this method, was not present. You need to install |
844
|
|
|
|
|
|
|
GD version 1.20 or greater to create PNG files, or a version of GD |
845
|
|
|
|
|
|
|
less than 1.20 to create GIF files. |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
=item No encoded text found |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
This message from C typically means that there was no text |
850
|
|
|
|
|
|
|
message supplied either during the current method call or in a |
851
|
|
|
|
|
|
|
previous method call on the same object. This error occurs when you |
852
|
|
|
|
|
|
|
are trying to create a barcode by calling one of C, |
853
|
|
|
|
|
|
|
C, C, or C without having specified the text |
854
|
|
|
|
|
|
|
to be encoded. |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
=item No text defined |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
This message from C typically means that there was no text |
859
|
|
|
|
|
|
|
message supplied either during the current method call or in a |
860
|
|
|
|
|
|
|
previous method call on the same object. |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=item Invalid preferred code ``$preferred_code'' |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
This error means C was called with the C<$preferred_code> |
865
|
|
|
|
|
|
|
optional parameter but it was not one of ``A'', ``B'', or ``C''. |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
=item Sanity Check Overflow |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
This is a serious error in C that indicates a serious |
870
|
|
|
|
|
|
|
problem attempting to encode the requested message. This means that |
871
|
|
|
|
|
|
|
an infinite loop was generated. If you get this error please contact |
872
|
|
|
|
|
|
|
the author. |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
=item Unable to find encoding for ``$text'' |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
Part or all of the message could not be encoded. This may mean that |
877
|
|
|
|
|
|
|
the message contained characters not encodable in the CODE 128 |
878
|
|
|
|
|
|
|
character set, such as a character with an ASCII value higher than 127 |
879
|
|
|
|
|
|
|
(except the special control characters defined in this module). |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
=item Unable to switch from ``$old_code'' to ``$new_code'' |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
This is a serious error in C that indicates a serious problem |
884
|
|
|
|
|
|
|
occurred when switching between the codes (A, B, or C) of CODE 128. |
885
|
|
|
|
|
|
|
If you get this error please contact the author. |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
=item Unable to start with ``$new_code'' |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
This is a serious error in C that indicates a serious problem |
890
|
|
|
|
|
|
|
occurred when starting encoding in one of the codes (A, B, or C) of |
891
|
|
|
|
|
|
|
CODE 128. If you get this error please contact the author. |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
=item Unknown code ``$new_code'' (should be A, B, or C) |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
This is a serious error in C that indicates an invalid |
896
|
|
|
|
|
|
|
argument was supplied. Only the codes (A, B, or C) of CODE 128 may be |
897
|
|
|
|
|
|
|
supplied here. If you get this error please contact the author. |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
=back |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
=head1 BUGS |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
At least some Web browsers do not seem to handle PNG files with |
904
|
|
|
|
|
|
|
transparent backgrounds correctly. As a result, the default for PNG |
905
|
|
|
|
|
|
|
is to generate barcodes without transparent backgrounds - the |
906
|
|
|
|
|
|
|
background is grey instead. |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
=head1 AUTHOR |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
William R. Ward, wrw@bayview.com |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
=head1 SEE ALSO |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
perl(1), GD |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
=cut |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
1; |