src/charconv.tcl

   1 #!/bin/sh
   2 # the next line restats using tclsh \
   3 exec tclsh "$0" "$@"
   4 #
   5 # $Id: charconv.tcl,v 1.3 2004-03-16 13:12:42 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             puts "new table $tablenumber"
 252         } elseif {[regexp {</entitymap>} $line s]} {
 253             dump_trie $ofilehandle
 254         } elseif {[regexp {<character hex="([^\"]*)".*<unientity>([0-9A-Fa-f]*)</unientity>} $line s hex ucs]} {
 255             ins_trie $hex $ucs
 256             unset hex
 257         } elseif {[regexp {<codeTable number="([0-9]+)"} $line s tablenumber]} {
 258             reset_trie
 259             set trie(prefix) "${prefix}_$tablenumber"
 260             puts "new table $tablenumber"
 261         } elseif {[regexp {</codeTable>} $line s]} {
 262             if {[lsearch $omits $tablenumber] == -1} {
 263                 dump_trie $ofilehandle
 264             }
 265         } elseif {[regexp {</code>} $line s]} {
 266             if {[string length $ucs]} {
 267                 for {set i 0} {$i < [string length $marc]} {incr i 2} {
 268                     lappend hex [string range $marc $i [expr $i+1]]
 269                 }
 270                 # puts "ins_trie $hex $ucs"
 271                 ins_trie $hex $ucs
 272                 unset hex
 273             }
 274             set marc {}
 275             set uni {}
 276         } elseif {[regexp {<marc>([0-9A-Fa-f]*)</marc>} $line s marc]} {
 277             incr marc_lines
 278         } elseif {[regexp {<ucs>([0-9A-Fa-f]*)</ucs>} $line s ucs]} {
 279             incr ucs_lines
 280         }
 281     }
 282     close $f
 283 }
 284
 285 set verbose 0
 286 set ifile {}
 287 set ofile out.c
 288 set trie(split) 40
 289 set prefix {c}
 290 # Parse command line
 291 set l [llength $argv]
 292 set i 0
 293 set omits {}
 294 while {$i < $l} {
 295     set arg [lindex $argv $i]
 296     switch -glob -- $arg {
 297         -v {
 298             incr verbose
 299         }
 300         -s {
 301             if {[string length $arg]} {
 302                 set arg [lindex $argv [incr i]]
 303             }
 304             set trie(split) $arg
 305         }
 306         -p {
 307             if {[string length $arg]} {
 308                 set arg [lindex $argv [incr i]]
 309             }
 310             set prefix $arg
 311         }
 312         -o {
 313             if {[string length $arg]} {
 314                 set arg [lindex $argv [incr i]]
 315             }
 316             set ofile $arg
 317         }
 318         -O {
 319             if {[string length $arg]} {
 320                 set arg [lindex $argv [incr i]]
 321             }
 322             lappend omits $arg
 323         }
 324         default {
 325             lappend ifiles $arg
 326         }
 327     }
 328     incr i
 329 }
 330 if {![info exists ifiles]} {
 331     puts "charconv.tcl: missing input file(s)"
 332     usage
 333 }
 334
 335 set ofilehandle [open $ofile w]
 336 preamble_trie $ofilehandle
 337
 338 foreach ifile $ifiles {
 339     readfile $ifile $ofilehandle $prefix $omits
 340 }
 341 close $ofilehandle
 342
 343