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

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Sun Feb 10 04:39:03 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-6, mcvs-0-5
Changes since 1.8: +4 -3 lines
Adding some restarts around cvs update.

* posix.lisp (execute-command-xargs): Bail with nil return
value if any command line fails.

* update.lisp (mcvs-update): Tests return value of execute-program
and signal condition if it's nil. Provides a continue restart
as well as a retry restart to try the command again.

* error.lisp (mcvs-error-handler): Show retry restarts as
a special menu item "R".
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     (provide "posix")
7    
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     (otherwise (push (format nil "~a/" (pop folded-path))
55     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     (push (format nil "/~a" (or (pop split-path) "")) split-path)))
68    
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     (values (reduce #'(lambda (x y) (format nil "~a/~a" x y)) split-path)
77     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.8 (defun suffix (path separator-char)
104     (let ((pos (position separator-char path :from-end t)))
105     (if pos
106     (values (subseq path (1+ pos)) (subseq path 0 pos))
107     (values nil path))))
108    
109 kaz 1.1 (defun path-equal (p1 p2)
110     (string= p1 p2))
111 kaz 1.2 (declaim (inline path-equal))
112 kaz 1.1
113 kaz 1.2 (defun path-prefix-equal (shorter longer)
114     (let ((ls (length shorter)) (ll (length longer)))
115     (cond
116     ((> ls ll) nil)
117     ((not (string= shorter longer :end2 ls)) nil)
118     ((= ls ll) t)
119     ((and (> ls 0)
120     (char-equal (char shorter (1- ls)) #\/)
121     (char-equal (char longer (1- ls))) #\/) t)
122     ((char-equal (char longer ls) #\/) t)
123     (t nil))))
124 kaz 1.1
125 kaz 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
126     (defun path-cat (first-component &rest components)
127     (reduce #'(lambda (x y) (format nil "~a/~a" x y)) components
128     :initial-value first-component)))
129 kaz 1.7
130     (defun arglist-to-command-string (arglist)
131     "Convert list of strings, assumed to be an argument vector, into
132     a single command string that can be submitted to a POSIX command
133     interpreter. This requires escaping of all shell meta-characters."
134     (let ((command (make-array '(1024)
135     :element-type 'character
136     :adjustable t
137     :fill-pointer 0)))
138     (dolist (arg arglist command)
139     (dotimes (i (length arg))
140     (let ((ch (char arg i)))
141     (when (find ch #(#\' #\" #\* #\[ #\] #\?
142     #\$ #\{ #\} #\" #\space #\tab
143     #\( #\) #\< #\> #\| #\; #\&))
144     (vector-push-extend #\\ command))
145     (vector-push-extend ch command)))
146     (vector-push-extend #\space command))))
147    
148     (defun execute-program (&rest arg-list)
149     (let ((command (if (consp (first arg-list))
150     (arglist-to-command-string (first arg-list))
151     (arglist-to-command-string arg-list))))
152     (shell-interpreter command)))
153    
154 kaz 1.8 (defun execute-program-xargs (fixed-args &optional extra-args fixed-trail-args)
155 kaz 1.7 (let* ((fixed-size (reduce #'(lambda (x y)
156     (+ x (length y) 1))
157 kaz 1.8 (append fixed-args fixed-trail-args)
158     :initial-value 0))
159 kaz 1.7 (size fixed-size))
160     (if extra-args
161     (let (chopped-arg)
162     (dolist (arg extra-args)
163     (push arg chopped-arg)
164     (when (> (incf size (1+ (length arg))) *argument-limit*)
165 kaz 1.9 (when (not (execute-program (append fixed-args
166     (nreverse chopped-arg)
167     fixed-trail-args)))
168     (return nil))
169 kaz 1.7 (setf chopped-arg nil)
170     (setf size fixed-size)))
171     (when chopped-arg
172 kaz 1.8 (execute-program (append fixed-args (nreverse chopped-arg)
173     fixed-trail-args))))
174 kaz 1.7 (execute-program fixed-args))))

  ViewVC Help
Powered by ViewVC 1.1.5