src/charconv.tcl

   1 #!/bin/sh
   2 # the next line restats using tclsh \
   3 exec tclsh "$0" "$@"
   4 #
   5 # $Id: charconv.tcl,v 1.1 2003-10-27 12:21:30 adam Exp $
   6
   7 proc usage {} {
   8     puts {charconv.tcl: [-p prefix] [-s split] [-o ofile] file ... }
   9     exit 1
  10 }
  11
  12 proc ins_trie {from to} {
  13     global trie
  14     if {![info exists trie(no)]} {
  15         set trie(no) 1
  16         set trie(size) 0
  17     }
  18     incr trie(size)
  19     ins_trie_r [split $from] $to 0
  20 }
  21
  22 proc split_trie {this} {
  23     global trie
  24     set trie($this,type) d
  25     foreach e $trie($this,content) {
  26         set from [lindex $e 0]
  27         set to [lindex $e 1]
  28
  29         set ch [lindex $from 0]
  30         set rest [lrange $from 1 end]
  31
  32         if {[llength $rest]} {
  33             if {![info exist trie($this,ptr,$ch)]} {
  34                 set trie($this,ptr,$ch) $trie(no)
  35                 incr trie(no)
  36             }
  37             ins_trie_r $rest $to $trie($this,ptr,$ch)
  38         } else {
  39             set trie($this,to,$ch) $to
  40         }
  41     }
  42     set trie($this,content) missing
  43 }
  44
  45 proc ins_trie_r {from to this} {
  46     global trie
  47
  48     if {![info exist trie($this,type)]} {
  49         set trie($this,type) f
  50     }
  51     if {$trie($this,type) == "f"} {
  52         lappend trie($this,content) [list $from $to]
  53
  54         # split ?
  55         if {[llength $trie($this,content)] > $trie(split)} {
  56             split_trie $this
  57             return [ins_trie_r $from $to $this]
  58         }
  59     } else {
  60         set ch [lindex $from 0]
  61         set rest [lrange $from 1 end]
  62
  63         if {[llength $rest]} {
  64             if {![info exist trie($this,ptr,$ch)]} {
  65                 set trie($this,ptr,$ch) $trie(no)
  66                 incr trie(no)
  67             }
  68             ins_trie_r $rest $to $trie($this,ptr,$ch)
  69         } else {
  70             set trie($this,to,$ch) $to
  71         }
  72     }
  73 }
  74
  75 proc dump_trie {ofile} {
  76     global trie
  77
  78     set f [open $ofile w]
  79
  80     puts $f "/* TRIE: size $trie(size) */"
  81     puts $f "\#include <string.h>"
  82     puts $f {
  83         struct yaz_iconv_trie_flat {
  84             char *from;
  85             int to;
  86         };
  87         struct yaz_iconv_trie_dir {
  88             struct yaz_iconv_trie *ptr;
  89             int to;
  90         };
  91
  92         struct yaz_iconv_trie {
  93             struct yaz_iconv_trie_flat *flat;
  94             struct yaz_iconv_trie_dir *dir;
  95         };
  96     }
  97
  98     set this $trie(no)
  99     while { [incr this -1] >= 0 } {
 100         puts $f "/* PAGE $this */"
 101         if {$trie($this,type) == "f"} {
 102             puts $f "struct yaz_iconv_trie_flat $trie(prefix)page${this}_flat\[\] = \{"
 103             foreach m $trie($this,content) {
 104                 puts -nonewline $f "  \{\""
 105                 foreach d [lindex $m 0] {
 106                     puts -nonewline $f "\\x$d"
 107                 }
 108                 puts -nonewline $f "\", 0x[lindex $m 1]"
 109                 puts $f "\},"
 110             }
 111             puts $f "  \{0, 0\}"
 112             puts $f "\};"
 113             puts $f "struct yaz_iconv_trie $trie(prefix)page${this} = \{"
 114             puts $f "  $trie(prefix)page${this}_flat, 0"
 115             puts $f "\};"
 116         } else {
 117             puts $f "struct yaz_iconv_trie_dir $trie(prefix)page${this}_dir\[256\] = \{"
 118             for {set i 0} {$i < 256} {incr i} {
 119                 puts -nonewline $f "  \{"
 120                 set ch [format %02X $i]
 121                 set null 1
 122                 if {[info exist trie($this,ptr,$ch)]} {
 123                     puts -nonewline $f "&$trie(prefix)page$trie($this,ptr,$ch), "
 124                     set null 0
 125                 } else {
 126                     puts -nonewline $f "0, "
 127                 }
 128                 if {[info exist trie($this,to,$ch)]} {
 129                     puts -nonewline $f "0x$trie($this,to,$ch)\}"
 130                     set null 0
 131                 } else {
 132                     puts -nonewline $f "0\}"
 133                 }
 134                 if {!$null} {
 135                     puts -nonewline $f " /* $ch */"
 136                 }
 137                 if {$i < 255} {
 138                     puts $f ","
 139                 } else {
 140                     puts $f ""
 141                 }
 142             }
 143             puts $f "\};"
 144             puts $f "struct yaz_iconv_trie $trie(prefix)page${this} = \{"
 145             puts $f "  0, $trie(prefix)page${this}_dir"
 146             puts $f "\};"
 147         }
 148     }
 149     puts $f {
 150         static unsigned long lookup(struct yaz_iconv_trie *t, unsigned char *inp,
 151                                     size_t inbytesleft, size_t *no_read)
 152         {
 153             if (!t || inbytesleft < 1)
 154             return 0;
 155             if (t->dir)
 156             {
 157                 size_t ch = inp[0] & 0xff;
 158                 unsigned long code =
 159                 lookup(t->dir[ch].ptr, inp+1, inbytesleft-1, no_read);
 160                 if (code)
 161                 {
 162                     (*no_read)++;
 163                     return code;
 164                 }
 165                 if (t->dir[ch].to)
 166                 {
 167                     code = t->dir[ch].to;
 168                     *no_read = 1;
 169                     return code;
 170                 }
 171             }
 172             else
 173             {
 174                 struct yaz_iconv_trie_flat *flat = t->flat;
 175                 while (flat->from)
 176                 {
 177                     size_t len = strlen(flat->from);
 178                     if (len <= inbytesleft)
 179                     {
 180                         if (memcmp(flat->from, inp, len) == 0)
 181                         {
 182                             *no_read = len;
 183                             return flat->to;
 184                         }
 185                     }
 186                     flat++;
 187                 }
 188             }
 189             return 0;
 190         }
 191
 192     }
 193     puts $f "unsigned long yaz_$trie(prefix)_conv
 194             (unsigned char *inp, size_t inbytesleft, size_t *no_read)
 195         {
 196             unsigned long code;
 197
 198             code = lookup(&$trie(prefix)page0, inp, inbytesleft, no_read);
 199             if (!code)
 200             {
 201                 *no_read = 1;
 202                 code = *inp;
 203             }
 204             return code;
 205         }
 206     "
 207     close $f
 208 }
 209
 210 proc readfile {fname} {
 211     set lineno 0
 212     set f [open $fname r]
 213     while {1} {
 214         incr lineno
 215         set cnt [gets $f line]
 216         if {$cnt < 0} {
 217             break
 218         }
 219         set hex {}
 220         set uni {}
 221         regexp {<character hex="([^\"]*)".*<unientity>([0-9A-Z]*)</unientity>} $line s hex uni
 222         # puts "$lineno hex=$hex uni=$uni $line"
 223         if {[string length $uni]} {
 224             ins_trie $hex $uni
 225         }
 226     }
 227     close $f
 228 }
 229
 230 set verbose 0
 231 set ifile {}
 232 set ofile out.c
 233 set trie(split) 40
 234 set trie(prefix) {}
 235 # Parse command line
 236 set l [llength $argv]
 237 set i 0
 238 while {$i < $l} {
 239     set arg [lindex $argv $i]
 240     switch -glob -- $arg {
 241         -v {
 242             incr verbose
 243         }
 244         -s {
 245             if {[string length $arg]} {
 246                 set arg [lindex $argv [incr i]]
 247             }
 248             set trie(split) $arg
 249         }
 250         -p {
 251             if {[string length $arg]} {
 252                 set arg [lindex $argv [incr i]]
 253             }
 254             set trie(prefix) $arg
 255         }
 256         -o {
 257             if {[string length $arg]} {
 258                 set arg [lindex $argv [incr i]]
 259             }
 260             set ofile $arg
 261         }
 262         default {
 263             lappend ifiles $arg
 264         }
 265     }
 266     incr i
 267 }
 268 if {![info exists ifiles]} {
 269     puts "charconv.tcl: missing input file(s)"
 270     usage
 271 }
 272 foreach ifile $ifiles {
 273     readfile $ifile
 274 }
 275 dump_trie $ofile