1 |
#!/usr/local/bin/perl |
2 |
# |
3 |
# Hacking EAN numbers to a form usable with WLEAN.MF. |
4 |
# |
5 |
# September 3, 1997 |
6 |
# Peter Willadt |
7 |
# |
8 |
# Added hacking any text for coding with code 128 |
9 |
# 1998-01-24 |
10 |
# |
11 |
# Added checksumming for code 93 |
12 |
# 1998-11-29 |
13 |
# |
14 |
# This file is free to use without any further permissions. |
15 |
# This file comes with no warranty of any kind. |
16 |
# |
17 |
# The TeX file to be filtered may contain any number of lines |
18 |
# that have one of the following commands |
19 |
# starting at the leftmost position. |
20 |
# |
21 |
# \ean{12 or 13 digit number} |
22 |
# the number gets coded as EAN, |
23 |
# if it is only 12 digits long, the checksum gets calculated |
24 |
# |
25 |
# \embed{number} |
26 |
# the number is used as a base for embedding article numbers & c. |
27 |
# \eean{number} |
28 |
# a number to be embedded with an ean. |
29 |
# |
30 |
# \isbn{number} |
31 |
# an isbn to make an embedded ean of. |
32 |
# |
33 |
# \cxxviii{any 7 bit ascii values} |
34 |
# code as barcode 128 (see rules below!) |
35 |
# |
36 |
# \xciii{uppercase text or number} |
37 |
# text to be coded as code 128 |
38 |
# |
39 |
# example: |
40 |
# You want the isbn 0-201-13448-9 to be embedded. |
41 |
# so you say \isbn{0201134489}, |
42 |
# but you may also say \embed{9780000000000} and, |
43 |
# somewhere later in the file, \eean{020113448} |
44 |
# In this case you have to leave the last digit out, |
45 |
# as isbn loose their check digit in favour of the |
46 |
# ean check digit. |
47 |
# anyway you do it, you get your command replaced by |
48 |
# \EAN{13-digit-number-coded-strange} |
49 |
# in the output file. |
50 |
# |
51 |
# |
52 |
# code 128 rules: |
53 |
# you write a line starting with \cxxviii{ |
54 |
# followed by arbitrary 7 bit characters, delimited by a right brace}. |
55 |
# as perl is greedy, it will be the rightmost right brace (no fence matching), |
56 |
# but as perl is also nice, you will be warned if there is another |
57 |
# right brace. Please note that even the percent character % will be |
58 |
# included. So it is better to write the \cxxviii{...} statement onto |
59 |
# a line of its own. You may replace any character by ^^00 and |
60 |
# similiar codes, preferably you will do this to non-printable ascii |
61 |
# characters, or right braces and the like. This routine will try to find |
62 |
# an efficent way to make code 128 (sorry, not necessarily the most |
63 |
# efficient way) out of your input and then it will |
64 |
# insert a line like \CXXVIII{3a 70 12 ... @@} in the output file. |
65 |
# The code 128 special characters can be included by the following codes: |
66 |
# ^^80 FNC3 |
67 |
# ^^81 FNC2 |
68 |
# ^^82 SHIFT |
69 |
# ^^83 CODE C/CODE C/99 |
70 |
# ^^84 CODE B/FNC4/CODE B |
71 |
# ^^85 FNC4/CODE A/CODE A |
72 |
# ^^86 FNC1 |
73 |
# ^^87 START A |
74 |
# ^^88 START B |
75 |
# ^^89 START C |
76 |
# ^^8a STOP |
77 |
|
78 |
# code switch table for ean |
79 |
|
80 |
@ABTAB=(0,0,0,0,0,0, #0 |
81 |
0,0,1,0,1,1, #1 |
82 |
0,0,1,1,0,1, #2 |
83 |
0,0,1,1,1,0, #3 |
84 |
0,1,0,0,1,1, #4 and so on |
85 |
0,1,1,0,0,1, |
86 |
0,1,1,1,0,0, |
87 |
0,1,0,1,0,1, |
88 |
0,1,0,1,1,0, |
89 |
0,1,1,0,1,0, |
90 |
); |
91 |
|
92 |
# command line processing: Need input file |
93 |
|
94 |
if($ARGV[0]){ |
95 |
$ifname=$ARGV[0]; |
96 |
}else{ |
97 |
print "Enter name of file to be processed: "; |
98 |
$ifname = <>; |
99 |
chomp($ifname); |
100 |
} |
101 |
|
102 |
# command line processing: need output file |
103 |
|
104 |
if($ARGV[1]){ |
105 |
$ofname=">$ARGV[1]"; |
106 |
}else{ |
107 |
print "Enter name of output file: "; |
108 |
$ofname = <>; |
109 |
chomp($ofname); |
110 |
} |
111 |
|
112 |
# make an ean |
113 |
|
114 |
sub eancod{ |
115 |
my $srcstr=shift; |
116 |
# first digits first |
117 |
my $precod=substr($srcstr,0,1); |
118 |
# Starting output string |
119 |
my $eastring=$precod . " +"; |
120 |
# digits 2--7 |
121 |
for($i=0;$i<6;$i++){ |
122 |
my $disone=substr($srcstr,$i+1,1); |
123 |
$disone =~ tr/0123456789/ABCDEFGHIJ/; |
124 |
$disone= lc ($disone) if( @ABTAB[$precod*6 + $i]==1); |
125 |
$eastring .=$disone; |
126 |
}$eastring .= "-"; |
127 |
# digits 8--13 |
128 |
for($i=0;$i<6;$i++){ |
129 |
# if checksum misses, do your own |
130 |
if(($i==5) && (length($srcstr)==12)){ |
131 |
for($j=0,$checksum=0;$j<12;$j++){ |
132 |
$checksum+=substr($srcstr,$j,1)*(1+($j&1)*2); |
133 |
}; |
134 |
$checksum%=10; |
135 |
$checksum=10-$checksum; |
136 |
$checksum%=10; |
137 |
$disone="$checksum"; |
138 |
}else { |
139 |
$disone=substr($srcstr,$i+7,1); |
140 |
} |
141 |
$disone =~ tr/0123456789/KLMNOPQRST/; |
142 |
$eastring .=$disone; |
143 |
}$eastring .="+"; |
144 |
return $eastring; |
145 |
} |
146 |
|
147 |
################################################## |
148 |
# here starts the code 128 stuff |
149 |
# |
150 |
################################################## |
151 |
# get the numerical value of a hex character, |
152 |
# e.g. 65 from 41 |
153 |
# |
154 |
sub hexchar{ |
155 |
my $src=shift; |
156 |
my ($i, $j, $result); |
157 |
$src =~ tr/a-f/A-F/; |
158 |
$i=ord(substr($src,0,1)); |
159 |
$j=ord(substr($src,1,1)); |
160 |
if($i >= ord("A")){ |
161 |
$i += (10-ord('A')); |
162 |
}else{ |
163 |
$i -= ord("0"); |
164 |
} |
165 |
if($j >= ord("A")){ |
166 |
$j += (10-ord("A")); |
167 |
}else{ |
168 |
$j -= ord("0"); |
169 |
} |
170 |
$result=16*($i)+$j; |
171 |
return $result; |
172 |
} |
173 |
|
174 |
# globals: |
175 |
# @cxxchars holds the characters the user wants to code |
176 |
# @ctbl holds the possible codings for these chars |
177 |
# @cxxout holds the codes to be output for code 128 |
178 |
|
179 |
################################################## |
180 |
# build up the switching table for code 128 |
181 |
|
182 |
sub makectbl{ |
183 |
# locals |
184 |
my $i; |
185 |
for($i=0;$i < $cxxlength; $i++){ |
186 |
if(($cxxchars[$i] >= ord("0"))&&($cxxchars[$i] <= ord("9"))){ |
187 |
# digits |
188 |
$ctbl[$i]=7; |
189 |
}elsif(($cxxchars[$i] >= ord(" "))&&($cxxchars[$i] <= ord("_"))){ |
190 |
# common Chars |
191 |
$ctbl[$i]=3; |
192 |
}elsif($cxxchars[$i] < ord(" ")){ |
193 |
# ascii control chars |
194 |
$ctbl[$i]=1; |
195 |
}elsif(($cxxchars[$i] >=ord("`"))&&($cxxchars[$i] <= ord("\x7f"))){ |
196 |
# lowercase |
197 |
$ctbl[$i]=2; |
198 |
if($cxxchars[$i] == ord("}")){ |
199 |
print "Encountered right brace in argument to cxxviii\n"; |
200 |
} |
201 |
}else{ # Function Codes |
202 |
$ctbl[$i] =7; |
203 |
} |
204 |
} |
205 |
$ctbl[$i]=0; |
206 |
} |
207 |
|
208 |
################################################## |
209 |
# make a character array from a string |
210 |
# looking like aBc\x41def^^41 or so. |
211 |
# |
212 |
sub unhex{ |
213 |
my ($i, $j, $b); |
214 |
my $srcstr=shift; |
215 |
$j=0; |
216 |
for($i=0;($b=ord(substr($srcstr,$i,1))) > 0;$i++){ |
217 |
if($b == ord("\\")){ |
218 |
if(substr($srcstr,$i+1,1) =~ /[xX]/){ # hex input |
219 |
$cxxchars[$j] = hexchar(substr($srcstr,$i+2,2)); |
220 |
$i += 3; |
221 |
}else{ |
222 |
$cxxchars[$j] = ord("\\"); |
223 |
} |
224 |
}elsif($b == ord("^")){ |
225 |
if(ord(substr($srcstr,$i+1,1)) == ord("^")){ # hex input |
226 |
$cxxchars[$j] = hexchar(substr($srcstr,$i+2,2)); |
227 |
$i += 3; |
228 |
}else{ |
229 |
$cxxchars[$j] = ord("^"); |
230 |
} |
231 |
}else{ |
232 |
$cxxchars[$j] = $b; |
233 |
} |
234 |
$j++; |
235 |
} |
236 |
return $j; |
237 |
} |
238 |
|
239 |
################################################## |
240 |
# write out a chunk of code 128 in hex symbols |
241 |
# |
242 |
sub cxxchunk{ |
243 |
my $j=shift; |
244 |
my ($i, $sum, $k); |
245 |
$sum=7; |
246 |
for($i=0;$sum & $ctbl[$j+$i]; $i++){ |
247 |
$sum &= $ctbl[$j+$i]; |
248 |
} |
249 |
if($sum==1){ |
250 |
$cxxout[$j]=101; |
251 |
}else{ |
252 |
$cxxout[$j]=100; |
253 |
} |
254 |
for($k=0;$k<$i;$k++){ |
255 |
if(($sum==1)&&($cxxchars[$j+$k] < ord(" "))){ |
256 |
$cxxout[$j+$k+1]=$cxxchars[$j+$k] + 64; |
257 |
}else{ |
258 |
$cxxout[$j+$k+1]=$cxxchars[$j+$k] - ord(" "); |
259 |
} |
260 |
} |
261 |
$k++; |
262 |
return $k; |
263 |
} |
264 |
|
265 |
################################################## |
266 |
# consecutive digits may perhaps be efficiently |
267 |
# coded with charset C |
268 |
# |
269 |
sub pastedigits{ |
270 |
my $digitcount=shift; |
271 |
my $j=shift; |
272 |
my $firstdigit=shift; |
273 |
my $lastset=shift; |
274 |
my $k; |
275 |
if($digitcount==0){ |
276 |
return $j; |
277 |
} # else: we've found consecutive digits |
278 |
elsif($digitcount<4){ |
279 |
# but unfortunately not enough digits. |
280 |
for($k=0;$k<$digitcount;$k++){ |
281 |
$cxxoutout[$j] = $cxxout[$firstdigit+$k]; |
282 |
$j++; |
283 |
} |
284 |
return $j; |
285 |
}else{ |
286 |
# is there an odd number of digits? |
287 |
if(($digitcount & 1)==1){ |
288 |
$cxxoutout[$j] = $cxxout[$firstdigit]; |
289 |
$firstdigit++; |
290 |
$digitcount--; |
291 |
$j++; |
292 |
}elsif(($cxxout[$j-1]>=99)&&($cxxout[$j-1]<=101)){ |
293 |
# Switched immediately before digits. |
294 |
# so overwrite the switch |
295 |
$j--; |
296 |
} |
297 |
$cxxoutout[$j] = 99; # switch to set C |
298 |
$j++; |
299 |
# copy digits in compressed format |
300 |
for($k=0;$k<$digitcount;$k+=2){ |
301 |
$cxxoutout[$j] = ($cxxout[$firstdigit+$k]-16)*10 |
302 |
+$cxxout[$firstdigit+$k+1]-16; |
303 |
$j++; |
304 |
} |
305 |
# reset char set, if you have to |
306 |
if($lastset != 0){ |
307 |
$cxxoutout[$j] = $lastset; |
308 |
$j++; |
309 |
} |
310 |
} |
311 |
return $j; |
312 |
} |
313 |
|
314 |
sub digitoptimize{ |
315 |
# change to charset C if there are at least four numbers in a row. |
316 |
# copy to @cxxoutout |
317 |
my ($lastset, $firstdigit, $digitcount, $i,$j,$k); |
318 |
$firstdigit=0; |
319 |
$digitcount=0; |
320 |
zch: |
321 |
for($i=0, $j=0; $i < $cxxlength; $i++){ |
322 |
if(($cxxout[$i]>=16)&&($cxxout[$i]<=25)){ |
323 |
# it's a number |
324 |
if($digitcount == 0){ |
325 |
$firstdigit=$i; |
326 |
} |
327 |
$digitcount++; |
328 |
next zch; |
329 |
} |
330 |
$j=pastedigits($digitcount,$j,$firstdigit,$lastset); |
331 |
$digitcount=0; |
332 |
$cxxoutout[$j] = $cxxout[$i]; |
333 |
$j++; |
334 |
if(($cxxout[$i]>=99)&&($cxxout[$i]<=101)){ |
335 |
# it's a code switch |
336 |
$lastset=$cxxout[$i]; |
337 |
} |
338 |
} |
339 |
$j=pastedigits($digitcount,$j,$firstdigit, 0); |
340 |
return $j; |
341 |
} |
342 |
|
343 |
################################################## |
344 |
# code 128 is a little complicated |
345 |
# if you read till here, you already know. |
346 |
# |
347 |
sub codcxxviii{ |
348 |
# locals |
349 |
my ($i,$j,$sum); |
350 |
my $srcstr=shift; |
351 |
# reset all arrays |
352 |
$cxxlength=0; |
353 |
# first step: unhexing |
354 |
$cxxlength = unhex($srcstr); |
355 |
# @cxxchars now holds the characters the user wants |
356 |
makectbl(); |
357 |
# @ctbl now contains the possible tables for the chars in $j; |
358 |
for($i =0; $i < $cxxlength;){ |
359 |
$i += cxxchunk($i); |
360 |
} |
361 |
# change codeset switch to start |
362 |
$cxxlength=$i; |
363 |
$j=digitoptimize(); |
364 |
if($cxxoutout[0]==99){ |
365 |
$cxxoutout[0]=105; |
366 |
}elsif($cxxoutout[0]==100){ |
367 |
$cxxoutout[0]=104; |
368 |
}else{ |
369 |
$cxxoutout[0]=103; |
370 |
} |
371 |
# calculate checksum and build output string |
372 |
for($i=1,$sum=$cxxoutout[0];$i<$j;$i++){ |
373 |
$sum+=$cxxoutout[$i]*$i; |
374 |
} |
375 |
$sum %=103; |
376 |
$cxxoutout[$j]=$sum; |
377 |
$j++; |
378 |
$cxxoutout[$j]=106; #stop sign |
379 |
$srcstr=""; |
380 |
for($i=0;$i<($j+1);$i++){ |
381 |
$srcstr .= sprintf "%02X", $cxxoutout[$i]; |
382 |
} |
383 |
$srcstr .= "@@"; |
384 |
return $srcstr; |
385 |
} |
386 |
################################################## |
387 |
# do code 93 -- it's easy |
388 |
################################################## |
389 |
sub codxciii{ |
390 |
my $srcstr=shift; |
391 |
my $cstbl='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%()[]'; |
392 |
my ($i, $j, $sumc, $sumh); |
393 |
$sumc=$sumh=0; |
394 |
for ($i=0;$i<length($srcstr);$i++){ |
395 |
$j=index($cstbl, substr($srcstr,$i,1),0); |
396 |
# $j is the check value of the character. |
397 |
$sumh=$sumh+$j; |
398 |
$sumc=$sumc+$sumh; |
399 |
} |
400 |
$srcstr=$srcstr . substr($cstbl,$sumc%47,1); |
401 |
$sumc=$sumc+$sumh+($sumc%47); |
402 |
$srcstr=$srcstr . substr($cstbl,$sumc%47,1); |
403 |
return $srcstr; |
404 |
} |
405 |
|
406 |
################################################## |
407 |
# we got both input and output file, |
408 |
# we defined all subroutines, |
409 |
# so here we go... |
410 |
# |
411 |
open(EINGABE, $ifname) or die "No file"; |
412 |
open(AUSGABE, $ofname) or die "Can't open output file"; |
413 |
while($line=<EINGABE>){ |
414 |
if($line =~ /^\\embed{(\d+)\}/){ |
415 |
$embedded=$1; |
416 |
print AUSGABE "$line"; |
417 |
}elsif($line =~ /^\\eean\{(\d+)\}(.*)/){ |
418 |
# embedded EAN |
419 |
$embtmp=substr($embedded,0,12-length($1)); |
420 |
$mycod=$embtmp . $1; |
421 |
$eastring=eancod($mycod); |
422 |
print AUSGABE "\\EAN{$eastring}$2 % embedded($1)\n"; |
423 |
}elsif ($line =~ /^\\ean\{(\d+)\}(.*)/){ |
424 |
# normal ean |
425 |
$eastring=eancod($1); |
426 |
print AUSGABE "\\EAN{$eastring}$2 %($1)\n"; |
427 |
}elsif($line =~ /^\\isbn\{([\dxX]+)\}(.*)/){ |
428 |
# isbn to be embedded |
429 |
$embtmp=substr($1,0,9); |
430 |
$mycod='978' . $embtmp; |
431 |
$eastring=eancod($mycod); |
432 |
print AUSGABE "\\EAN{$eastring}$2 % ISBN($1)\n"; |
433 |
}elsif($line =~ /^\\cxxviii\{(.+)\}(.*)/){ |
434 |
# code 128 |
435 |
$eastring=codcxxviii($1); |
436 |
print AUSGABE "\\CXXVIII $eastring $2 % Code128($1)\n"; |
437 |
}elsif($line =~ /^\\xciii\{(.+)\}(.*)/){ |
438 |
# code 93 |
439 |
$eastring=codxciii($1); |
440 |
print AUSGABE "\\XCIII{$eastring}$2 % Code93($1)\n"; |
441 |
}else { |
442 |
print AUSGABE $line |
443 |
}; |
444 |
} |
445 |
|
446 |
################################################## |
447 |
# we're done, so we do some cleanup and quit. |
448 |
close (EINGABE); |
449 |
close (AUSGABE); |
450 |
print "Done.\n"; |
451 |
|
452 |
################################################## |
453 |
# what we do here is called |
454 |
# 'falling off the edge of the world' |
455 |
# in the camel book. |
456 |
################################################## |