home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclX8.3 / buildidx.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  6.1 KB  |  175 lines
  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 8.7 1999/03/31 06:37:47 markd Exp $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. namespace 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. #
  163. proc 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.