src/charconv.tcl

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