git.zerfleddert.de Git - micropolis/blob - src/tclx/tclsrc/packages.tcl

   1 #
   2 # packages.tcl --
   3 #
   4 # Command to retrieve a list of packages or information about the packages.
   5 #------------------------------------------------------------------------------
   6 # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
   7 #
   8 # Permission to use, copy, modify, and distribute this software and its
   9 # documentation for any purpose and without fee is hereby granted, provided
  10 # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11 # Mark Diekhans make no representations about the suitability of this
  12 # software for any purpose.  It is provided "as is" without express or
  13 # implied warranty.
  14 #------------------------------------------------------------------------------
  15 # $Id: packages.tcl,v 2.0 1992/10/16 04:52:02 markd Rel $
  16 #------------------------------------------------------------------------------
  17 #
  18
  19 #@package: TclX-packages packages autoprocs
  20
  21 proc packages {{option {}}} {
  22     global TCLENV
  23     set packList {}
  24     foreach key [array names TCLENV] {
  25         if {[string match "PKG:*" $key]} {
  26             lappend packList [string range $key 4 end]
  27         }
  28     }
  29     if [lempty $option] {
  30         return $packList
  31     } else {
  32         if {$option != "-location"} {
  33             error "Unknow option \"$option\", expected \"-location\""
  34         }
  35         set locList {}
  36         foreach pack $packList {
  37             set fileId [lindex $TCLENV(PKG:$pack) 0]
  38
  39             lappend locList [list $pack [concat $TCLENV($fileId) \
  40                                              [lrange $TCLENV(PKG:$pack) 1 2]]]
  41         }
  42         return $locList
  43     }
  44 }
  45
  46 proc autoprocs {} {
  47     global TCLENV
  48     set procList {}
  49     foreach key [array names TCLENV] {
  50         if {[string match "PROC:*" $key]} {
  51             lappend procList [string range $key 5 end]
  52         }
  53     }
  54     return $procList
  55 }