]>
Commit | Line | Data |
---|---|---|
6a5fa4e0 MG |
1 | # |
2 | # buildidx.tcl -- | |
3 | # | |
4 | # Code to build Tcl package library. Defines the proc `buildpackageindex'. | |
5 | # | |
6 | #------------------------------------------------------------------------------ | |
7 | # Copyright 1992 Karl Lehenbauer and Mark Diekhans. | |
8 | # | |
9 | # Permission to use, copy, modify, and distribute this software and its | |
10 | # documentation for any purpose and without fee is hereby granted, provided | |
11 | # that the above copyright notice appear in all copies. Karl Lehenbauer and | |
12 | # Mark Diekhans make no representations about the suitability of this | |
13 | # software for any purpose. It is provided "as is" without express or | |
14 | # implied warranty. | |
15 | #------------------------------------------------------------------------------ | |
16 | # $Id: buildidx.tcl,v 2.0 1992/10/16 04:51:38 markd Rel $ | |
17 | #------------------------------------------------------------------------------ | |
18 | # | |
19 | ||
20 | proc TCHSH:PutLibLine {outfp package where endwhere autoprocs} { | |
21 | puts $outfp [concat $package $where [expr {$endwhere - $where - 1}] \ | |
22 | $autoprocs] | |
23 | } | |
24 | ||
25 | proc TCLSH:CreateLibIndex {libName} { | |
26 | ||
27 | if {[file extension $libName] != ".tlb"} { | |
28 | error "Package library `$libName' does not have the extension `.tlb'"} | |
29 | set idxName "[file root $libName].tndx" | |
30 | ||
31 | unlink -nocomplain $idxName | |
32 | set libFH [open $libName r] | |
33 | set idxFH [open $idxName w] | |
34 | ||
35 | set contectHdl [scancontext create] | |
36 | ||
37 | scanmatch $contectHdl "^#@package: " { | |
38 | set size [llength $matchInfo(line)] | |
39 | if {$size < 2} { | |
40 | error [format "invalid package header \"%s\"" $matchInfo(line)] | |
41 | } | |
42 | if $inPackage { | |
43 | TCHSH:PutLibLine $idxFH $pkgDefName $pkgDefWhere \ | |
44 | $matchInfo(offset) $pkgDefProcs | |
45 | } | |
46 | set pkgDefName [lindex $matchInfo(line) 1] | |
47 | set pkgDefWhere [tell $matchInfo(handle)] | |
48 | set pkgDefProcs [lrange $matchInfo(line) 2 end] | |
49 | set inPackage 1 | |
50 | } | |
51 | ||
52 | scanmatch $contectHdl "^#@packend" { | |
53 | if !$inPackage { | |
54 | error "#@packend without #@package in $libName | |
55 | } | |
56 | TCHSH:PutLibLine $idxFH $pkgDefName $pkgDefWhere $matchInfo(offset) \ | |
57 | $pkgDefProcs | |
58 | set inPackage 0 | |
59 | } | |
60 | ||
61 | set inPackage 0 | |
62 | if {[catch { | |
63 | scanfile $contectHdl $libFH | |
64 | } msg] != 0} { | |
65 | global errorInfo errorCode | |
66 | close libFH | |
67 | close idxFH | |
68 | error $msg $errorInfo $errorCode | |
69 | } | |
70 | if {![info exists pkgDefName]} { | |
71 | error "No #@package definitions found in $libName" | |
72 | } | |
73 | if $inPackage { | |
74 | TCHSH:PutLibLine $idxFH $pkgDefName $pkgDefWhere [tell $libFH] \ | |
75 | $pkgDefProcs | |
76 | } | |
77 | close $libFH | |
78 | close $idxFH | |
79 | ||
80 | scancontext delete $contectHdl | |
81 | ||
82 | # Set mode and ownership of the index to be the same as the library. | |
83 | ||
84 | file stat $libName statInfo | |
85 | chmod $statInfo(mode) $idxName | |
86 | chown [list $statInfo(uid) $statInfo(gid)] $idxName | |
87 | ||
88 | } | |
89 | ||
90 | proc buildpackageindex {libfile} { | |
91 | ||
92 | set status [catch {TCLSH:CreateLibIndex $libfile} errmsg] | |
93 | if {$status != 0} { | |
94 | global errorInfo errorCode | |
95 | error "building package index for `$libfile' failed: $errmsg" \ | |
96 | $errorInfo $errorCode | |
97 | } | |
98 | } | |
99 |