File Coverage

blib/lib/Imager/Barcode128.pm
Criterion Covered Total %
statement 134 137 97.8
branch 19 28 67.8
condition 8 15 53.3
subroutine 24 24 100.0
pod 1 5 20.0
total 186 209 89.0


line stmt bran cond sub pod time code
1             package Imager::Barcode128;
2             $Imager::Barcode128::VERSION = '0.0103';
3 1     1   757 use strict;
  1         2  
  1         29  
4 1     1   529 use Moo;
  1         11510  
  1         5  
5 1     1   2464 use Imager;
  1         44450  
  1         7  
6 1     1   556 use Ouch;
  1         2363  
  1         4  
7 1     1   75 use Exporter;
  1         2  
  1         33  
8 1     1   6 use base 'Exporter';
  1         2  
  1         135  
9              
10 1     1   6 use constant CodeA => chr(0xf4);
  1         2  
  1         53  
11 1     1   6 use constant CodeB => chr(0xf5);
  1         3  
  1         44  
12 1     1   5 use constant CodeC => chr(0xf6);
  1         2  
  1         43  
13 1     1   5 use constant FNC1 => chr(0xf7);
  1         2  
  1         46  
14 1     1   17 use constant FNC2 => chr(0xf8);
  1         2  
  1         52  
15 1     1   5 use constant FNC3 => chr(0xf9);
  1         2  
  1         54  
16 1     1   7 use constant FNC4 => chr(0xfa);
  1         2  
  1         53  
17 1     1   5 use constant Shift => chr(0xfb);
  1         1  
  1         67  
18 1     1   6 use constant StartA => chr(0xfc);
  1         2  
  1         53  
19 1     1   6 use constant StartB => chr(0xfd);
  1         17  
  1         49  
20 1     1   6 use constant StartC => chr(0xfe);
  1         2  
  1         51  
21 1     1   7 use constant Stop => chr(0xff);
  1         1  
  1         2063  
