File Coverage

blib/lib/Barcode/Code128.pm
Criterion Covered Total %
statement 140 245 57.1
branch 27 102 26.4
condition 13 43 30.2
subroutine 28 33 84.8
pod 11 11 100.0
total 219 434 50.4


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 statement or use the special token ':all' instead
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;