/[informatika.old]/print/codean.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /print/codean.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed Apr 12 08:10:24 2000 UTC (22 years, 9 months ago) by dpavlin
Branch: MAIN
CVS Tags: HEAD
File MIME type: text/plain
alati za ispis izvještaja

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 ##################################################

  ViewVC Help
Powered by ViewVC 1.1.26