projects / micropolis / blame
| Commit | Line | Data |
|---|---|---|
| 6a5fa4e0 MG |
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 | } |