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

Last change on this file was 11839, checked in by Kon Lovett, 13 years ago

Needed Unit files.

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