src/charconv.tcl

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