| 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 {& & < < > > \" "} $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 |
|
Parent Directory
| 
Revision Log