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