]> cvs.zerfleddert.de Git - micropolis/blob - src/tclx/tclsrc/pushd.tcl
let bundled tcl compile with recent tools
[micropolis] / src / tclx / tclsrc / pushd.tcl
1 #
2 # pushd.tcl --
3 #
4 # C-shell style directory stack procs.
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: pushd.tcl,v 2.0 1992/10/16 04:52:06 markd Rel $
17 #------------------------------------------------------------------------------
18 #
19
20 #@package: TclX-directory_stack pushd popd dirs
21
22 global TCLENV(dirPushList)
23
24 set TCLENV(dirPushList) ""
25
26 proc pushd {args} {
27 global TCLENV
28
29 if {[llength $args] > 1} {
30 error "bad # args: pushd [dir_to_cd_to]"
31 }
32 set TCLENV(dirPushList) [linsert $TCLENV(dirPushList) 0 [pwd]]
33
34 if {[llength $args] != 0} {
35 cd [glob $args]
36 }
37 }
38
39 proc popd {} {
40 global TCLENV
41
42 if [llength $TCLENV(dirPushList)] {
43 cd [lvarpop TCLENV(dirPushList)]
44 pwd
45 } else {
46 error "directory stack empty"
47 }
48 }
49
50 proc dirs {} {
51 global TCLENV
52 echo [pwd] $TCLENV(dirPushList)
53 }
Impressum, Datenschutz