This commit is contained in:
2024-10-14 00:08:40 +02:00
parent dbfba56f66
commit 1462d52e13
4572 changed files with 2658864 additions and 0 deletions

View File

@@ -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;

View File

@@ -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;

View File

@@ -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;

View File

@@ -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;

View File

@@ -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;

View File

@@ -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;

View File

@@ -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;