source: project/release/3/misc-extn/trunk/misc-extn-directory.scm @ 8121

Last change on this file since 8121 was 8121, checked in by Kon Lovett, 14 years ago

Forgot to add to repo.

File size: 3.3 KB
Line 
1;;;; misc-extn-directory.scm
2;;;; Kon Lovett, Sep '07
3
4(use srfi-1 srfi-13 utils posix)
5(use misc-extn-list stack miscmacros)
6
7(eval-when (compile)
8  (declare
9    (usual-integrations)
10        (inline)
11        (fixnum)
12                (no-procedure-checks)
13                (no-bound-checks)
14        (export
15      push-directory
16      pop-directory
17      pop-toplevel-directory
18      create-directory/parents
19                create-pathname-directory
20                make-program-filename
21                file-exists/directory?
22                find-file-pathnames
23                find-program-pathnames
24                which-command-pathname
25                remove-dotfiles
26          ; Deprecated
27                which-command-directory) ) )
28
29;;; Directory Stuff
30
31;; Directory Stack
32
33(define push-directory)
34(define pop-directory)
35(define pop-toplevel-directory)
36
37(let ([*directory-stack* (make-stack)]
38      [*currdir-pathname* (make-pathname "." #f)])
39
40  (set! push-directory
41    (lambda (dir)
42      (stack-push! *directory-stack* (current-directory))
43      ; Don't cd unless necessary
44      (when (and dir
45                 (not (or (string-null? dir)
46                          (string=? *currdir-pathname* (make-pathname dir #f)) ) ) )
47        (current-directory dir) ) ) )
48
49  (set! pop-directory
50    (lambda ()
51      (unless (stack-empty? *directory-stack*)
52        (current-directory (stack-pop! *directory-stack*)) ) ) )
53
54  (set! pop-toplevel-directory
55    (lambda ()
56      (until (stack-empty? *directory-stack*)
57        (pop-directory) ) ) ) )
58
59;; Ensure the directory exists.
60
61(define (create-directory/parents dir)
62  (let loop ([dir dir])
63    (when (and dir (not (directory? dir)))
64      (loop (pathname-directory dir))
65      (create-directory dir) ) ) )
66
67;; Ensure the directory for the specified path exists.
68
69(define (create-pathname-directory pathname)
70  (create-directory/parents (pathname-directory pathname)) )
71
72;; Platform specific program filename.
73
74(define (make-program-filename bn)
75  (cond-expand
76    [windows
77      (if (pathname-extension bn)
78          bn
79          (make-pathname #f bn ".exe"))]
80    [else
81      bn]) )
82
83;; Pathname if file exists in directory.
84
85(define (file-exists/directory? fil #!optional dir)
86  (let ([path (make-pathname dir fil)])
87    (and (file-exists? path)
88         path) ) )
89
90;; List of all found pathnames.
91
92(define (find-file-pathnames fil . dirs)
93  (let loop ([dirs dirs] [paths '()])
94    (if (null? dirs)
95        (not-null? paths)
96        (let ([dir (car dirs)])
97          (loop (cdr dirs)
98            (append! paths
99                     (filter-map (cut file-exists/directory? fil <>)
100                                 (ensure-list dir)))))) ) )
101
102(define (find-program-pathnames cmd . dirs)
103  (apply find-file-pathnames
104         (make-program-filename cmd)
105         dirs) )
106
107;; First found program pathname in path.
108
109(cond-expand
110  [windows (define-constant PATH-DELIMITER ";")]
111  [else (define-constant PATH-DELIMITER ":")])
112
113(define (which-command-pathname cmd #!optional (env-var "PATH"))
114  (and-let* ([env-path (getenv env-var)]
115             [paths
116              (find-program-pathnames cmd
117                                      (string-split env-path PATH-DELIMITER))])
118    (first paths) ) )
119
120;; Remove dot files from a directory list
121
122(define (remove-dotfiles files)
123        (remove
124                (lambda (pn)
125                        (string-prefix? "." (pathname-file pn)))
126                files) )
127
128;; Deprecated
129
130(define which-command-directory which-command-pathname)
Note: See TracBrowser for help on using the repository browser.