git.rot13.org Git - webpac/blob - openisis/tcl/openIsis.tcl

   1 #
   2 #/*
   3 #       openisis - an open implementation of the CDS/ISIS database
   4 #       Version 0.8.x (patchlevel see file Version)
   5 #       Copyright (C) 2001-2003 by Erik Grziwotz, erik@openisis.org
   6 #
   7 #       This library is free software; you can redistribute it and/or
   8 #       modify it under the terms of the GNU Lesser General Public
   9 #       License as published by the Free Software Foundation; either
  10 #       version 2.1 of the License, or (at your option) any later version.
  11 #
  12 #       This library is distributed in the hope that it will be useful,
  13 #       but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 #       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 #       Lesser General Public License for more details.
  16 #
  17 #       You should have received a copy of the GNU Lesser General Public
  18 #       License along with this library; if not, write to the Free Software
  19 #       Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20 #
  21 #       see README for more information
  22 #EOH */
  23 #
  24 #
  25 #       $Id: openIsis.tcl,v 1.11 2003/06/05 13:34:59 mawag Exp $
  26 #       the openIsis package
  27 #
  28
  29 package require Tcl 8.3
  30
  31 package provide openIsis 0.8.7
  32
  33 namespace eval openIsis {
  34         namespace export puts puth putu MHL MHLl isis res v save
  35         array set put {= s \" h ? u}
  36         set umap [list \n =0A { } + & =26 = =3D ? =3F]
  37         set srv "" ;# current server
  38         array set fsp {db "" proc ""} ;# cache field selection procedure
  39         set ver 0 ;# verbosity
  40 }
  41
  42 # Tsp compile
  43 # create Tcl code for Tcl Server Page
  44 # the returned code is usually evaluated in a namespace
  45 proc openIsis::Tspc {tsp {intro ""}} {
  46         variable put
  47         # vars global and main hold global and main code, resp
  48         set global {}
  49         set main {}
  50         # which section we are in
  51         set sect main
  52         set i 0
  53         set lit {$j >= $i};# condition for having a literal
  54         while {"#" == [string index $tsp $i]} {
  55                 set i [string first "\n" $tsp $i]
  56                 if {0 > $i} { error "unterminated line" }
  57                 incr i
  58         }
  59         while 1 {
  60                 # we're in literal (outside <% %>) mode
  61                 if {0 <= [set j [string first <% $tsp $i]]} {
  62                         incr j -1
  63                 } else {
  64                         set j end
  65                         set lit {$i <= [string length $tsp]}
  66                 }
  67                 if $lit {
  68                         append $sect "puts " [list [string range $tsp $i $j]] "\n"
  69                 }
  70                 if {"end" == $j} break
  71                 # have <% code, j was last char before
  72                 incr j 3
  73                 if {0 > [set i [string first %> $tsp $j]]} {
  74                         error "unbalanced <% at pos $j '[string range $tsp $j [expr $i+80]]'..."
  75                 }
  76                 incr i -1
  77                 switch -- [set type [string index $tsp $j]] \
  78                 - { # comment -- actually should start --
  79                         # extend to end of comment, skipping all intervening %>
  80                         if {0 > [set i [string first --%> $tsp $j]]} {
  81                                 error "unbalanced <%-- at pos $j ..."
  82                         }
  83                         incr i 4 ;# skip --%>
  84                         continue
  85                 } = - "\"" - ? {
  86                         incr j
  87                         set expr [string range $tsp $j $i]
  88                         # apply some magic guessing
  89                         if [regexp {^[.\-\d]} $expr] { # looks like v get args
  90                                 append $sect put$put($type) { [lindex [v get } $expr "] 0]\n"
  91                         } elseif [regexp {^[\w\d:]+($|\()} $expr] { # looks like variable
  92                                 append $sect "put$put($type) \"\$" $expr "\"\n"
  93                         } elseif [regexp {^\w} $expr] { # looks like command
  94                                 append $sect put$put($type) { [} $expr "]\n"
  95                         } else { # use as is
  96                                 append $sect "put$put($type) \"" $expr "\"\n"
  97                         }
  98                         set type =
  99                 } @ {
 100                         error "@-section is meaningless with TSPs"
 101                 } ! {
 102                         set sect global
 103                         if [set globlit [expr {"!" == [string index $tsp $i]}]] {
 104                                 incr i -1
 105                         }
 106                         incr j
 107                 } default {
 108                         set type ""
 109                         set sect main
 110                 }
 111                 if {"=" != $type} {
 112                         append $sect [string range $tsp $j $i] "\n"
 113                 }
 114                 if {"!" == $type} {
 115                         if $globlit {
 116                                 incr i 1
 117                         } else { # reset
 118                                 set sect main
 119                         }
 120                 }
 121                 incr i 3
 122         }
 123         return "$intro
 124 $global
 125 proc main {} {
 126 $main
 127 }
 128 ";
 129 }       ;# openIsis::Tspc
 130
 131 proc openIsis::puts {str} {
 132         ::puts -nonewline $str
 133 }
 134
 135 proc openIsis::2html {str} { # substitution of very important entities
 136         string map {& &amp; < &lt; > &gt; \" &quot;} $str
 137 }
 138
 139 proc openIsis::puth {str} {
 140         puts [2html $str]
 141 }
 142
 143 proc openIsis::2url {str} {
 144         variable umap
 145         regsub -all {[\0-\37]} [
 146         string map $umap $str
 147         ] {+} str
 148         set str
 149 }
 150
 151 proc openIsis::putu {str} {
 152         puts [2url $str]
 153 }
 154
 155 # run tspfile, compiling if necessary
 156 #
 157 proc openIsis::Tspr {tspfile} {
 158         variable ver
 159         set compile 1
 160         set mtime [file mtime $tspfile]
 161         catch {
 162                 if {[set ::tsp::${tspfile}::mtime] == $mtime} { set compile 0 }
 163         }
 164         if $compile {
 165                 catch {namespace delete ::tsp::$tspfile}
 166                 set f [open $tspfile]
 167                 namespace eval ::tsp::$tspfile [Tspc [read $f] "
 168                         variable mtime $mtime
 169                         namespace import ::openIsis::*
 170                 "]
 171                 close $f
 172                 if $ver {
 173                         ::puts stderr "compiled mtime [set ::tsp::${tspfile}::mtime]
 174                         [info body ::tsp::${tspfile}::main]"
 175                 }
 176         }
 177         ::tsp::${tspfile}::main
 178 }       ;# openIsis::Tspr
 179
 180 proc openIsis::MHL {str} {
 181         global env
 182         if [info exists env(ENCODING)] {
 183                 set str [encoding convertfrom $env(ENCODING) $str]
 184         }
 185         # ::puts stderr "MHLing '$str'"
 186         regsub -all {(<[^=>]*)=[^>]+>} $str {\1>} str; # dump <a=b> substitutions
 187         regsub -all {><} $str {; } str; # replace >< pairs
 188         regsub -all {[><]} $str {} str; # nuke other ><
 189         regsub {^\^.} $str {} str; # kill initial subfield spec
 190         regsub -all {\^a} $str {; } str; # ^a -> ;
 191         regsub -all {\^[b-i]} $str {, } str; # ^[b-i] -> ,
 192         regsub -all {\^.} $str {. } str; # others -> .
 193         return $str
 194 }
 195
 196 proc openIsis::MHLl {list} {
 197         set ret {}
 198         foreach str $list {
 199                 lappend ret [MHL $str]
 200         }
 201         return $ret
 202 }
 203
 204 # a procedure to make live with requests easier:
 205 # it uses the current value of the $srv server variable to send a request
 206 # so we can switch servers by setting srv, yet use a single command
 207 proc openIsis::isis {request args} {
 208         variable srv
 209         variable ver
 210         $srv .req delete
 211         $srv .req set -type $request
 212         # eval so that the single list of args becomes multiple parameters
 213         eval $srv req $args
 214         if $ver {
 215         ::puts stderr "###req
 216 [$srv .req serialize]###res
 217 [$srv .res serialize]###"
 218         }
 219         # return the size (number of records or mfns)
 220         $srv .res get {size 0}
 221 }
 222
 223 # convenient access to the result
 224 proc openIsis::res {args} {
 225         variable srv
 226         eval $srv .res $args
 227 }
 228
 229 # wrapper for current result record
 230 # add a "get first", if args is a single integer
 231 proc openIsis::v {args} {
 232         variable srv
 233         # if {"rowid" == $args} { return [$srv .res get {rowid 0}] }
 234         if {[string is integer $args]} { # v 24
 235                 return [$srv .res .rec get "$args {}"]
 236         }
 237         eval $srv .res .rec $args
 238 }
 239
 240
 241 #       write record rec as mfn to server srv
 242 proc openIsis::save {{rec rec} {mfn 0}} {
 243         variable srv
 244         variable fsp
 245
 246         set dbpath [$srv get 5]/[$srv get 721] ;# syspath/db
 247         if {$fsp(db) != $dbpath} { # check for fsp
 248                 set fsp(db) $dbpath
 249                 if {[catch {source $dbpath.fsp} fsp(proc)]
 250                         || "" == [info procs $fsp(proc)]} {
 251                         ::puts stderr "fsp $fsp(proc) : $::errorInfo"
 252                         set fsp(proc) ""
 253                 }
 254                 ::puts stderr "using fsp $fsp(proc)"
 255         }
 256
 257         $srv .req delete
 258         if {"" != $fsp(proc)} {
 259                 $srv new ::openIsis::idx
 260                 idx delete
 261                 if $mfn { # delete entries for old version
 262                         isis read -rowid $mfn
 263                         idx add -1 del ;# set delete mode
 264                         $fsp(proc) ::openIsis::v ::openIsis::idx
 265                         idx add -1 add ;# back to add mode
 266                 }
 267                 # add new index entries
 268                 $fsp(proc) $rec ::openIsis::idx
 269                 ::puts stderr "index entries:\n[idx serialize]"
 270                 $srv .req wrap -tag 926 ::openIsis::idx
 271         }
 272
 273         $srv .req set 904 $mfn
 274
 275         # wrap the record into request
 276         $srv .req wrap -tag 908 $rec
 277
 278         ::puts stderr "write:\n[$srv .req serialize]"
 279         if $mfn {
 280                 $srv req -type update -rowid $mfn
 281         } else {
 282                 $srv req -type insert
 283         }
 284
 285         res get rowid
 286 }       ;# save
 287
 288 proc openIsis::prnres {msg stb} {
 289   if [$stb .res] {
 290     set res [$stb .res get sid ser error error2]
 291     set tms ""
 292     set dta ""
 293     catch { set tms [$stb .res get tms] }
 294     catch { set dta [$stb .res get rec] }
 295     ::puts stderr "\[$stb/[lindex $res 0]] $msg:\
 296       ser [lindex $res 1],\
 297       err [lindex $res 2]/[lindex $res 3],\
 298       tms $tms,\
 299       dta $dta"
 300   } else {
 301     ::puts stderr "\[$stb] $msg: no response available"
 302   }
 303 }
 304
 305 proc openIsis::errno { stb } {
 306         if { ![ $stb .res ] } { return 0 }
 307         set err [$stb .res get error]
 308         if { $err } { return $err }
 309         set err [$stb .res get error2]
 310         return $err
 311 }
 312
 313 proc openIsis::maxrow {stb db wrn} {
 314   $stb .req delete
 315   $stb req type maxrow db $db
 316   prnres "maxrow $db" $stb
 317   set row 0
 318   if [catch {
 319     set row [$stb .res get rowid]
 320   }] {
 321     if $wrn {
 322       global errorInfo
 323       ::puts stderr $errorInfo
 324     }
 325   } {
 326     # puts stderr "maxrow = $row"
 327   }
 328   return $row
 329 }
 330
 331 #       ######################################################################
 332
 333 namespace eval openIsis::util {
 334
 335 #       construct fdt from list
 336         proc buildfdt lst {
 337                 set fdt [openIsisRec]
 338                 set num 0
 339                 foreach ent "$lst" {
 340                         set fd [eval openIsisRec \{\} set $ent]
 341                         $fdt wrap -tag 881 -done $fd
 342                         incr num
 343                 }
 344                 $fdt set 880 $num
 345                 return $fdt
 346         }
 347
 348 #       build list of records
 349         proc buildlst {lst {emb {}} {fdt {}}} {
 350                 if [string length $fdt] {
 351                         set fdt "-fdt $fdt"
 352                 }
 353                 set res [list]
 354                 foreach ent "$lst" {
 355                         set rec [eval openIsisRec \{\} $fdt]
 356                         foreach {tag val} "$ent" {
 357                                 if {0 <= [lsearch $emb $tag]} {
 358                                         set rec2 [eval openIsisRec \{\} add $val]
 359                                         $rec wrap -done $tag $rec2
 360                                 } {
 361                                         $rec add -ignore $tag $val
 362                                 }
 363                         }
 364                         lappend res $rec
 365                 }
 366                 return $res
 367         }
 368
 369 #       split recfield into list of subfield's char and value
 370         proc splitfld fld {
 371                 set lst [list]
 372                 set c ""
 373                 while {0 <= [set e [string first ^ $fld]]} {
 374                         set val [string range $fld 0 [expr $e - 1]]
 375                         set nc [string index $fld [incr e]]
 376                         if ![string length $nc] {
 377                                 break
 378                         }
 379                         if {[string length $c] || [string length $val]} {
 380                                 lappend lst "$c" "$val"
 381                         }
 382                         set c $nc
 383                         set fld [string range $fld [incr e] end]
 384                 }
 385                 lappend lst "$c" "$fld"
 386                 return $lst
 387         }
 388
 389         proc _rec2subs rec {
 390                 set fdt [$rec fdt]
 391                 set num [$fdt get 880]
 392                 set res {}
 393                 for {set j 0} {$num > $j} {incr j} {
 394                         set fd [$fdt .881\[$j\]]
 395                         if {15 == [$fd get 862]} {
 396                                 lappend res [$fd get 860]
 397                         }
 398                         $fd done
 399                 }
 400                 $fdt done
 401                 return $res
 402         }
 403
 404         proc _tgttag {tag rel} {
 405                 foreach {s t} $rel {
 406                         if {$s == $tag} {
 407                                 return $t
 408                         }
 409                 }
 410                 return -1
 411         }
 412
 413 #       make a deep record copy
 414 #       @param src command of source record
 415 #       @param tgt target record, optional
 416 #       @param fdt fdt of target record, optional
 417 #       @param rel relation between source and target record tags
 418 #               if empty, source tags are taken over unmodified
 419 #       @return target record
 420         proc deepcopy {src {tgt {}} {fdt {}} {rel {}}} {
 421                 if [catch {$tgt row}] {
 422                         if [string length $fdt] {
 423                                 set tgt [openIsisRec -fdt $fdt]
 424                         } {
 425                                 set tgt [openIsisRec]
 426                         }
 427                 }
 428                 set hasr [llength $rel]
 429                 set hast 0
 430                 if [catch {
 431                         set subrecs [_rec2subs $src]
 432                         set subend -1
 433                         foreach {t v} [$src get -tags] {
 434                                 if {0 <= $subend} {
 435                                         if $hast {
 436                                                 $emb add $t $v
 437                                         }
 438                                         if {$subend == [incr subcnt]} {
 439                                                 if $hast {
 440                                                         $tgt wrap -tag $subtag -done $emb
 441                                                 }
 442                                                 set subend -1
 443                                         }
 444                                         continue
 445                                 }
 446                                 if {0 <= [lsearch $subrecs $t]} {
 447                                         set subend $v
 448                                         set subcnt 0
 449                                         if $hasr {
 450                                                 set subtag [_tgttag $t "$rel"]
 451                                         } {
 452                                                 set subtag $t
 453                                         }
 454                                         set hast [expr 0 <= $subtag]
 455                                         if $hast {
 456                                                 set emb [openIsisRec]
 457                                         }
 458                                         continue
 459                                 }
 460                                 if $hasr {
 461                                         set tt [_tgttag $t "$rel"]
 462                                 } {
 463                                         set tt $t
 464                                 }
 465                                 if {0 <= $tt} {
 466                                         $tgt add -ignore $tt $v
 467                                 }
 468                         }
 469                 }] {
 470                         global errorInfo
 471                         puts $errorInfo
 472                 }
 473                 if $hast {
 474                         if ![catch { $emb done }] {
 475                                 set lst ""
 476                                 catch { set lst [$src get -tags] }
 477                                 puts "deepcopy: corrupted source: $lst"
 478                         }
 479                 }
 480                 return $tgt
 481         }
 482 }
 483