/[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

Annotation of /openisis/current/tcl/openIsis.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 237 - (hide 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 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 {& &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