Skip Menu |
 

This queue is for tickets about the Barcode-Code128 CPAN distribution.

Report information
The Basics
Id: 121717
Status: new
Priority: 0/
Queue: Barcode-Code128

People
Owner: Nobody in particular
Requestors: BOBMATH [...] cpan.org
Cc:
AdminCc:

Bug Information
Severity: Wishlist
Broken in: (no value)
Fixed in: (no value)



Subject: optimize encoding
Download (untitled) / with headers
text/plain 121b
The encoder doesn't always produce the shortest possible encoding. Here's a nifty optimizing encoder. Use it if you like.
Subject: encode.pl
Download encode.pl
text/x-perl 2.6k
use strict; use warnings; for my $str ( "12", # use Code C "123", # don't use Code C "1234", # use C "12345", # use C (odd length) "abc1234", # C at end "abc12345", # C at end (odd length) "1234abc", # C at beginning "abc1234def", # no C in middle "abc123456def", # C in middle "abc1234\n", # C in middle "abc\ndef", # shift to Code A ) { my @code = encode128($str); my $len = @code; print "$str => @code ($len)\n"; } sub encode128 { # find an optimal Code128 encoding for $str my ($str) = @_; my $a = { code => 103, len => 1 }; my $b = { code => 104, len => 1 }; my $c = { code => 105, len => 1 }; my ($hold, $digit); for my $s (unpack 'C*', $str) { if ($s >= 48 && $s <= 57) { # try code C ($hold, $c) = ( $c || extend($a->{len} <= $b->{len} ? $a : $b, 99), $hold && extend($hold, $digit*10 + $s - 528) ); $digit = $s; } elsif ($s == 0xf1) { $c = extend($c, 102) if $c; $hold = $digit = undef; } else { $c = $hold = $digit = undef; } if ($s >= 32 && $s <= 95) { # Code A or Code B $a = extend($a, $s - 32); $b = extend($b, $s - 32); } elsif ($s <= 31) { # Code A only $a = extend($a, $s + 64); $b = $a->{len} <= $b->{len} ? extend($a, 100) : extend($b, 98, $s + 64); } elsif ($s >= 96 && $s <= 127) { # Code B only $b = extend($b, $s - 32); $a = $b->{len} <= $a->{len} ? extend($b, 101) : extend($a, 98, $s - 32); } elsif ($s == 0xf1) { $a = extend($a, 102); $b = extend($b, 102); } elsif ($s == 0xf2) { $a = extend($a, 97); $b = extend($b, 97); } elsif ($s == 0xf3) { $a = extend($a, 96); $b = extend($b, 96); } elsif ($s == 0xf4) { $a = extend($a, 101); $b = extend($b, 100); } else { die "Illegal character in string: $s"; } if ($c) { $a = extend($c, 101) if $c->{len} + 1 < $a->{len}; $b = extend($c, 100) if $c->{len} + 1 < $b->{len}; } } # pick best encoding $a = $b if $b->{len} < $a->{len}; $a = $c if $c && $c->{len} < $a->{len}; my @codes; while ($a) { unshift @codes, $a->{code}; $a = $a->{next}; } # calculate checksum my $sum = $codes[0]; $sum += $codes[$_] * $_ for 1 .. $#codes; push @codes, $sum % 103, 106; return wantarray ? @codes : \@codes; } sub extend { my ($node, @codes) = @_; foreach my $c (@codes) { $node = { next => $node, len => $node->{len}+1, code => $c }; } return $node; }


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.