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

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.19: +3 -0 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

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

  ViewVC Help
Powered by ViewVC 1.1.5