]> cvs.zerfleddert.de Git - micropolis/blob - res/buildidx.tcl
XINCLUDE: use /usr/X11R6/include everywhere
[micropolis] / res / buildidx.tcl
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
Impressum, Datenschutz