git.zerfleddert.de Git - micropolis/blob - src/tcl/library/mkindex.tcl

   1 # auto_mkindex:
   2 # Given a directory and a glob-style specification for files in that
   3 # directory, generate a "tclIndex" file in the directory that is suitable
   4 # for use in auto-loading.  Returns a null string.
   5 #
   6 # $Header: /user6/ouster/tcl/scripts/RCS/mkindex.tcl,v 1.2 91/12/16 08:29:25 ouster Exp $ SPRITE (Berkeley)
   7 #
   8 # Copyright 1991 Regents of the University of California
   9 # Permission to use, copy, modify, and distribute this
  10 # software and its documentation for any purpose and without
  11 # fee is hereby granted, provided that this copyright
  12 # notice appears in all copies.  The University of California
  13 # makes no representations about the suitability of this
  14 # software for any purpose.  It is provided "as is" without
  15 # express or implied warranty.
  16 #
  17
  18 proc auto_mkindex {dir files} {
  19     global errorCode errorInfo
  20     set oldDir [pwd]
  21     cd $dir
  22     set dir [pwd]
  23     append index "# Tcl autoload index file: each line identifies a Tcl\n"
  24     append index "# procedure and the file where that procedure is\n"
  25     append index "# defined.  Generated by the \"auto_mkindex\" command.\n"
  26     append index "\n"
  27     foreach file [glob $files] {
  28         set f ""
  29         set error [catch {
  30             set f [open $file]
  31             while {[gets $f line] >= 0} {
  32                 if [regexp {^proc[      ]+([^   ]*)} $line match procName] {
  33                     append index "[list $procName $file]\n"
  34                 }
  35             }
  36             close $f
  37         } msg]
  38         if $error {
  39             set code $errorCode
  40             set info $errorInfo
  41             catch [close $f]
  42             cd $oldDir
  43             error $msg $info $code
  44         }
  45     }
  46     set f [open tclindex w]
  47     puts $f $index nonewline
  48     close $f
  49     cd $oldDir
  50 }