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

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Fri Nov 24 04:53:49 2006 UTC (7 years, 5 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.23: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: Likewise.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (in-package :meta-cvs)
6
7 (eval-when (:compile-toplevel :load-toplevel :execute)
8 (defconstant *up-dir* "..")
9 (defconstant *this-dir* ".")
10 (defconstant *path-sep* "/"))
11
12 (defun canonicalize-path (path)
13 "Simplifies a POSIX path by eliminating . components, splicing out as many ..
14 components as possible, and condensing multiple slashes. A trailing slash is
15 guaranteed to be preserved, if it follows something that could be a file or
16 directory. Two values are returned, the simplified path and a boolean value
17 which is true if there are any .. components that could not be spliced out."
18 (let ((split-path (split-fields path "/"))
19 uncanceled-up)
20
21 ;; First, if the path has at least two components,
22 ;; replace the first empty one with the symbol :root
23 ;; and the last empty one with :dir. These indicate a
24 ;; leading and trailing /
25 (when (and (> (length split-path) 1))
26 (when (string= (first split-path) "")
27 (setf (first split-path) :root))
28 (when (string= (first (last split-path)) "")
29 (setf (first (last split-path)) :dir)))
30
31 ;; Next, squash out all of the . and empty components,
32 ;; and replace .. components with :up symbol.
33 (setf split-path (mapcan #'(lambda (item)
34 (cond
35 ((string= item "") nil)
36 ((string= item ".") nil)
37 ((string= item "..") (list :up))
38 (t (list item))))
39 split-path))
40 (let (folded-path)
41 ;; Now, we use a pushdown automaton to reduce the .. paths
42 ;; The remaining stack is the reversed path.
43 (dolist (item split-path)
44 (case item
45 ((:up)
46 (case (first folded-path)
47 ((:root)) ;; do nothing
48 ((:up nil) (push item folded-path) (setf uncanceled-up t))
49 (otherwise (pop folded-path))))
50 ((:dir)
51 (case (first folded-path)
52 ((:root :up nil))
53 (otherwise (push (concatenate 'string (pop folded-path) "/")
54 folded-path))))
55 (otherwise
56 (push item folded-path))))
57 (setf split-path (nreverse folded-path)))
58
59 ;; If there are at least two components, remove a leading :root
60 ;; and add a / to the first component. If there are 0 components
61 ;; add a "." component.
62 (if (zerop (length split-path))
63 (push "." split-path)
64 (when (eq (first split-path) :root)
65 (pop split-path)
66 (push (concatenate 'string "/" (or (pop split-path) "")) split-path)))
67
68 ;; Map remaining symbols back to strings
69 (setf split-path (mapcar #'(lambda (item)
70 (case item
71 ((:up) "..")
72 (otherwise item))) split-path))
73
74 ;; Convert back to text
75 (values (reduce #'(lambda (x y) (concatenate 'string x "/" y)) split-path)
76 uncanceled-up)))
77
78 (defun basename (path)
79 "Splits the path into base name and directory, returned as two values.
80 If the path is / then . and / are returned. The rightmost slash is
81 used to determine the split between the path and the base name. If there
82 is a rightmost slash, then everything up to but not including that slash is
83 returned as the directory (second) value, and everything to the right is
84 returned as the base name (first) value. If there is no rightmost slash,
85 then the directory is returned as NIL, and the path is the entire base name.
86 If the path has a trailing slash, then that trailing slash is part of the base
87 name, and does not count as the rightmost slash."
88 (let* ((pos1 (position #\/ path :from-end t))
89 (pos2 (position #\/ path :end pos1 :from-end t)))
90 (cond
91 ((string= path "/")
92 (values "." "/"))
93 ((null pos1)
94 (values path nil))
95 ((= (1+ pos1) (length path))
96 (if (null pos2)
97 (values path nil)
98 (values (subseq path (1+ pos2)) (subseq path 0 pos2))))
99 (t
100 (values (subseq path (1+ pos1)) (subseq path 0 pos1))))))
101
102 (defun suffix (path &optional (separator-char #\.))
103 (multiple-value-bind (name dir)
104 (basename path)
105 (let ((pos (position separator-char name)))
106 (cond
107 ((eql pos 0)
108 (values nil name dir))
109 (pos
110 (values (subseq name (1+ pos)) (subseq name 0 pos) dir))
111 (t (values nil name dir))))))
112
113 (declaim (inline path-equal))
114 (defun path-equal (p1 p2)
115 (string= p1 p2))
116
117 (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
129 (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
134 (defun path-absolute-p (path)
135 (unless (zerop (length path))
136 (char= (char path 0) #\/)))
137
138 (defun parse-posix-namestring (path)
139 (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