1# 2# buildidx.tcl -- 3# 4# Code to build Tcl package library. Defines the proc `buildpackageindex'. 5# 6#------------------------------------------------------------------------------ 7# Copyright 1992-1999 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 1.1 2001/10/24 23:31:48 hobbs Exp $ 17#------------------------------------------------------------------------------ 18# 19 20namespace eval TclX { 21 22 23 #-------------------------------------------------------------------------- 24 # The following code passes around a array containing information about a 25 # package. The following fields are defined 26 # 27 # o name - The name of the package. 28 # o offset - The byte offset of the package in the file. 29 # o length - Number of bytes in the current package (EOLN counts as one 30 # byte, even if <cr><lf> is used. This makes it possible to do a 31 # single read. 32 # o procs - The list of entry point procedures defined for the package. 33 #-------------------------------------------------------------------------- 34 35 #-------------------------------------------------------------------------- 36 # Write a line to the index file describing the package. 37 # 38 proc PutIdxEntry {outfp pkgInfo} { 39 puts $outfp [concat [keylget pkgInfo name] \ 40 [keylget pkgInfo offset] \ 41 [keylget pkgInfo length] \ 42 [keylget pkgInfo procs]] 43 } 44 45 #-------------------------------------------------------------------------- 46 # Parse a package header found by a scan match. Handle backslashed 47 # continuation lines. Make a namespace reference out of the name 48 # that the Tcl auto_load function will like. Global names have no 49 # leading :: (for historic reasons), all others are fully qualified. 50 # 51 proc ParsePkgHeader matchInfoVar { 52 upvar $matchInfoVar matchInfo 53 54 set length [expr [clength $matchInfo(line)] + 1] 55 set line [string trimright $matchInfo(line)] 56 while {[string match {*\\} $line]} { 57 set line [csubstr $line 0 [expr [clength $line]-1]] 58 set nextLine [gets $matchInfo(handle)] 59 append line " " [string trimright $nextLine] 60 incr length [expr [clength $nextLine] + 1] 61 } 62 set procs {} 63 foreach p [lrange $line 2 end] { 64 lappend procs [auto_qualify $p ::] 65 } 66 67 keylset pkgInfo name [lindex $line 1] 68 keylset pkgInfo offset $matchInfo(offset) 69 keylset pkgInfo procs $procs 70 keylset pkgInfo length $length 71 return $pkgInfo 72 } 73 74 #-------------------------------------------------------------------------- 75 # Do the actual work of creating a package library index from a library 76 # file. 77 # 78 proc CreateLibIndex {libName} { 79 if {[file extension $libName] != ".tlib"} { 80 error "Package library `$libName' does not have the extension\ 81 `.tlib'" 82 } 83 set idxName "[file root $libName].tndx" 84 85 catch {file delete $idxName} 86 87 set contectHdl [scancontext create] 88 89 scanmatch $contectHdl "^#@package: " { 90 if {[catch {llength $matchInfo(line)}] || 91 ([llength $matchInfo(line)] < 2)} { 92 error "invalid package header \"$matchInfo(line)\"" 93 } 94 if ![lempty $pkgInfo] { 95 TclX::PutIdxEntry $idxFH $pkgInfo 96 } 97 set pkgInfo [TclX::ParsePkgHeader matchInfo] 98 incr packageCnt 99 } 100 101 scanmatch $contectHdl "^#@packend" { 102 if [lempty $pkgInfo] { 103 error "#@packend without #@package in $libName" 104 } 105 keylset pkgInfo length \ 106 [expr [keylget pkgInfo length] + \ 107 [clength $matchInfo(line)]+1] 108 TclX::PutIdxEntry $idxFH $pkgInfo 109 set pkgInfo {} 110 } 111 112 113 scanmatch $contectHdl { 114 if ![lempty $pkgInfo] { 115 keylset pkgInfo length \ 116 [expr [keylget pkgInfo length] + \ 117 [clength $matchInfo(line)]+1] 118 } 119 } 120 121 try_eval { 122 set libFH [open $libName r] 123 set idxFH [open $idxName w] 124 set packageCnt 0 125 set pkgInfo {} 126 127 scanfile $contectHdl $libFH 128 if {$packageCnt == 0} { 129 error "No \"#@package:\" definitions found in $libName" 130 } 131 if ![lempty $pkgInfo] { 132 TclX::PutIdxEntry $idxFH $pkgInfo 133 } 134 } { 135 catch {file delete $idxName} 136 error $errorResult $errorInfo $errorCode 137 } { 138 catch {close $libFH} 139 catch {close $idxFH} 140 } 141 142 scancontext delete $contectHdl 143 144 # Set mode and ownership of the index to be the same as the library. 145 # Ignore errors if you can't set the ownership. 146 147 # FIX: WIN32, when chmod/chown work. 148 global tcl_platform 149 if ![cequal $tcl_platform(platform) "unix"] return 150 151 file stat $libName statInfo 152 chmod $statInfo(mode) $idxName 153 catch { 154 chown [list $statInfo(uid) $statInfo(gid)] $idxName 155 } 156 } 157 158} ;# namespace TclX 159 160#------------------------------------------------------------------------------ 161# Create a package library index from a library file. 162# 163proc buildpackageindex {libfilelist} { 164 foreach libfile $libfilelist { 165 if [catch { 166 TclX::CreateLibIndex $libfile 167 } errmsg] { 168 global errorInfo errorCode 169 error "building package index for `$libfile' failed: $errmsg" \ 170 $errorInfo $errorCode 171 } 172 } 173} 174 175