src/charconv.tcl

   1 #!/bin/sh
   2 # the next line restats using tclsh \
   3 exec tclsh "$0" "$@"
   4 #
   5 # $Id: charconv.tcl,v 1.4 2004-03-16 13:13:34 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;
  21             $totype to;
  22         };
  23         struct yaz_iconv_trie_dir {
  24             struct yaz_iconv_trie *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 *t, unsigned char *inp,
  35                                     size_t inbytesleft, size_t *no_read)
  36         {
  37             if (!t || inbytesleft < 1)
  38             return 0;
  39             if (t->dir)
  40             {
  41                 size_t ch = inp[0] & 0xff;
  42                 unsigned long code =
  43                 lookup(t->dir[ch].ptr, inp+1, inbytesleft-1, no_read);
  44                 if (code)
  45                 {
  46                     (*no_read)++;
  47                     return code;
  48                 }
  49                 if (t->dir[ch].to)
  50                 {
  51                     code = t->dir[ch].to;
  52                     *no_read = 1;
  53                     return code;
  54                 }
  55             }
  56             else
  57             {
  58                 struct yaz_iconv_trie_flat *flat = t->flat;
  59                 while (flat->from)
  60                 {
  61                     size_t len = strlen(flat->from);
  62                     if (len <= inbytesleft)
  63                     {
  64                         if (memcmp(flat->from, inp, len) == 0)
  65                         {
  66                             *no_read = len;
  67                             return flat->to;
  68                         }
  69                     }
  70                     flat++;
  71                 }
  72             }
  73             return 0;
  74         }
  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) 40
  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, 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(prefix)page$trie($this,ptr,$ch), "
 193                     set null 0
 194                 } else {
 195                     puts -nonewline $f "0, "
 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     puts $f "unsigned long yaz_$trie(prefix)_conv
 219             (unsigned char *inp, size_t inbytesleft, size_t *no_read)
 220         {
 221             unsigned long code;
 222
 223             code = lookup(&$trie(prefix)page0, inp, inbytesleft, no_read);
 224             if (!code)
 225             {
 226                 *no_read = 1;
 227                 code = *inp;
 228             }
 229             return code;
 230         }
 231     "
 232 }
 233
 234 proc readfile {fname ofilehandle prefix omits} {
 235     global trie
 236
 237     set marc_lines 0
 238     set ucs_lines 0
 239     set lineno 0
 240     set f [open $fname r]
 241     set tablenumber x
 242     while {1} {
 243         incr lineno
 244         set cnt [gets $f line]
 245         if {$cnt < 0} {
 246             break
 247         }
 248         if {[regexp {<entitymap>} $line s]} {
 249             reset_trie
 250             set trie(prefix) "${prefix}"
 251         } elseif {[regexp {</entitymap>} $line s]} {
 252             dump_trie $ofilehandle
 253         } elseif {[regexp {<character hex="([^\"]*)".*<unientity>([0-9A-Fa-f]*)</unientity>} $line s hex ucs]} {
 254             ins_trie $hex $ucs
 255             unset hex
 256         } elseif {[regexp {<codeTable number="([0-9]+)"} $line s tablenumber]} {
 257             reset_trie
 258             set trie(prefix) "${prefix}_$tablenumber"
 259         } elseif {[regexp {</codeTable>} $line s]} {
 260             if {[lsearch $omits $tablenumber] == -1} {
 261                 dump_trie $ofilehandle
 262             }
 263         } elseif {[regexp {</code>} $line s]} {
 264             if {[string length $ucs]} {
 265                 for {set i 0} {$i < [string length $marc]} {incr i 2} {
 266                     lappend hex [string range $marc $i [expr $i+1]]
 267                 }
 268                 # puts "ins_trie $hex $ucs"
 269                 ins_trie $hex $ucs
 270                 unset hex
 271             }
 272             set marc {}
 273             set uni {}
 274         } elseif {[regexp {<marc>([0-9A-Fa-f]*)</marc>} $line s marc]} {
 275             incr marc_lines
 276         } elseif {[regexp {<ucs>([0-9A-Fa-f]*)</ucs>} $line s ucs]} {
 277             incr ucs_lines
 278         }
 279     }
 280     close $f
 281 }
 282
 283 set verbose 0
 284 set ifile {}
 285 set ofile out.c
 286 set trie(split) 40
 287 set prefix {c}
 288 # Parse command line
 289 set l [llength $argv]
 290 set i 0
 291 set omits {}
 292 while {$i < $l} {
 293     set arg [lindex $argv $i]
 294     switch -glob -- $arg {
 295         -v {
 296             incr verbose
 297         }
 298         -s {
 299             if {[string length $arg]} {
 300                 set arg [lindex $argv [incr i]]
 301             }
 302             set trie(split) $arg
 303         }
 304         -p {
 305             if {[string length $arg]} {
 306                 set arg [lindex $argv [incr i]]
 307             }
 308             set prefix $arg
 309         }
 310         -o {
 311             if {[string length $arg]} {
 312                 set arg [lindex $argv [incr i]]
 313             }
 314             set ofile $arg
 315         }
 316         -O {
 317             if {[string length $arg]} {
 318                 set arg [lindex $argv [incr i]]
 319             }
 320             lappend omits $arg
 321         }
 322         default {
 323             lappend ifiles $arg
 324         }
 325     }
 326     incr i
 327 }
 328 if {![info exists ifiles]} {
 329     puts "charconv.tcl: missing input file(s)"
 330     usage
 331 }
 332
 333 set ofilehandle [open $ofile w]
 334 preamble_trie $ofilehandle
 335
 336 foreach ifile $ifiles {
 337     readfile $ifile $ofilehandle $prefix $omits
 338 }
 339 close $ofilehandle
 340
 341