Return to buildidx.tcl CVS log

Up to [Micropolis - Activity] / micropolis / res

Annotation of micropolis/res/buildidx.tcl, revision 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.