home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / tls / tls074c.sunsparc.Z / tls074c.sunsparc / usr / lib / tcl / buildidx.tcl < prev    next >
Encoding:
Text File  |  1995-07-20  |  4.7 KB  |  141 lines
  1. #
  2. # buildidx.tcl --
  3. #
  4. # Code to build Tcl package library. Defines the proc `buildpackageindex'.
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1993 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.3 1995/01/26 10:51:25 zibi Exp $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. #------------------------------------------------------------------------------
  21. # The following code passes around a array containing information about a
  22. # package.  The following fields are defined
  23. #
  24. #   o name - The name of the package.
  25. #   o offset - The byte offset of the package in the file.
  26. #   o procs - The list of entry point procedures defined for the package.
  27. #------------------------------------------------------------------------------
  28.  
  29. #------------------------------------------------------------------------------
  30. # Write a line to the index file describing the package.
  31. #
  32. proc TCLSH:PutIdxEntry {outfp pkgInfo endOffset} {
  33.     puts $outfp [concat [keylget pkgInfo name] \
  34.                         [keylget pkgInfo offset] \
  35.                         [expr {$endOffset - [keylget pkgInfo offset] - 1}] \
  36.                         [keylget pkgInfo procs]]
  37. }
  38.  
  39. #------------------------------------------------------------------------------
  40. # Parse a package header found by a scan match.  Handle backslashed
  41. # continuation lines.
  42. #
  43. proc TCLSH:ParsePkgHeader matchInfoVar {
  44.     upvar $matchInfoVar matchInfo
  45.  
  46.     set line [string trimright $matchInfo(line)]
  47.     while {[string match {*\\} $line]} {
  48.         set line [csubstr $line 0 [expr [clength $line]-1]]
  49.         append line " " [string trimright [gets $matchInfo(handle)]]
  50.     }
  51.  
  52.     keylset pkgInfo name   [lindex $line 1]
  53.     keylset pkgInfo offset [tell $matchInfo(handle)]
  54.     keylset pkgInfo procs  [lrange $line  2 end]
  55.     return $pkgInfo
  56. }
  57.  
  58. #------------------------------------------------------------------------------
  59. # Do the actual work of creating a package library index from a library file.
  60. #
  61. proc TCLSH:CreateLibIndex {libName} {
  62.  
  63.     if {[file extension $libName] != ".tlib"} {
  64.         error "Package library `$libName' does not have the extension `.tlib'"
  65.     }
  66.     set idxName "[file root $libName].tndx"
  67.  
  68.     unlink -nocomplain $idxName
  69.     set libFH [open $libName r]
  70.     set idxFH [open $idxName w]
  71.     set packageCnt 0
  72.  
  73.     set contectHdl [scancontext create]
  74.  
  75.     scanmatch $contectHdl "^#@package: " {
  76.         if {[llength $matchInfo(line)] < 2} {
  77.             error "invalid package header \"$matchInfo(line)\""
  78.         }
  79.         if ![lempty $pkgInfo] {
  80.             TCLSH:PutIdxEntry $idxFH $pkgInfo $matchInfo(offset)
  81.         }
  82.         set pkgInfo [TCLSH:ParsePkgHeader matchInfo]
  83.         incr packageCnt
  84.     }
  85.  
  86.     scanmatch $contectHdl "^#@packend" {
  87.         if [lempty $pkgInfo] {
  88.             error "#@packend without #@package in $libName"
  89.         }
  90.         TCLSH:PutIdxEntry $idxFH $pkgInfo $matchInfo(offset)
  91.         set pkgInfo {}
  92.     }
  93.  
  94.     set pkgInfo {}
  95.     if {[catch {
  96.         scanfile $contectHdl $libFH
  97.         if {$packageCnt == 0} {
  98.             error "No #@package definitions found in $libName"
  99.         }   
  100.     } msg] != 0} {
  101.        global errorInfo errorCode
  102.        close $libFH
  103.        close $idxFH
  104.        unlink -nocomplain $idxName
  105.        error $msg $errorInfo $errorCode
  106.     }
  107.     if ![lempty $pkgInfo] {
  108.         TCLSH:PutIdxEntry $idxFH $pkgInfo [tell $libFH] 
  109.     }
  110.     close $libFH
  111.     close $idxFH
  112.     
  113.     scancontext delete $contectHdl
  114.  
  115.     # Set mode and ownership of the index to be the same as the library.
  116.     # Ignore errors if you can't set the ownership.
  117.  
  118.     file stat $libName statInfo
  119.     chmod $statInfo(mode) $idxName
  120.     catch {
  121.        chown [list $statInfo(uid) $statInfo(gid)] $idxName
  122.     }
  123. }
  124.  
  125. #------------------------------------------------------------------------------
  126. # Create a package library index from a library file.
  127. #
  128. proc buildpackageindex {libfilelist} {
  129.     foreach libfile $libfilelist {
  130.         set status [catch {
  131.             TCLSH:CreateLibIndex $libfile
  132.         } errmsg]
  133.         if {$status != 0} {
  134.             global errorInfo errorCode
  135.             error "building package index for `$libfile' failed: $errmsg" \
  136.                 $errorInfo $errorCode
  137.         }
  138.     }
  139. }
  140.  
  141.