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.18 2006-12-17 15:34:11 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         lappend trie($this,content) [list $from $to $combining $codename]
 151
 152         # split ?
 153         if {[llength $trie($this,content)] > $trie(split)} {
 154             split_trie $this
 155             return [ins_trie_r $from $to $combining $codename $this]
 156         }
 157     } else {
 158         set ch [lindex $from 0]
 159         set rest [lrange $from 1 end]
 160
 161         if {[llength $rest]} {
 162             if {![info exist trie($this,ptr,$ch)]} {
 163                 set trie($this,ptr,$ch) $trie(no)
 164                 incr trie(no)
 165             }
 166             ins_trie_r $rest $to $combining $codename $trie($this,ptr,$ch)
 167         } else {
 168             if {![info exist trie($this,to,$ch)]} {
 169                 set trie($this,to,$ch) $to
 170                 set trie($this,combining,$ch) $combining
 171                 set trie($this,codename,$ch) $codename
 172             }
 173         }
 174     }
 175 }
 176
 177 proc dump_trie {ofilehandle} {
 178     global trie
 179
 180     set f $ofilehandle
 181
 182     puts $f "/* TRIE: size $trie(size) */"
 183
 184     set this $trie(no)
 185     while { [incr this -1] >= 0 } {
 186         puts $f "/* PAGE $this */"
 187         if {$trie($this,type) == "f"} {
 188             puts $f "struct yaz_iconv_trie_flat $trie(prefix)page${this}_flat\[\] = \{"
 189             foreach m $trie($this,content) {
 190                 puts -nonewline $f "  \{\""
 191                 foreach d [lindex $m 0] {
 192                     puts -nonewline $f "\\x$d"
 193                 }
 194                 puts -nonewline $f "\", [lindex $m 2], 0x[lindex $m 1]"
 195                 set v [lindex $m 3]
 196                 puts $f "\}, /* $v */"
 197             }
 198             puts $f "  \{\"\", 0\}"
 199             puts $f "\};"
 200             puts $f "struct yaz_iconv_trie $trie(prefix)page${this} = \{"
 201             puts $f "  $trie(prefix)page${this}_flat, 0"
 202             puts $f "\};"
 203         } else {
 204             puts $f "struct yaz_iconv_trie_dir $trie(prefix)page${this}_dir\[256\] = \{"
 205             for {set i 0} {$i < 256} {incr i} {
 206                 puts -nonewline $f "  \{"
 207                 set ch [format %02X $i]
 208                 set null 1
 209                 if {[info exist trie($this,ptr,$ch)]} {
 210                     puts -nonewline $f "[expr $trie($this,ptr,$ch)+1], "
 211                     set null 0
 212                 } else {
 213                     puts -nonewline $f "0, "
 214                 }
 215                 if {[info exist trie($this,combining,$ch)]} {
 216                     puts -nonewline $f "$trie($this,combining,$ch), "
 217                 } else {
 218                     puts -nonewline $f "0, "
 219                 }
 220                 if {[info exist trie($this,to,$ch)]} {
 221                     puts -nonewline $f "0x$trie($this,to,$ch)\}"
 222                     set null 0
 223                 } else {
 224                     puts -nonewline $f "0\}"
 225                 }
 226                 if {[info exist trie($this,codename,$ch)]} {
 227                     set v $trie($this,codename,$ch)
 228                     puts -nonewline $f " /* $v */"
 229                 }
 230                 if {$i < 255} {
 231                     puts $f ","
 232                 } else {
 233                     puts $f ""
 234                 }
 235             }
 236             puts $f "\};"
 237             puts $f "struct yaz_iconv_trie $trie(prefix)page${this} = \{"
 238             puts $f "  0, $trie(prefix)page${this}_dir"
 239             puts $f "\};"
 240         }
 241     }
 242
 243     puts $f "struct yaz_iconv_trie *$trie(prefix)ptrs \[\] = {"
 244     for {set this 0} {$this < $trie(no)} {incr this} {
 245         puts $f " &$trie(prefix)page$this,"
 246     }
 247     puts $f "0, };"
 248     puts $f ""
 249
 250     puts $f "unsigned long yaz_$trie(prefix)_conv
 251             (unsigned char *inp, size_t inbytesleft, size_t *no_read, int *combining)
 252         {
 253             unsigned long code;
 254
 255             code = lookup($trie(prefix)ptrs, 1, inp, inbytesleft, no_read, combining);
 256             if (!code)
 257             {
 258                 *no_read = 1;
 259             }
 260             return code;
 261         }
 262     "
 263 }
 264
 265 proc readfile {fname ofilehandle prefix omits reverse} {
 266     global trie
 267
 268     set marc_lines 0
 269     set ucs_lines 0
 270     set utf_lines 0
 271     set altutf_lines 0
 272     set codename_lines 0
 273     set lineno 0
 274     set f [open $fname r]
 275     set tablenumber x
 276     set combining 0
 277     set codename {}
 278     set altutf {}
 279     while {1} {
 280         incr lineno
 281         set cnt [gets $f line]
 282         if {$cnt < 0} {
 283             break
 284         }
 285         if {[regexp {<entitymap>} $line s]} {
 286             reset_trie
 287             set trie(prefix) "${prefix}"
 288         } elseif {[regexp {</entitymap>} $line s]} {
 289             dump_trie $ofilehandle
 290         } elseif {[regexp {<character hex="([^\"]*)".*<unientity>([0-9A-Fa-f]*)</unientity>} $line s hex ucs]} {
 291             ins_trie $hex $ucs $combining {}
 292             unset hex
 293         } elseif {[regexp {<codeTable .*number="([0-9]+)"} $line s tablenumber]} {
 294             reset_trie
 295             set trie(prefix) "${prefix}_$tablenumber"
 296             set combining 0
 297         } elseif {[regexp {</codeTable>} $line s]} {
 298             if {[lsearch $omits $tablenumber] == -1} {
 299                 dump_trie $ofilehandle
 300             }
 301         } elseif {[regexp {</code>} $line s]} {
 302             if {[string length $ucs]} {
 303                 if {$reverse} {
 304                     for {set i 0} {$i < [string length $utf]} {incr i 2} {
 305                         lappend hex [string range $utf $i [expr $i+1]]
 306                     }
 307                     # puts "ins_trie $hex $marc
 308                     ins_trie $hex $marc $combining $codename
 309                     unset hex
 310
 311                 } else {
 312                     for {set i 0} {$i < [string length $marc]} {incr i 2} {
 313                         lappend hex [string range $marc $i [expr $i+1]]
 314                     }
 315                     # puts "ins_trie $hex $ucs"
 316                     ins_trie $hex $ucs $combining $codename
 317                     unset hex
 318                 }
 319             }
 320             if {$reverse && [string length $marc]} {
 321                 for {set i 0} {$i < [string length $altutf]} {incr i 2} {
 322                     lappend hex [string range $altutf $i [expr $i+1]]
 323                 }
 324                 if {[info exists hex]} {
 325                     ins_trie $hex $marc $combining $codename
 326                     unset hex
 327                 }
 328             }
 329             set marc {}
 330             set uni {}
 331             set codename {}
 332             set combining 0
 333             set altutf {}
 334         } elseif {[regexp {<marc>([0-9A-Fa-f]*)</marc>} $line s marc]} {
 335             incr marc_lines
 336         } elseif {[regexp {<name>(.*)</name>} $line s codename]} {
 337             incr codename_lines
 338         } elseif {[regexp {<name>(.*)} $line s codename]} {
 339             incr codename_lines
 340             incr lineno
 341             set cnt [gets $f line]
 342             if {$cnt < 0} {
 343                 break
 344             }
 345             if {[regexp {(.*)</name>} $line s codename_ex]} {
 346                 set codename "${codename} ${codename_ex}"
 347             }
 348         } elseif {[regexp {<isCombining>true</isCombining>} $line s]} {
 349             set combining 1
 350         } elseif {[regexp {<ucs>([0-9A-Fa-f]*)</ucs>} $line s ucs]} {
 351             incr ucs_lines
 352         } elseif {[regexp {<utf-8>([0-9A-Fa-f]*)</utf-8>} $line s utf]} {
 353             incr utf_lines
 354         } elseif {[regexp {<altutf-8>([0-9A-Fa-f]*)</altutf-8>} $line s altutf]} {
 355             incr altutf_lines
 356         }
 357     }
 358     close $f
 359 }
 360
 361 set verbose 0
 362 set ifile {}
 363 set ofile out.c
 364 set prefix {c}
 365 set reverse_map 0
 366 # Parse command line
 367 set l [llength $argv]
 368 set i 0
 369 set omits {}
 370 while {$i < $l} {
 371     set arg [lindex $argv $i]
 372     switch -glob -- $arg {
 373         -v {
 374             incr verbose
 375         }
 376         -s {
 377             if {[string length $arg]} {
 378                 set arg [lindex $argv [incr i]]
 379             }
 380             set trie(split) $arg
 381         }
 382         -p {
 383             if {[string length $arg]} {
 384                 set arg [lindex $argv [incr i]]
 385             }
 386             set prefix $arg
 387         }
 388         -o {
 389             if {[string length $arg]} {
 390                 set arg [lindex $argv [incr i]]
 391             }
 392             set ofile $arg
 393         }
 394         -O {
 395             if {[string length $arg]} {
 396                 set arg [lindex $argv [incr i]]
 397             }
 398             lappend omits $arg
 399         }
 400         -r {
 401             set reverse_map 1
 402         }
 403         default {
 404             lappend ifiles $arg
 405         }
 406     }
 407     incr i
 408 }
 409 if {![info exists ifiles]} {
 410     puts "charconv.tcl: missing input file(s)"
 411     usage
 412 }
 413
 414 set ofilehandle [open $ofile w]
 415 preamble_trie $ofilehandle $ifiles $ofile
 416
 417 foreach ifile $ifiles {
 418     readfile $ifile $ofilehandle $prefix $omits $reverse_map
 419 }
 420 close $ofilehandle
 421
 422