22              
23             our @EXPORT_OK = qw(FNC1 FNC2 FNC3 FNC4 Shift);
24             our %EXPORT_TAGS = (all => \@EXPORT_OK);
25              
26             our @ENCODING = qw(11011001100 11001101100 11001100110 10010011000 10010001100 10001001100 10011001000 10011000100 10001100100 11001001000 11001000100 11000100100 10110011100 10011011100 10011001110 10111001100 10011101100 10011100110 11001110010 11001011100 11001001110 11011100100 11001110100 11101101110 11101001100 11100101100 11100100110 11101100100 11100110100 11100110010 11011011000 11011000110 11000110110 10100011000 10001011000 10001000110 10110001000 10001101000 10001100010 11010001000 11000101000 11000100010 10110111000 10110001110 10001101110 10111011000 10111000110 10001110110 11101110110 11010001110 11000101110 11011101000 11011100010 11011101110 11101011000 11101000110 11100010110 11101101000 11101100010 11100011010 11101111010 11001000010 11110001010 10100110000 10100001100 10010110000 10010000110 10000101100 10000100110 10110010000 10110000100 10011010000 10011000010 10000110100 10000110010 11000010010 11001010000 11110111010 11000010100 10001111010 10100111100 10010111100 10010011110 10111100100 10011110100 10011110010 11110100100 11110010100 11110010010 11011011110 11011110110 11110110110 10101111000 10100011110 10001011110 10111101000 10111100010 11110101000 11110100010 10111011110 10111101110 11101011110 11110101110 11010000100 11010010000 11010011100 1100011101011);
27              
28             our %CODE_CHARS = (
29             A => [ (map { chr($_) } 040..0137, 000..037), FNC3, FNC2, Shift, CodeC, CodeB, FNC4, FNC1, StartA, StartB, StartC, Stop ],
30             B => [ (map { chr($_) } 040..0177), FNC3, FNC2, Shift, CodeC, FNC4, CodeA, FNC1, StartA, StartB, StartC, Stop ],
31             C => [ ("00".."99"), CodeB, CodeA, FNC1, StartA, StartB, StartC, Stop ]
32             );
33              
34             # Provide string equivalents to the constants
35             our %FUNC_CHARS = ('CodeA' => CodeA,
36             'CodeB' => CodeB,
37             'CodeC' => CodeC,
38             'FNC1' => FNC1,
39             'FNC2' => FNC2,
40             'FNC3' => FNC3,
41             'FNC4' => FNC4,
42             'Shift' => Shift,
43             'StartA' => StartA,
44             'StartB' => StartB,
45             'StartC' => StartC,
46             'Stop' => Stop );
47              
48             # Convert the above into a 2-dimensional hash
49             our %CODE = ( A => { map { $CODE_CHARS{A}[$_] => $_ } 0..106 },
50             B => { map { $CODE_CHARS{B}[$_] => $_ } 0..106 },
51             C => { map { $CODE_CHARS{C}[$_] => $_ } 0..106 } );
52              
53              
54             =head1 NAME
55              
56             Imager::Barcode128 - Create GS1-128 compliant bar codes using Imager
57              
58             =head1 VERSION
59              
60             version 0.0103
61              
62             =head1 SYNOPSIS
63              
64             use Imager::Barcode128;
65              
66             my $barcode = Imager::Barcode128->new( text => 'My cool barcode' );
67             $barcode->draw;
68             $barcode->image->write(file => 'barcode.png');
69              
70             =head1 DESCRIPTION
71              
72             If you want to generate GS1-128 compliant bar codes using L then look no further!
73              
74             =head1 EXPORTS
75              
76             By default this module exports nothing. However, there are a number of constants that represent special characters used in the CODE 128 symbology that you may wish to include. For example if you are using the EAN-128 or UCC-128 code, the string to encode begins with the FNC1 character. To encode the EAN-128 string "00 0 0012345 555555555 8", you would do the following:
77              
78             my $barcode = Imager::Barcode128->new(text => FNC1.'00000123455555555558');
79              
80             To have this module export one or more of these characters, specify them on the use statement or use the special token ':all' instead to include all of them. Examples:
81              
82             use Imager::Barcode128 qw(FNC1 Shift);
83             use Imager::Barcode128 qw(:all);
84              
85             Here is the complete list of the exportable characters. They are assigned to high-order ASCII characters purely arbitrarily for the purposes of this module; the values used do not reflect any part of the GS1-128 standard.
86              
87             FNC1 0xf7
88             FNC2 0xf8
89             FNC3 0xf9
90             FNC4 0xfa
91             Shift 0xfb
92              
93             =head1 METHODS
94              
95             =head2 new(text => 'Product #45')
96              
97             Constructor.
98              
99             =over
100              
101             =item image
102              
103             The L object to draw the bar code on to. Required.
104              
105             =item text
106              
107             The text to be encoded into the bar code. Required.
108              
109             =item x
110              
111             The x coordinate of the top left corner to start drawing the bar code. Defaults to 0.
112              
113             =item y
114              
115             The y coordinate of the top left corner to start drawing the bar code. Defaults to 0.
116              
117             =back
118              
119             =cut
120              
121             =head2 x()
122              
123             Get or set the x coordinate of the top left corner of where to start drawing the bar code.
124              
125             =cut
126              
127             has x => (
128             is => 'rw',
129             default => sub { 0 },
130             );
131              
132             =head2 y()
133              
134             Get or set the y coordinate of the top left corner of where to start drawing the bar code.
135              
136             =cut
137              
138             has y => (
139             is => 'rw',
140             default => sub { 0 },
141             );
142              
143             =head2 color()
144              
145             Get or set the color of the bar code. Defaults to C. You can also pass an L object.
146              
147             =cut
148              
149             has color => (
150             is => 'rw',
151             default => sub { 'black' },
152             );
153              
154             =head2 scale()
155              
156             Get or set the scale of the bar code. Defaults to C<2>. Not recommended to set it to less than 2.
157              
158             A bar in the bar code is 1 pixel wide per unit of scale.
159              
160             =cut
161              
162             has scale => (
163             is => 'rw',
164             default => sub { 2 },
165             );
166              
167             =head2 height()
168              
169             Get or set the height of the bar code. Defaults to the height of the C.
170              
171             =cut
172              
173             has height => (
174             is => 'rw',
175             lazy => 1,
176             default => sub {
177             my $self = shift;
178             return $self->has_image ? $self->image->getheight : 100;
179             },
180             );
181              
182             =head2 image()
183              
184             Get or set the L object. Defaults to a 100px tall image with a white background. The image will be however long it needs to be to contain the bar code.
185              
186             =cut
187              
188             has image => (
189             is => 'rw',
190             lazy => 1,
191             predicate => 1,
192             default => sub {
193             my $self = shift;
194             my $x = length($self->_barcode) * $self->scale;
195             my $image = Imager->new(xsize => $x, ysize => $self->height);
196             $image->box(color => 'white', filled => 1);
197             return $image;
198             },
199             );
200              
201             =head2 text()
202              
203             Get or set the text to be encoded into the bar code.
204              
205             =cut
206              
207             has text => (
208             is => 'rw',
209             required => 1,
210             );
211              
212             has _code => ( # private
213             is => 'rw',
214             default => sub { '' },
215             isa => sub {
216             ouch('invalid code', 'Code must be one of A, B, or C.') unless ($_[0] eq 'A' || $_[0] eq 'B' || $_[0] eq 'C' || $_[0] eq '');
217             },
218             );
219              
220             has _encoded => ( # private
221             is => 'rw',
222             default => sub { [] },
223             );
224              
225             has _barcode => ( # private
226             is => 'rw',
227             lazy => 1,
228             default => sub {
229             my $self = shift;
230             return $self->barcode
231             },
232             );
233              
234             =head2 draw()
235              
236             Draws a barcode on the image. Returns C<$self> for method chaining.
237              
238             =cut
239              
240             sub draw {
241 1     1 1 1317 my $self = shift;
242 1         7 my @barcode = split //, $self->barcode;
243 1         34 my $x = $self->x;
244 1         5 my $y = $self->y;
245 1         11 my $scale = $self->scale;
246 1         21 my $image = $self->image;
247 1         28 my $height = $self->height;
248 1         20 my $color = $self->color;
249 1         4 foreach my $element (@barcode) {
250 123         6315 $x += $scale;
251 123 100       258 next unless $element eq '#';
252 60         142 $image->box(
253             color => $color,
254             xmin => $x - $scale,
255             ymin => $y,
256             xmax => $x,
257             ymax => $y + $height,
258             filled => 1,
259             );
260             }
261 1         113 return $self;
262             }
263              
264             sub barcode {
265 2     2 0 7 my $self = shift;
266 2         7 $self->encode;
267 2         4 my @encoded = @{ $self->_encoded };
  2         27  
268 2 50       7 ouch('no encoded text',"No encoded text found") unless @encoded;
269 2         4 return $self->_barcode(join '', map { $_ = $ENCODING[$_]; tr/01/ \#/; $_ } @encoded); # cache it in case we need it for other things
  22         30  
  22         40  
  22         68  
270             }
271              
272             sub encode {
273 2     2 0 4 my ($self, $preferred_code) = @_;
274 2 50 33     8 ouch('invalid preffered code',"Invalid preferred code ``$preferred_code''") if defined $preferred_code && !exists $CODE{$preferred_code};
275 2         6 my $text = $self->text;
276 2         44 $self->_code('');
277 2         17 my $encoded = $self->_encoded([]);
278 2         5 my $sanity = 0;
279 2         6 while (length $text) {
280 4 50       9 ouch('overflow',"Sanity Check Overflow") if $sanity++ > 1000;
281 4         9 my @chars;
282 4 50 33     18 if (defined $preferred_code && $preferred_code && (@chars = _encodable($preferred_code, $text))) {
    100 33        
283 0         0 $self->start($preferred_code);
284 0         0 push @$encoded, map { $CODE{$preferred_code}{$_} } @chars;
  0         0  
285             }
286             elsif (@chars = _encodable('C', $text)) {
287 2         7 $self->start('C');
288 2         15 push @$encoded, map { $CODE{C}{$_} } @chars;
  4         11  
289             }
290             else {
291 2         4 my %x = map { $_ => [ _encodable($_, $text) ] } qw(A B);
  4         9  
292 2 50       11 my $code = (@{$x{A}} >= @{$x{B}} ? 'A' : 'B'); # prefer A if equal
  2         7  
  2         5  
293 2         7 $self->start($code);
294 2         13 @chars = @{ $x{$code} };
  2         8  
295 2         5 push @$encoded, map { $CODE{$code}{$_} } @chars;
  10         22  
296             }
297 4 50       11 ouch('no encoding', "Unable to find encoding for ``$text''") unless @chars;
298 4         18 substr($text, 0, length join '', @chars) = '';
299             }
300 2         5 $self->stop;
301             }
302              
303             sub start {
304 4     4 0 7 my ($self, $new_code) = @_;
305 4         72 my $old_code = $self->_code;
306 4 100       26 if ($old_code ne '') {
307 2 50       7 my $func = $FUNC_CHARS{"Code$new_code"} or ouch('cannot switch codes', "Unable to switch from ``$old_code'' to ``$new_code''");
308 2         19 push @{ $self->_encoded }, $CODE{$old_code}{$func};
  2         12  
309             }
310             else {
311 2 50       9 my $func = $FUNC_CHARS{"Start$new_code"} or ouch('bad start code',"Unable to start with ``$new_code''");
312 2         4 @{ $self->_encoded } = $CODE{$new_code}{$func};
  2         7  
313             }
314 4         68 $self->_code($new_code);
315             }
316              
317             sub stop {
318 2     2 0 5 my ($self) = @_;
319 2         4 my $encoded = $self->_encoded;
320 2         4 my $sum = $encoded->[0];
321 2         4 for (my $i = 1; $i < @{ $encoded }; ++$i) {
  18         31  
322 16         24 $sum += $i * $encoded->[$i];
323             }
324 2         3 my $stop = Stop;
325 2         3 push @{ $encoded }, ($sum % 103), $CODE{C}{$stop};
  2         8  
326             }
327              
328             sub _encodable {
329 11     11   11032 my ($code, $string) = @_;
330 11         17 my @chars;
331 11         24 while (length $string) {
332 17         24 my $old = $string;
333 17   100     78 push @chars, $1 while($code eq 'C' && $string =~ s/^(\d\d)//);
334 17         25 my $char;
335 17         45 while (defined($char = substr($string, 0, 1))) {
336 43 50 66     134 last if $code ne 'C' && $string =~ /^\d\d\d\d\d\d/;
337 43 100       106 last unless exists $CODE{$code}{$char};
338 26         44 push @chars, $char;
339 26         230 $string =~ s/^\Q$char\E//;
340             }
341 17 100       41 last if $old eq $string; # stop if no more changes made to $string
342             }
343 11         53 return @chars;
344             }
345              
346             =head1 EXCEPTIONS
347              
348             This module will throw an L if anything goes wrong. Under normal circumstances you should not expect to need to handle exceptions.
349              
350             =head1 TODO
351              
352             None that I can think of at this time.
353              
354             =head2 SEE ALSO
355              
356             Most of the logic of this module was stolen from an older module called L. I build this because I wanted to generate the bar codes with L rather than L.
357              
358             =head1 PREREQS
359              
360             L
361             L
362             L
363              
364             =head1 SUPPORT
365              
366             =over
367              
368             =item Repository
369              
370             L
371              
372             =item Bug Reports
373              
374             L
375              
376             =back
377              
378              
379             =head1 AUTHOR
380              
381             =over
382              
383             =item JT Smith
384              
385             =back
386              
387             =head1 LEGAL
388              
389             Imager::Barcode128 is Copyright 2015 Plain Black Corporation (L) and is licensed under the same terms as Perl itself.
390              
391             =cut
392              
393             1;