init III
This commit is contained in:
@@ -0,0 +1,190 @@
|
||||
package PDF::API2::Resource::XObject::Form::BarCode;
|
||||
|
||||
use base 'PDF::API2::Resource::XObject::Form::Hybrid';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
use PDF::API2::Util;
|
||||
use PDF::API2::Basic::PDF::Utils;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
PDF::API2::Resource::XObject::Form::BarCode - Base class for one-dimensional barcodes
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $barcode = PDF::API2::Resource::XObject::Form::BarCode->new($pdf, %options)
|
||||
|
||||
Creates a barcode form resource.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, $pdf, %options) = @_;
|
||||
my $self = $class->SUPER::new($pdf);
|
||||
|
||||
$self->{' bfont'} = $options{'-font'};
|
||||
|
||||
$self->{' umzn'} = $options{'-umzn'} || 0; # (u)pper (m)ending (z)o(n)e
|
||||
$self->{' lmzn'} = $options{'-lmzn'} || 0; # (l)ower (m)ending (z)o(n)e
|
||||
$self->{' zone'} = $options{'-zone'} || 0; # barcode height
|
||||
$self->{' quzn'} = $options{'-quzn'} || 0; # (qu)iet (z)o(n)e
|
||||
$self->{' ofwt'} = $options{'-ofwt'} || 0.01; # (o)ver(f)low (w)id(t)h
|
||||
$self->{' fnsz'} = $options{'-fnsz'}; # (f)o(n)t(s)i(z)e
|
||||
$self->{' spcr'} = $options{'-spcr'} || ''; # (sp)a(c)e(r) between chars in label
|
||||
$self->{' mils'} = $options{'-mils'} || 1000/72; # single barcode unit width. 1 mil = 1/1000 of one inch. 1000/72 - for backward compatibility
|
||||
$self->{' color'} = $options{'-color'} || 'black'; # barcode color
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
my %bar_widths = (
|
||||
0 => 0,
|
||||
1 => 1, 'a' => 1, 'A' => 1,
|
||||
2 => 2, 'b' => 2, 'B' => 2,
|
||||
3 => 3, 'c' => 3, 'C' => 3,
|
||||
4 => 4, 'd' => 4, 'D' => 4,
|
||||
5 => 5, 'e' => 5, 'E' => 5,
|
||||
6 => 6, 'f' => 6, 'F' => 6,
|
||||
7 => 7, 'g' => 7, 'G' => 7,
|
||||
8 => 8, 'h' => 8, 'H' => 8,
|
||||
9 => 9, 'i' => 9, 'I' => 9,
|
||||
);
|
||||
|
||||
sub encode {
|
||||
my ($self, $string) = @_;
|
||||
my @bars = map { [ $self->encode_string($_), $_ ] } split //, $string;
|
||||
return @bars;
|
||||
}
|
||||
|
||||
sub encode_string {
|
||||
my ($self, $string) = @_;
|
||||
|
||||
my $bar;
|
||||
foreach my $character (split //, $string) {
|
||||
$bar .= $self->encode_char($character);
|
||||
}
|
||||
return $bar;
|
||||
}
|
||||
|
||||
sub drawbar {
|
||||
my $self = shift();
|
||||
my @sets = @{shift()};
|
||||
my $caption = shift();
|
||||
|
||||
$self->fillcolor($self->{' color'});
|
||||
$self->strokecolor($self->{' color'});
|
||||
$self->linedash();
|
||||
|
||||
my $x = $self->{' quzn'};
|
||||
my $is_space_next = 0;
|
||||
my $wdt_factor = $self->{' mils'} / 1000 * 72;
|
||||
foreach my $set (@sets) {
|
||||
my ($code, $label);
|
||||
if (ref($set)) {
|
||||
($code, $label) = @{$set};
|
||||
}
|
||||
else {
|
||||
$code = $set;
|
||||
$label = undef;
|
||||
}
|
||||
|
||||
my $code_width = 0;
|
||||
my ($font_size, $y_label);
|
||||
foreach my $bar (split //, $code) {
|
||||
my $bar_width = $bar_widths{$bar} * $wdt_factor;
|
||||
|
||||
my ($y0, $y1);
|
||||
if ($bar =~ /[0-9]/) {
|
||||
$y0 = $self->{' quzn'} + $self->{' lmzn'};
|
||||
$y1 = $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'} + $self->{' umzn'};
|
||||
$y_label = $self->{' quzn'};
|
||||
$font_size = $self->{' fnsz'} || $self->{' lmzn'};
|
||||
}
|
||||
elsif ($bar =~ /[a-z]/) {
|
||||
$y0 = $self->{' quzn'};
|
||||
$y1 = $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'} + $self->{' umzn'};
|
||||
$y_label = $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'} + $self->{' umzn'};
|
||||
$font_size = $self->{' fnsz'} || $self->{' umzn'};
|
||||
}
|
||||
elsif ($bar =~ /[A-Z]/) {
|
||||
$y0 = $self->{' quzn'};
|
||||
$y1 = $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'};
|
||||
$font_size = $self->{' fnsz'} || $self->{' umzn'};
|
||||
$y_label = $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'} + $self->{' umzn'} - $font_size;
|
||||
}
|
||||
else {
|
||||
$y0 = $self->{' quzn'} + $self->{' lmzn'};
|
||||
$y1 = $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'} + $self->{' umzn'};
|
||||
$y_label = $self->{' quzn'};
|
||||
$font_size = $self->{' fnsz'} || $self->{' lmzn'};
|
||||
}
|
||||
|
||||
unless ($is_space_next or $bar eq '0') {
|
||||
$self->linewidth($bar_width - $self->{' ofwt'});
|
||||
$self->move($x + $code_width + $bar_width / 2, $y0);
|
||||
$self->line($x + $code_width + $bar_width / 2, $y1);
|
||||
$self->stroke();
|
||||
}
|
||||
$is_space_next = not $is_space_next;
|
||||
|
||||
$code_width += $bar_width;
|
||||
}
|
||||
|
||||
if (defined($label) and $self->{' lmzn'}) {
|
||||
$label = join($self->{' spcr'}, split //, $label);
|
||||
$self->textstart();
|
||||
$self->translate($x + ($code_width / 2), $y_label);
|
||||
$self->font($self->{' bfont'}, $font_size);
|
||||
$self->text_center($label);
|
||||
$self->textend();
|
||||
}
|
||||
|
||||
$x += $code_width;
|
||||
}
|
||||
|
||||
$x += $self->{' quzn'};
|
||||
|
||||
if (defined $caption) {
|
||||
my $font_size = $self->{' fnsz'} || $self->{' lmzn'};
|
||||
my $y_caption = $self->{' quzn'} - $font_size;
|
||||
$self->textstart();
|
||||
$self->translate($x / 2, $y_caption);
|
||||
$self->font($self->{' bfont'}, $font_size);
|
||||
$self->text_center($caption);
|
||||
$self->textend();
|
||||
}
|
||||
|
||||
$self->{' w'} = $x;
|
||||
$self->{' h'} = 2 * $self->{' quzn'} + $self->{' lmzn'} + $self->{' zone'} + $self->{' umzn'};
|
||||
$self->bbox(0, 0, $self->{' w'}, $self->{' h'});
|
||||
}
|
||||
|
||||
=item $width = $barcode->width()
|
||||
|
||||
=cut
|
||||
|
||||
sub width {
|
||||
my $self = shift();
|
||||
return $self->{' w'};
|
||||
}
|
||||
|
||||
=item $height = $barcode->height()
|
||||
|
||||
=cut
|
||||
|
||||
sub height {
|
||||
my $self = shift();
|
||||
return $self->{' h'};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,36 @@
|
||||
package PDF::API2::Resource::XObject::Form::BarCode::codabar;
|
||||
|
||||
use base 'PDF::API2::Resource::XObject::Form::BarCode';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
sub new {
|
||||
my ($class, $pdf, %options) = @_;
|
||||
my $self = $class->SUPER::new($pdf, %options);
|
||||
|
||||
my @bars = $self->encode($options{'-code'});
|
||||
|
||||
$self->drawbar([@bars], $options{'caption'});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
my $codabar = q|0123456789-$:/.+ABCD|;
|
||||
|
||||
my @barcodabar = qw(
|
||||
11111221 11112211 11121121 22111111 11211211
|
||||
21111211 12111121 12112111 12211111 21121111
|
||||
11122111 11221111 21112121 21211121 21212111
|
||||
11212121 aabbabaa ababaaba ababaaba aaabbbaa
|
||||
);
|
||||
|
||||
sub encode_char {
|
||||
my $self = shift();
|
||||
my $char = uc shift();
|
||||
return $barcodabar[index($codabar, $char)];
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,239 @@
|
||||
package PDF::API2::Resource::XObject::Form::BarCode::code128;
|
||||
|
||||
use base 'PDF::API2::Resource::XObject::Form::BarCode';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
=head1 NAME
|
||||
|
||||
PDF::API2::Resource::XObject::Form::BarCode::code128 - Code 128 and EAN-128 barcode support
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $res = PDF::API2::Resource::XObject::Form::BarCode::code128->new($pdf, %options)
|
||||
|
||||
Returns a code128 object. Use '-ean' to encode using EAN128 mode.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, $pdf, %options) = @_;
|
||||
$class = ref($class) if ref($class);
|
||||
|
||||
my $self = $class->SUPER::new($pdf, %options);
|
||||
|
||||
my @bars;
|
||||
if ($options{'-ean'}) {
|
||||
@bars = $self->encode_ean128($options{'-code'});
|
||||
}
|
||||
else {
|
||||
@bars = $self->encode_128($options{'-type'}, $options{'-code'});
|
||||
}
|
||||
|
||||
$self->drawbar(\@bars, $options{'caption'});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# CODE-A Encoding Table
|
||||
my $code128a = q| !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_| . join('', map { chr($_) } (0..31)) . qq/\xf3\xf2\x80\xcc\xcb\xf4\xf1\x8a\x8b\x8c\xff/;
|
||||
|
||||
# CODE-B Encoding Table
|
||||
my $code128b = q| !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|.qq/|}~\x7f\xf3\xf2\x80\xcc\xf4\xca\xf1\x8a\x8b\x8c\xff/;
|
||||
|
||||
# CODE-C Encoding Table (00-99 are placeholders)
|
||||
my $code128c = ("\xfe" x 100) . qq/\xcb\xca\xf1\x8a\x8b\x8c\xff/;
|
||||
|
||||
# START A-C
|
||||
my $bar128Sa = "\x8a";
|
||||
my $bar128Sb = "\x8b";
|
||||
my $bar128Sc = "\x8c";
|
||||
|
||||
# FNC1-FNC4
|
||||
my $bar128F1 = "\xf1";
|
||||
my $bar128F2 = "\xf2";
|
||||
my $bar128F3 = "\xf3";
|
||||
my $bar128F4 = "\xf4";
|
||||
|
||||
# CODE A-C
|
||||
my $bar128Ca = "\xca";
|
||||
my $bar128Cb = "\xcb";
|
||||
my $bar128Cc = "\xcc";
|
||||
|
||||
# SHIFT
|
||||
my $bar128sh = "\x80";
|
||||
|
||||
# STOP
|
||||
my $bar128St = "\xff";
|
||||
|
||||
# Note: The stop code (last position) is longer than the other codes because it also has the
|
||||
# termination bar appended, rather than requiring it be added as a separate call.
|
||||
my @bar128 = qw(
|
||||
212222 222122 222221 121223 121322 131222 122213 122312 132212 221213
|
||||
221312 231212 112232 122132 122231 113222 123122 123221 223211 221132
|
||||
221231 213212 223112 312131 311222 321122 321221 312212 322112 322211
|
||||
212123 212321 232121 111323 131123 131321 112313 132113 132311 211313
|
||||
231113 231311 112133 112331 132131 113123 113321 133121 313121 211331
|
||||
231131 213113 213311 213131 311123 311321 331121 312113 312311 332111
|
||||
314111 221411 431111 111224 111422 121124 121421 141122 141221 112214
|
||||
112412 122114 122411 142112 142211 241211 221114 413111 241112 134111
|
||||
111242 121142 121241 114212 124112 124211 411212 421112 421211 212141
|
||||
214121 412121 111143 111341 131141 114113 114311 411113 411311 113141
|
||||
114131 311141 411131 b1a4a2 b1a2a4 b1a2c2 b3c1a1b
|
||||
);
|
||||
|
||||
sub encode_128_char_idx {
|
||||
my ($code, $char) = @_;
|
||||
my $index;
|
||||
|
||||
if (lc($code) eq 'a') {
|
||||
# Ignore CODE-A request if we're already in CODE-A
|
||||
return if $char eq $bar128Ca;
|
||||
|
||||
$index = index($code128a, $char);
|
||||
}
|
||||
elsif (lc($code) eq 'b') {
|
||||
# Ignore CODE-B request if we're already in CODE-B
|
||||
return if $char eq $bar128Cb;
|
||||
$index = index($code128b, $char);
|
||||
}
|
||||
elsif (lc($code) eq 'c') {
|
||||
# Ignore CODE-C request if we're already in CODE-C
|
||||
return if $char eq $bar128Cc;
|
||||
|
||||
if ($char =~ /^([0-9][0-9])$/) {
|
||||
$index = $1;
|
||||
}
|
||||
else {
|
||||
$index = index($code128c, $char);
|
||||
}
|
||||
}
|
||||
|
||||
return ($bar128[$index], $index);
|
||||
}
|
||||
|
||||
sub encode_128_char {
|
||||
my ($code, $char) = @_;
|
||||
my ($b) = encode_128_char_idx($code, $char);
|
||||
return $b;
|
||||
}
|
||||
|
||||
sub encode_128_string {
|
||||
my ($code, $string) = @_;
|
||||
my ($bar, $index, @bars, @checksum);
|
||||
my @characters = split(//, $string);
|
||||
|
||||
my $character;
|
||||
while (defined($character = shift @characters)) {
|
||||
if ($character =~ /[\xf1-\xf4]/) {
|
||||
# CODE-C doesn't have FNC2-FNC4
|
||||
if ($character =~ /[\xf2-\xf4]/ and $code eq 'c') {
|
||||
($bar, $index) = encode_128_char_idx($code, "\xCB");
|
||||
push @bars, $bar;
|
||||
push @checksum, $index;
|
||||
$code = 'b';
|
||||
}
|
||||
|
||||
($bar, $index) = encode_128_char_idx($code, $character);
|
||||
}
|
||||
elsif ($character =~ /[\xCA-\xCC]/) {
|
||||
($bar, $index) = encode_128_char_idx($code, $character);
|
||||
$code = ($character eq "\xCA" ? 'a' :
|
||||
$character eq "\xCB" ? 'b' : 'c');
|
||||
}
|
||||
else {
|
||||
if ($code ne 'c') {
|
||||
# SHIFT: Switch codes for the following character only
|
||||
if ($character eq $bar128sh) {
|
||||
($bar, $index) = encode_128_char_idx($code, $character);
|
||||
push @bars, $bar;
|
||||
push @checksum, $index;
|
||||
$character = shift(@characters);
|
||||
($bar, $index) = encode_128_char_idx($code eq 'a' ? 'b' : 'a', $character);
|
||||
}
|
||||
else {
|
||||
($bar, $index) = encode_128_char_idx($code, $character);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$character .= shift(@characters) if $character =~ /\d/ and scalar @characters;
|
||||
if ($character =~ /^[^\d]*$/ or $character =~ /^\d[^\d]*$/) {
|
||||
($bar, $index) = encode_128_char_idx($code, "\xCB");
|
||||
push @bars, $bar;
|
||||
push @checksum, $index;
|
||||
$code = 'b';
|
||||
}
|
||||
if ($character =~ /^\d[^\d]*$/) {
|
||||
unshift(@characters, substr($character, 1, 1)) if length($character) > 1;
|
||||
$character = substr($character, 0, 1);
|
||||
}
|
||||
($bar, $index) = encode_128_char_idx($code, $character);
|
||||
}
|
||||
}
|
||||
$character = '' if $character =~ /[^\x20-\x7e]/;
|
||||
push @bars, [$bar, $character];
|
||||
push @checksum, $index;
|
||||
}
|
||||
return ([@bars], @checksum);
|
||||
}
|
||||
|
||||
sub encode_128 {
|
||||
my ($self, $code, $string) = @_;
|
||||
my @bars;
|
||||
my $checksum_value;
|
||||
|
||||
# Default to Code C if all characters are digits (and there are at
|
||||
# least two of them). Otherwise, default to Code B.
|
||||
$code ||= $string =~ /^\d{2,}$/ ? 'c' : 'b';
|
||||
|
||||
# Allow the character set to be passed as a capital letter
|
||||
# (consistent with the specification).
|
||||
$code = lc($code) if $code =~ /^[A-C]$/;
|
||||
|
||||
# Ensure a valid character set has been chosen.
|
||||
die "Character set must be A, B, or C (not '$code')" unless $code =~ /^[a-c]$/;
|
||||
|
||||
if ($code eq 'a') {
|
||||
push @bars, encode_128_char($code, $bar128Sa);
|
||||
$checksum_value = 103;
|
||||
}
|
||||
elsif ($code eq 'b') {
|
||||
push @bars, encode_128_char($code, $bar128Sb);
|
||||
$checksum_value = 104;
|
||||
}
|
||||
elsif ($code eq 'c') {
|
||||
push @bars, encode_128_char($code, $bar128Sc);
|
||||
$checksum_value = 105;
|
||||
}
|
||||
my ($bar, @checksum_values) = encode_128_string($code, $string);
|
||||
|
||||
push @bars, @{$bar};
|
||||
|
||||
# Calculate the checksum value
|
||||
foreach my $i (1 .. scalar @checksum_values) {
|
||||
$checksum_value += $i * $checksum_values[$i - 1];
|
||||
}
|
||||
$checksum_value %= 103;
|
||||
push @bars, $bar128[$checksum_value];
|
||||
push @bars, encode_128_char($code, $bar128St);
|
||||
|
||||
return @bars;
|
||||
}
|
||||
|
||||
sub encode_ean128 {
|
||||
my ($self, $string) = @_;
|
||||
$string =~ s/[^a-zA-Z\d]+//g;
|
||||
$string =~ s/(\d+)([a-zA-Z]+)/$1\xcb$2/g;
|
||||
$string =~ s/([a-zA-Z]+)(\d+)/$1\xcc$2/g;
|
||||
|
||||
return $self->encode_128('c', "\xf1$string");
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,113 @@
|
||||
package PDF::API2::Resource::XObject::Form::BarCode::code3of9;
|
||||
|
||||
use base 'PDF::API2::Resource::XObject::Form::BarCode';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
sub new {
|
||||
my ($class, $pdf, %options) = @_;
|
||||
my $self = $class->SUPER::new($pdf, %options);
|
||||
|
||||
my @bars = encode_3of9($options{'-code'},
|
||||
$options{'-chk'} ? 1 : 0,
|
||||
$options{'-ext'} ? 1 : 0);
|
||||
|
||||
$self->drawbar([@bars], $options{'caption'});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
my $code3of9 = q(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%*);
|
||||
|
||||
my @bar3of9 = qw(
|
||||
1112212111 2112111121 1122111121 2122111111
|
||||
1112211121 2112211111 1122211111 1112112121
|
||||
2112112111 1122112111 2111121121 1121121121
|
||||
2121121111 1111221121 2111221111 1121221111
|
||||
1111122121 2111122111 1121122111 1111222111
|
||||
2111111221 1121111221 2121111211 1111211221
|
||||
2111211211 1121211211 1111112221 2111112211
|
||||
1121112211 1111212211 2211111121 1221111121
|
||||
2221111111 1211211121 2211211111 1221211111
|
||||
1211112121 2211112111 1221112111 1212121111
|
||||
1212111211 1211121211 1112121211 abaababaa1
|
||||
);
|
||||
|
||||
my @extended_map = (
|
||||
'%U', '$A', '$B', '$C', '$D', '$E', '$F', '$G', '$H', '$I',
|
||||
'$J', '$K', '$L', '$M', '$N', '$O', '$P', '$Q', '$R', '$S',
|
||||
'$T', '$U', '$V', '$W', '$X', '$Y', '$Z', '%A', '%B', '%C',
|
||||
'%D', '$E', ' ', '/A', '/B', '/C', '/D', '/E', '/F', '/G',
|
||||
'/H', '/I', '/J', '/K', '/L', '-', '.', '/O', '0', '1',
|
||||
'2', '3', '4', '5', '6', '7', '8', '9', '/Z', '%F',
|
||||
'%G', '%H', '%I', '%J', '%V', 'A', 'B', 'C', 'D', 'E',
|
||||
'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
|
||||
'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
|
||||
'Z', '%K', '%L', '%M', '%N', '%O', '%W', '+A', '+B', '+C',
|
||||
'+D', '+E', '+F', '+G', '+H', '+I', '+J', '+K', '+L', '+M',
|
||||
'+N', '+O', '+P', '+Q', '+R', '+S', '+T', '+U', '+V', '+W',
|
||||
'+X', '+Y', '+Z', '%P', '%Q', '%R', '%S', '%T'
|
||||
);
|
||||
|
||||
sub encode_3of9_char {
|
||||
my $character = shift();
|
||||
return $bar3of9[index($code3of9, $character)];
|
||||
}
|
||||
|
||||
sub encode_3of9_string {
|
||||
my ($string, $is_mod43) = @_;
|
||||
|
||||
my $bar;
|
||||
my $checksum = 0;
|
||||
foreach my $char (split //, $string) {
|
||||
$bar .= encode_3of9_char($char);
|
||||
$checksum += index($code3of9, $char);
|
||||
}
|
||||
|
||||
if ($is_mod43) {
|
||||
$checksum %= 43;
|
||||
$bar .= $bar3of9[$checksum];
|
||||
}
|
||||
|
||||
return $bar;
|
||||
}
|
||||
|
||||
# Deprecated (rolled into encode_3of9_string)
|
||||
sub encode_3of9_string_w_chk { return encode_3of9_string(shift(), 1); }
|
||||
|
||||
sub encode_3of9 {
|
||||
my ($string, $is_mod43, $is_extended) = @_;
|
||||
|
||||
my $display;
|
||||
unless ($is_extended) {
|
||||
$string = uc $string;
|
||||
$string =~ s/[^0-9A-Z\-\.\ \$\/\+\%]+//g;
|
||||
$display = $string;
|
||||
}
|
||||
else {
|
||||
# Extended Code39 supports all 7-bit ASCII characters
|
||||
$string =~ s/[^\x00-\x7f]//g;
|
||||
$display = $string;
|
||||
|
||||
# Encode, but don't display, non-printable characters
|
||||
$display =~ s/[[:cntrl:]]//g;
|
||||
|
||||
$string = join('', map { $extended_map[ord($_)] } split //, $string);
|
||||
}
|
||||
|
||||
my @bars;
|
||||
push @bars, encode_3of9_char('*');
|
||||
push @bars, [ encode_3of9_string($string, $is_mod43), $display ];
|
||||
push @bars, encode_3of9_char('*');
|
||||
return @bars;
|
||||
}
|
||||
|
||||
# Deprecated (rolled into encode_3of9)
|
||||
sub encode_3of9_w_chk { return encode_3of9(shift(), 1, 0); }
|
||||
sub encode_3of9_ext { return encode_3of9(shift(), 0, 1); }
|
||||
sub encode_3of9_ext_w_chk { return encode_3of9(shift(), 1, 1); }
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,78 @@
|
||||
package PDF::API2::Resource::XObject::Form::BarCode::ean13;
|
||||
|
||||
use base 'PDF::API2::Resource::XObject::Form::BarCode';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
sub new {
|
||||
my ($class, $pdf, %options) = @_;
|
||||
my $self = $class->SUPER::new($pdf, %options);
|
||||
|
||||
my @bars = $self->encode($options{'-code'});
|
||||
|
||||
$self->drawbar([@bars], $options{'caption'});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
my @ean_code_odd = qw(3211 2221 2122 1411 1132 1231 1114 1312 1213 3112);
|
||||
my @ean_code_even = qw(1123 1222 2212 1141 2311 1321 4111 2131 3121 2113);
|
||||
my @parity = qw(OOOOOO OOEOEE OOEEOE OOEEEO OEOOEE OEEOOE OEEEOO OEOEOE OEOEEO OEEOEO);
|
||||
|
||||
sub encode {
|
||||
my ($self, $string) = @_;
|
||||
my @digits = split //, $string;
|
||||
|
||||
# The first digit determines the even/odd pattern of the next six
|
||||
# digits, and is printed to the left of the barcode
|
||||
my $first = shift @digits;
|
||||
my @bars = (['07', $first]);
|
||||
|
||||
# Start Guard
|
||||
push @bars, 'a1a';
|
||||
|
||||
# Digits 2-7
|
||||
foreach my $i (0 .. 5) {
|
||||
my $digit = shift @digits;
|
||||
if (substr($parity[$first], $i, 1) eq 'O') {
|
||||
push @bars, [$ean_code_odd[$digit], $digit];
|
||||
}
|
||||
else {
|
||||
push @bars, [$ean_code_even[$digit], $digit];
|
||||
}
|
||||
}
|
||||
|
||||
# Center Guard
|
||||
push @bars, '1a1a1';
|
||||
|
||||
# Digits 8-13
|
||||
for (0..5) {
|
||||
my $digit = shift @digits;
|
||||
push @bars, [$ean_code_odd[$digit], $digit];
|
||||
}
|
||||
|
||||
# Right Guard
|
||||
push @bars, 'a1a';
|
||||
|
||||
return @bars;
|
||||
}
|
||||
|
||||
sub calculate_check_digit {
|
||||
my ($self, $string) = @_;
|
||||
my @digits = split //, $string;
|
||||
my $weight = 1;
|
||||
my $checksum = 0;
|
||||
foreach my $i (0..11) {
|
||||
$checksum += $digits[$i] * $weight;
|
||||
$weight = $weight == 1 ? 3 : 1;
|
||||
}
|
||||
|
||||
$checksum = $checksum % 10;
|
||||
return 0 unless $checksum;
|
||||
return 10 - $checksum;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,62 @@
|
||||
package PDF::API2::Resource::XObject::Form::BarCode::int2of5;
|
||||
|
||||
use base 'PDF::API2::Resource::XObject::Form::BarCode';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
# Interleaved 2 of 5 Barcodes
|
||||
|
||||
# Pairs of digits are encoded; the first digit is represented by five
|
||||
# bars, and the second digit is represented by five spaces interleaved
|
||||
# with the bars.
|
||||
|
||||
sub new {
|
||||
my ($class, $pdf, %options) = @_;
|
||||
my $self = $class->SUPER::new($pdf,%options);
|
||||
|
||||
my @bars = $self->encode($options{'-code'});
|
||||
|
||||
$self->drawbar([@bars], $options{'caption'});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
my @bar25interleaved = qw(11221 21112 12112 22111 11212 21211 12211 11122 21121 12121);
|
||||
|
||||
sub encode {
|
||||
my ($self, $string) = @_;
|
||||
|
||||
# Remove any character that isn't a digit
|
||||
$string =~ s/[^0-9]//g;
|
||||
|
||||
# Prepend a 0 if there is an odd number of digits
|
||||
$string = '0' . $string if length($string) % 2;
|
||||
|
||||
# Start Code
|
||||
my @bars = ('aaaa');
|
||||
|
||||
# Encode pairs of digits
|
||||
my ($c1, $c2, $s1, $s2, $pair);
|
||||
while (length($string)) {
|
||||
($c1, $c2, $string) = split //, $string, 3;
|
||||
|
||||
$s1 = $bar25interleaved[$c1];
|
||||
$s2 = $bar25interleaved[$c2];
|
||||
$pair = '';
|
||||
foreach my $i (0 .. 4) {
|
||||
$pair .= substr($s1, $i, 1);
|
||||
$pair .= substr($s2, $i, 1);
|
||||
}
|
||||
push @bars, [$pair, ($c1 . $c2)];
|
||||
}
|
||||
|
||||
# Stop Code
|
||||
push @bars, 'baaa';
|
||||
|
||||
return @bars;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,58 @@
|
||||
package PDF::API2::Resource::XObject::Form::Hybrid;
|
||||
|
||||
use base qw(PDF::API2::Content PDF::API2::Resource::XObject::Form);
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.033'; # VERSION
|
||||
|
||||
use PDF::API2::Basic::PDF::Dict;
|
||||
use PDF::API2::Basic::PDF::Utils;
|
||||
use PDF::API2::Resource::XObject::Form;
|
||||
|
||||
sub new {
|
||||
my $self = PDF::API2::Resource::XObject::Form::new(@_);
|
||||
|
||||
$self->{' stream'} = '';
|
||||
$self->{' poststream'} = '';
|
||||
$self->{' font'} = undef;
|
||||
$self->{' fontsize'} = 0;
|
||||
$self->{' charspace'} = 0;
|
||||
$self->{' hscale'} = 100;
|
||||
$self->{' wordspace'} = 0;
|
||||
$self->{' lead'} = 0;
|
||||
$self->{' rise'} = 0;
|
||||
$self->{' render'} = 0;
|
||||
$self->{' matrix'} = [1, 0, 0, 1, 0, 0];
|
||||
$self->{' fillcolor'} = [0];
|
||||
$self->{' strokecolor'} = [0];
|
||||
$self->{' translate'} = [0, 0];
|
||||
$self->{' scale'} = [1, 1];
|
||||
$self->{' skew'} = [0, 0];
|
||||
$self->{' rotate'} = 0;
|
||||
$self->{' apiistext'} = 0;
|
||||
|
||||
$self->{'Resources'} = PDFDict();
|
||||
$self->{'Resources'}->{'ProcSet'} = PDFArray(map { PDFName($_) } qw(PDF Text ImageB ImageC ImageI));
|
||||
|
||||
$self->compressFlate();
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub outobjdeep {
|
||||
my ($self, @options) = @_;
|
||||
$self->textend() unless $self->{' nofilt'};
|
||||
|
||||
# Maintainer's Note: This list of keys isn't the same as the list
|
||||
# in new(). Should it be?
|
||||
foreach my $key (qw(api apipdf apipage font fontsize charspace hscale
|
||||
wordspace lead rise render matrix fillcolor
|
||||
strokecolor translate scale skew rotate)) {
|
||||
delete $self->{" $key"};
|
||||
}
|
||||
return PDF::API2::Basic::PDF::Dict::outobjdeep($self, @options);
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user