/[webpac]/openisis/current/tcl/openIsis.tcl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /openisis/current/tcl/openIsis.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 237 - (show annotations)
Mon Mar 8 17:43:12 2004 UTC (18 years, 2 months ago) by dpavlin
File MIME type: application/x-tcl
File size: 11357 byte(s)
initial import of openisis 0.9.0 vendor drop

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

  ViewVC Help
Powered by ViewVC 1.1.26