Return to buildidx.tcl CVS log

Up to [Micropolis - Activity] / micropolis / res

Annotation of micropolis/res/buildidx.tcl, revision 1.1.1.1

1.1       root        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: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.