1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
#
# Core.tcl
# Core Cost utilities
#
# 1.7
#
# Set default Cost parameters:
#
global COST env
foreach {param envar default} {
PARSER COST_PARSER nsgmls
SGMLDECL SGML_DECLARATION ""
} {
if {[info exists env($envar)]} {
set COST($param) $env($envar)
} else {
set COST($param) $default
}
}
### Debugging and warning message handling:
proc DEBUG {key msg} {}
proc warning {text} { puts stderr "Warning: $text" }
proc cost:undefined {class value} {
global CostUndefined
if {![info exists CostUndefined($class.$value)]} {
set CostUndefined($class.$value) 1
puts stderr "Warning: undefined $class '$value'"
}
}
### Convenience functions for reading SGMLS output
# load SGMLS output from file
proc loadfile {filename} {
set fp [open $filename r]
set handle [loadsgmls $fp]
close $fp
return $handle
}
# invoke nsgmls as a subprocess
#
proc loaddoc {filename} {
global COST
set fp [open "|$COST(PARSER) $COST(SGMLDECL) $filename" r]
set handle [loadsgmls $fp]
if {[catch {close $fp} errorOutput]} {
puts stderr $errorOutput
}
return $handle
}
# load XML document:
#
proc loadxmldoc {filename} {
set fp [open $filename r]
set handle [loadxml $fp]
close $fp
return $handle
}
### List processing utilities:
# luniq: remove duplicate entries from a list
proc luniq {l} {
set l [lsort $l]
set lastel [lindex $l 0]
set result [list $lastel]
foreach el $l {
if {$el != $lastel} {
lappend result $el
set lastel $el
}
}
return $result
}
# lreverse: reverse a list
proc lreverse {l} {
set result ""
set i [expr [llength $l]-1 ]
while {$i >= 0} {
lappend result [lindex $l $i]
incr i -1
}
return $result
}
# shift: remove element from head of list
proc shift {varname} {
upvar $varname l
set head [lindex $l 0]
set l [lrange $l 1 end]
return $head
}
### Extra SGML utilities:
# From DSSSL:
# "The _child number_ of an element is the number of
# element siblings of the current element that are before or
# equal to the current element and that have the same
# generic identifier as the current element."
# Useful for constructing section numbers, etc.
#
proc childNumber {} {
return [expr 1 + [query# prev el withGI [query gi]]]
}
proc elementNumber {} {
return [expr 1 + [query# backward el withGI [query gi]]]
}
# hierarchyNumbers gi:
# rough equivalent of DSSSL "hierarchical-number-recursive";
# returns a list of the child numbers of each ancestor
# with generic identifier 'gi'
#
proc hierarchyNumbers {gi} {
set hn {}
foreachNode rootpath el withGI $gi {
lappend hn [childNumber]
}
return $hn
}
### Source file management:
### 'cost:require $filename' looks in the Cost search path
### for the specified file and loads it as a Tcl script.
###
### 'cost:findFile $filename' looks in the search path
### and returns the full pathname, if found;
### 'cost:openFile $filename' does the same, but opens the file
### for reading and returns the new handle.
proc cost:require {filename} {
global COST_LOADED_FILES COST
if {[info exists COST_LOADED_FILES($filename)]} { return }
foreach dir [concat {{}} $COST(searchPath)] {
set fullpath [file join $dir $filename]
if {[file exists $fullpath]} {
uplevel #0 source $fullpath
set COST_LOADED_FILES($filename) $fullpath
return;
}
}
error "cost:require: Can't find $filename"
}
proc require [info args cost:require] [info body cost:require]
proc cost:findFile {filename} {
global COST
foreach dir [concat {{}} $COST(searchPath)] {
if {[file exists [set fullpath [file join $dir $filename]]]} {
return $fullpath
}
}
error "cost:findFile: Can't find $filename"
}
proc cost:openFile {filename} {
return [open [cost:findFile $filename] r]
}
#*EOF*
|
