File Coverage

blib/lib/PDF/Builder/Resource/XObject/Form/BarCode/int2of5.pm
Criterion Covered Total %
statement 32 32 100.0
branch 3 4 75.0
condition 1 3 33.3
subroutine 5 5 100.0
pod 1 2 50.0
total 42 46 91.3


line stmt bran cond sub pod time code
1             package PDF::Builder::Resource::XObject::Form::BarCode::int2of5;
2              
3 2     2   1043 use base 'PDF::Builder::Resource::XObject::Form::BarCode';
  2         6  
  2         237  
4              
5 2     2   13 use strict;
  2         5  
  2         47  
6 2     2   10 use warnings;
  2         4  
  2         873  
7              
8             our $VERSION = '3.025'; # VERSION
9             our $LAST_UPDATE = '3.024'; # manually update whenever code is changed
10              
11             =head1 NAME
12              
13             PDF::Builder::Resource::XObject::Form::BarCode::int2of5 - specific information for int 2-of-5 bar codes. Inherits from L
14              
15             =cut
16              
17             # Interleaved 2 of 5 Barcodes
18              
19             # Pairs of digits are encoded; the first digit is represented by five
20             # bars, and the second digit is represented by five spaces interleaved
21             # with the bars.
22              
23             sub new {
24 1     1 1 4 my ($class, $pdf, %options) = @_;
25             # copy dashed option names to preferred undashed names
26 1 50 33     7 if (defined $options{'-code'} && !defined $options{'code'}) { $options{'code'} = delete($options{'-code'}); }
  1         3  
27              
28 1         9 my $self = $class->SUPER::new($pdf,%options);
29              
30 1         4 my @bars = $self->encode($options{'code'});
31              
32 1         8 $self->drawbar([@bars], $options{'caption'});
33              
34 1         6 return $self;
35             }
36              
37             my @bar25interleaved = qw(11221 21112 12112 22111 11212 21211 12211 11122 21121 12121);
38              
39             sub encode {
40 2     2 0 743 my ($self, $string) = @_;
41              
42             # Remove any character that isn't a digit
43 2         11 $string =~ s/[^0-9]//g;
44              
45             # Prepend a 0 if there are an odd number of digits
46 2 100       11 $string = '0' . $string if length($string) % 2;
47              
48             # Start Code
49 2         7 my @bars = ('aaaa');
50              
51             # Encode pairs of digits
52 2         4 my ($c1, $c2, $s1, $s2, $pair);
53 2         6 while (length($string)) {
54 6         18 ($c1, $c2, $string) = split(//, $string, 3);
55              
56 6         15 $s1 = $bar25interleaved[$c1];
57 6         11 $s2 = $bar25interleaved[$c2];
58 6         10 $pair = '';
59 6         15 foreach my $i (0 .. 4) {
60 30         46 $pair .= substr($s1, $i, 1);
61 30         49 $pair .= substr($s2, $i, 1);
62             }
63 6         23 push @bars, [$pair, ($c1 . $c2)];
64             }
65              
66             # Stop Code
67 2         5 push @bars, 'baaa';
68              
69 2         7 return @bars;
70             }
71              
72             1;