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