1 |
dpavlin |
237 |
# |
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 |
|
|
|