/[meta-cvs]/meta-cvs/F-123D61C8FE941733281D2B08C15CD438
ViewVC logotype

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Sat Oct 12 19:21:16 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
Changes since 1.18: +1 -47 lines
Minor reorganization.

* posix.lisp: File renamed to paths.lisp, module renamed to "paths".
(*editor*): Variable removed.
(arglist-to-command-string, execute-programs-xargs,
invoke-editor-on): Functions removed.

* posix.lisp: New file.
(*editor*): Variable moved here from paths.lisp.
(arglist-to-command-string, invoke-editor-on): Functions moved here
from paths.lisp.

* editor.lisp: New file.
(*argument-limit*): Variable definition moved here.
(execute-programs-xargs): Function moved here from paths.lisp.

* clisp-unix.lisp: Renamed to clisp-posix.lisp.
Requires "posix" module now.
(*argument-limit*): Variable removed.

* system.lisp: Remove references to old clisp-linux module.
Added requires for new paths and execute modules.

* cmucl-unix.lisp (*argument-limit*): Variable definition removed.
1 kaz 1.6 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.5 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "split")
6 kaz 1.19 (provide "paths")
7 kaz 1.1
8 kaz 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
9     (defconstant *up-dir* "..")
10     (defconstant *this-dir* ".")
11     (defconstant *path-sep* "/"))
12 kaz 1.1
13     (defun canonicalize-path (path)
14     "Simplifies a POSIX path by eliminating . components, splicing out as many ..
15     components as possible, and condensing multiple slashes. A trailing slash is
16     guaranteed to be preserved, if it follows something that could be a file or
17     directory. Two values are returned, the simplified path and a boolean value
18     which is true if there are any .. components that could not be spliced out."
19     (let ((split-path (split-fields path "/"))
20     uncanceled-up)
21    
22     ;; First, if the path has at least two components,
23     ;; replace the first empty one with the symbol :root
24     ;; and the last empty one with :dir. These indicate a
25     ;; leading and trailing /
26     (when (and (> (length split-path) 1))
27     (when (string= (first split-path) "")
28     (setf (first split-path) :root))
29     (when (string= (first (last split-path)) "")
30     (setf (first (last split-path)) :dir)))
31    
32     ;; Next, squash out all of the . and empty components,
33     ;; and replace .. components with :up symbol.
34     (setf split-path (mapcan #'(lambda (item)
35     (cond
36     ((string= item "") nil)
37     ((string= item ".") nil)
38     ((string= item "..") (list :up))
39     (t (list item))))
40     split-path))
41     (let (folded-path)
42     ;; Now, we use a pushdown automaton to reduce the .. paths
43     ;; The remaining stack is the reversed path.
44     (dolist (item split-path)
45     (case item
46     ((:up)
47     (case (first folded-path)
48     ((:root)) ;; do nothing
49     ((:up nil) (push item folded-path) (setf uncanceled-up t))
50     (otherwise (pop folded-path))))
51     ((:dir)
52     (case (first folded-path)
53     ((:root :up nil))
54 kaz 1.15 (otherwise (push (concatenate 'string (pop folded-path) "/")
55 kaz 1.1 folded-path))))
56     (otherwise
57     (push item folded-path))))
58     (setf split-path (nreverse folded-path)))
59    
60     ;; If there are at least two components, remove a leading :root
61     ;; and add a / to the first component. If there are 0 components
62     ;; add a "." component.
63     (if (zerop (length split-path))
64     (push "." split-path)
65     (when (eq (first split-path) :root)
66     (pop split-path)
67 kaz 1.15 (push (concatenate 'string "/" (or (pop split-path) "")) split-path)))
68 kaz 1.1
69     ;; Map remaining symbols back to strings
70     (setf split-path (mapcar #'(lambda (item)
71     (case item
72     ((:up) "..")
73     (otherwise item))) split-path))
74    
75     ;; Convert back to text
76 kaz 1.15 (values (reduce #'(lambda (x y) (concatenate 'string x "/" y)) split-path)
77 kaz 1.1 uncanceled-up)))
78    
79     (defun basename (path)
80 kaz 1.7 "Splits the path into base name and directory, returned as two values.
81 kaz 1.1 If the path is / then . and / are returned. The rightmost slash is
82     used to determine the split between the path and the base name. If there
83 kaz 1.3 is a rightmost slash, then everything up to but not including that slash is
84 kaz 1.1 returned as the directory (second) value, and everything to the right is
85     returned as the base name (first) value. If there is no rightmost slash,
86     then the directory is returned as NIL, and the path is the entire base name.
87     If the path has a trailing slash, then that trailing slash is part of the base
88     name, and does not count as the rightmost slash."
89     (let* ((pos1 (position #\/ path :from-end t))
90     (pos2 (position #\/ path :end pos1 :from-end t)))
91     (cond
92     ((string= path "/")
93     (values "." "/"))
94     ((null pos1)
95     (values path nil))
96     ((= (1+ pos1) (length path))
97     (if (null pos2)
98     (values path nil)
99 kaz 1.3 (values (subseq path (1+ pos2)) (subseq path 0 pos2))))
100 kaz 1.1 (t
101 kaz 1.3 (values (subseq path (1+ pos1)) (subseq path 0 pos1))))))
102 kaz 1.1
103 kaz 1.10 (defun suffix (path &optional (separator-char #\.))
104     (let ((name (basename path)))
105     (let ((pos (position separator-char name)))
106     (cond
107     ((eql pos 0)
108     (values nil name))
109     (pos
110     (values (subseq name (1+ pos)) (subseq name 0 pos)))
111     (t (values nil name))))))
112 kaz 1.8
113 kaz 1.1 (defun path-equal (p1 p2)
114     (string= p1 p2))
115 kaz 1.2 (declaim (inline path-equal))
116 kaz 1.1
117 kaz 1.2 (defun path-prefix-equal (shorter longer)
118     (let ((ls (length shorter)) (ll (length longer)))
119     (cond
120     ((> ls ll) nil)
121     ((not (string= shorter longer :end2 ls)) nil)
122     ((= ls ll) t)
123     ((and (> ls 0)
124     (char-equal (char shorter (1- ls)) #\/)
125     (char-equal (char longer (1- ls))) #\/) t)
126     ((char-equal (char longer ls) #\/) t)
127     (t nil))))
128 kaz 1.1
129 kaz 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
130     (defun path-cat (first-component &rest components)
131     (reduce #'(lambda (x y) (format nil "~a/~a" x y)) components
132     :initial-value first-component)))
133 kaz 1.7
134 kaz 1.13 (defun path-absolute-p (path)
135 kaz 1.18 (unless (zerop (length path))
136     (char= (char path 0) #\/)))
137 kaz 1.13
138 kaz 1.12 (defun parse-posix-namestring (path)
139 kaz 1.14 (let ((split-path (split-fields path "/")))
140     (let ((dir (butlast split-path))
141     (name (first (last split-path))))
142     (apply #'make-pathname
143     `(,@(when dir
144     `(:directory ,(if (string= "" (first dir))
145     `(:absolute ,@(rest dir))
146     `(:relative ,@dir))))
147     ,@(when name
148     `(:name ,name)))))))

  ViewVC Help
Powered by ViewVC 1.1.5