cvs.zerfleddert.de Git - micropolis/blob - res/buildidx.tcl

   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