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