Use "" instead of 0 for last field 'from'. And test for end of list
[yaz-moved-to-github.git] / src / charconv.tcl
1 #!/bin/sh
2 # the next line restats using tclsh \
3 exec tclsh "$0" "$@"
4 #
5 # $Id: charconv.tcl,v 1.6 2004-03-20 07:16:25 adam Exp $
6
7 proc usage {} {
8     puts {charconv.tcl: [-p prefix] [-s split] [-o ofile] file ... }
9     exit 1
10 }
11
12 proc preamble_trie {ofilehandle} {
13     set f $ofilehandle
14
15     set totype {unsigned short}
16
17     puts $f "\#include <string.h>"
18     puts $f "
19         struct yaz_iconv_trie_flat {
20             char from\[6\];
21             $totype to;
22         };
23         struct yaz_iconv_trie_dir {
24             short ptr;
25             $totype to;
26         };
27         
28         struct yaz_iconv_trie {
29             struct yaz_iconv_trie_flat *flat;
30             struct yaz_iconv_trie_dir *dir;
31         };
32     "
33     puts $f {
34         static unsigned long lookup(struct yaz_iconv_trie **ptrs, int ptr, unsigned char *inp,
35                                     size_t inbytesleft, size_t *no_read)
36         {
37             struct yaz_iconv_trie *t = (ptr >= 0) ? ptrs[ptr] : 0;
38             if (!t || inbytesleft < 1)
39                 return 0;
40             if (t->dir)
41             {
42                 size_t ch = inp[0] & 0xff;
43                 unsigned long code =
44                 lookup(ptrs, t->dir[ch].ptr, inp+1, inbytesleft-1, no_read);
45                 if (code)
46                 {
47                     (*no_read)++;
48                     return code;
49                 }
50                 if (t->dir[ch].to)
51                 {
52                     code = t->dir[ch].to;
53                     *no_read = 1;
54                     return code;
55                 }
56             }
57             else
58             {
59                 struct yaz_iconv_trie_flat *flat = t->flat;
60                 while (flat->to)
61                 {
62                     size_t len = strlen(flat->from);
63                     if (len <= inbytesleft)
64                     {
65                         if (memcmp(flat->from, inp, len) == 0)
66                         {
67                             *no_read = len;
68                             return flat->to;
69                         }
70                     }
71                     flat++;
72                 }
73             }
74             return 0;
75         }
76     }
77 }
78
79 proc reset_trie {} {
80     global trie
81
82     foreach x [array names trie] {
83         unset trie($x)
84     }
85
86     set trie(no) 1
87     set trie(size) 0
88     set trie(max) 0
89     set trie(split) 50
90     set trie(prefix) {}
91 }
92
93 proc ins_trie {from to} {
94     global trie
95     if {![info exists trie(no)]} {
96         set trie(no) 1
97         set trie(size) 0
98         set trie(max) 0
99     }
100     if {$trie(max) < $to} {
101         set trie(max) $to
102     }
103     incr trie(size)
104     ins_trie_r [split $from] $to 0
105 }
106
107 proc split_trie {this} {
108     global trie
109     set trie($this,type) d
110     foreach e $trie($this,content) {
111         set from [lindex $e 0]
112         set to [lindex $e 1]
113         
114         set ch [lindex $from 0]
115         set rest [lrange $from 1 end]
116         
117         if {[llength $rest]} {
118             if {![info exist trie($this,ptr,$ch)]} {
119                 set trie($this,ptr,$ch) $trie(no)
120                 incr trie(no)
121             }
122             ins_trie_r $rest $to $trie($this,ptr,$ch)
123         } else {
124             set trie($this,to,$ch) $to
125         }
126     }
127     set trie($this,content) missing
128 }
129
130 proc ins_trie_r {from to this} {
131     global trie
132
133     if {![info exist trie($this,type)]} {
134         set trie($this,type) f
135     }
136     if {$trie($this,type) == "f"} {
137         lappend trie($this,content) [list $from $to]
138         
139         # split ?
140         if {[llength $trie($this,content)] > $trie(split)} {
141             split_trie $this
142             return [ins_trie_r $from $to $this]
143         }
144     } else {
145         set ch [lindex $from 0]
146         set rest [lrange $from 1 end]
147
148         if {[llength $rest]} {
149             if {![info exist trie($this,ptr,$ch)]} {
150                 set trie($this,ptr,$ch) $trie(no)
151                 incr trie(no)
152             }
153             ins_trie_r $rest $to $trie($this,ptr,$ch)
154         } else {
155             set trie($this,to,$ch) $to
156         }
157     }
158 }
159
160 proc dump_trie {ofilehandle} {
161     global trie
162
163     set f $ofilehandle
164
165     puts $f "/* TRIE: size $trie(size) */"
166
167     set this $trie(no)
168     while { [incr this -1] >= 0 } {
169         puts $f "/* PAGE $this */"
170         if {$trie($this,type) == "f"} {
171             puts $f "struct yaz_iconv_trie_flat $trie(prefix)page${this}_flat\[\] = \{"
172             foreach m $trie($this,content) {
173                 puts -nonewline $f "  \{\""
174                 foreach d [lindex $m 0] {
175                     puts -nonewline $f "\\x$d"
176                 }
177                 puts -nonewline $f "\", 0x[lindex $m 1]"
178                 puts $f "\},"
179             }
180             puts $f "  \{\"\", 0\}"
181             puts $f "\};"
182             puts $f "struct yaz_iconv_trie $trie(prefix)page${this} = \{"
183             puts $f "  $trie(prefix)page${this}_flat, 0"
184             puts $f "\};"
185         } else {
186             puts $f "struct yaz_iconv_trie_dir $trie(prefix)page${this}_dir\[256\] = \{"
187             for {set i 0} {$i < 256} {incr i} {
188                 puts -nonewline $f "  \{"
189                 set ch [format %02X $i]
190                 set null 1
191                 if {[info exist trie($this,ptr,$ch)]} {
192                     puts -nonewline $f "$trie($this,ptr,$ch), "
193                     set null 0
194                 } else {
195                     puts -nonewline $f "-1, "
196                 }
197                 if {[info exist trie($this,to,$ch)]} {
198                     puts -nonewline $f "0x$trie($this,to,$ch)\}"
199                     set null 0
200                 } else {
201                     puts -nonewline $f "0\}"
202                 }
203                 if {!$null} {
204                     puts -nonewline $f " /* $ch */"
205                 }
206                 if {$i < 255} {
207                     puts $f ","
208                 } else {
209                     puts $f ""
210                 }
211             }
212             puts $f "\};"
213             puts $f "struct yaz_iconv_trie $trie(prefix)page${this} = \{"
214             puts $f "  0, $trie(prefix)page${this}_dir"
215             puts $f "\};"
216         }
217     }
218
219     puts $f "struct yaz_iconv_trie *$trie(prefix)ptrs \[\] = {"
220     for {set this 0} {$this < $trie(no)} {incr this} {
221         puts $f " &$trie(prefix)page$this,"
222     }
223     puts $f "0, };"
224     puts $f ""
225
226     puts $f "unsigned long yaz_$trie(prefix)_conv
227             (unsigned char *inp, size_t inbytesleft, size_t *no_read)
228         {
229             unsigned long code;
230             
231             code = lookup($trie(prefix)ptrs, 0, inp, inbytesleft, no_read);
232             if (!code)
233             {
234                 *no_read = 1;
235                 code = *inp;
236             }
237             return code;
238         }
239     "
240 }
241
242 proc readfile {fname ofilehandle prefix omits} {
243     global trie
244
245     set marc_lines 0
246     set ucs_lines 0
247     set lineno 0
248     set f [open $fname r]
249     set tablenumber x
250     while {1} {
251         incr lineno
252         set cnt [gets $f line]
253         if {$cnt < 0} {
254             break
255         }
256         if {[regexp {<entitymap>} $line s]} {
257             reset_trie
258             set trie(prefix) "${prefix}"
259         } elseif {[regexp {</entitymap>} $line s]} {
260             dump_trie $ofilehandle
261         } elseif {[regexp {<character hex="([^\"]*)".*<unientity>([0-9A-Fa-f]*)</unientity>} $line s hex ucs]} {
262             ins_trie $hex $ucs
263             unset hex
264         } elseif {[regexp {<codeTable number="([0-9]+)"} $line s tablenumber]} {
265             reset_trie
266             set trie(prefix) "${prefix}_$tablenumber"
267         } elseif {[regexp {</codeTable>} $line s]} {
268             if {[lsearch $omits $tablenumber] == -1} {
269                 dump_trie $ofilehandle
270             }
271         } elseif {[regexp {</code>} $line s]} {
272             if {[string length $ucs]} {
273                 for {set i 0} {$i < [string length $marc]} {incr i 2} {
274                     lappend hex [string range $marc $i [expr $i+1]]
275                 }
276                 # puts "ins_trie $hex $ucs"
277                 ins_trie $hex $ucs
278                 unset hex
279             }
280             set marc {}
281             set uni {}
282         } elseif {[regexp {<marc>([0-9A-Fa-f]*)</marc>} $line s marc]} {
283             incr marc_lines
284         } elseif {[regexp {<ucs>([0-9A-Fa-f]*)</ucs>} $line s ucs]} {
285             incr ucs_lines
286         }
287     }
288     close $f
289 }
290
291 set verbose 0
292 set ifile {}
293 set ofile out.c
294 set prefix {c}
295 # Parse command line
296 set l [llength $argv]
297 set i 0
298 set omits {}
299 while {$i < $l} {
300     set arg [lindex $argv $i]
301     switch -glob -- $arg {
302         -v {
303             incr verbose
304         }
305         -s {
306             if {[string length $arg]} {
307                 set arg [lindex $argv [incr i]]
308             }
309             set trie(split) $arg
310         }
311         -p {
312             if {[string length $arg]} {
313                 set arg [lindex $argv [incr i]]
314             }
315             set prefix $arg
316         }
317         -o {
318             if {[string length $arg]} {
319                 set arg [lindex $argv [incr i]]
320             }
321             set ofile $arg
322         }
323         -O {
324             if {[string length $arg]} {
325                 set arg [lindex $argv [incr i]]
326             }
327             lappend omits $arg
328         }
329         default {
330             lappend ifiles $arg
331         }
332     }
333     incr i
334 }
335 if {![info exists ifiles]} {
336     puts "charconv.tcl: missing input file(s)"
337     usage
338 }
339
340 set ofilehandle [open $ofile w]
341 preamble_trie $ofilehandle
342
343 foreach ifile $ifiles {
344     readfile $ifile $ofilehandle $prefix $omits
345 }
346 close $ofilehandle
347
348