Newer
Older
(t
(setf files good-files)))
(let ((common (file-namestring (car files))))
(dolist (file (cdr files))
(let ((name (file-namestring file)))
(dotimes (i (min (length common) (length name))
(when (< (length name) (length common))
(setf common name)))
(unless (char= (schar common i) (schar name i))
(setf common (subseq common 0 i))
(return)))))
(values (merge-pathnames common pathname)
nil)))))))
;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
;;;
(defun complete-file-directory-arg (pathname defaults)
(let* ((pathname (merge-pathnames pathname defaults))
(type (pathname-type pathname)))
(flet ((append-multi-char-wild (thing)
(etypecase thing
(null :wild)
(pattern
(make-pattern (append (pattern-pieces thing)
(list :multi-char-wild))))
(simple-string
(make-pattern (list thing :multi-char-wild))))))
(if (or (null type) (eq type :unspecific))
;; There is no type.
(make-pathname :defaults pathname
:name (append-multi-char-wild (pathname-name pathname))
:type :wild)
;; There already is a type, so just extend it.
(make-pathname :defaults pathname
:name (pathname-name pathname)
:type (append-multi-char-wild (pathname-type pathname)))))))
;;; Ambiguous-Files -- Public
(defun ambiguous-files (pathname
&optional (defaults *default-pathname-defaults*))
"Return a list of all files which are possible completions of Pathname.
We look in the directory specified by Defaults as well as looking down
the search list."
(directory (complete-file-directory-arg pathname defaults)
:check-for-subdirs nil))
;;; File-writable -- exported from extensions.
;;;
;;; Determines whether the single argument (which should be a pathname)
;;; can be written by the the current task.
(defun file-writable (name)
"File-writable accepts a pathname and returns T if the current
process can write it, and NIL otherwise."
(let ((name (unix-namestring name nil)))
(if (mach:unix-file-kind name)
(mach:unix-access name mach:w_ok)
(mach:unix-access (subseq name
0
(or (position #\/ name :from-end t)
0))
(logior mach:w_ok mach:x_ok))))))
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
;;; Pathname-Order -- Internal
;;;
;;; Predicate to order pathnames by. Goes by name.
;;;
(defun pathname-order (x y)
(let ((xn (%pathname-name x))
(yn (%pathname-name y)))
(if (and xn yn)
(let ((res (string-lessp xn yn)))
(cond ((not res) nil)
((= res (length (the simple-string xn))) t)
((= res (length (the simple-string yn))) nil)
(t t)))
xn)))
;;; Default-Directory -- Public
;;;
(defun default-directory ()
"Returns the pathname for the default directory. This is the place where
a file will be written if no directory is specified. This may be changed
with setf."
(multiple-value-bind (gr dir-or-error)
(mach:unix-current-directory)
(if gr
(let ((*ignore-wildcards* t))
(pathname (concatenate 'simple-string dir-or-error "/")))
;;; %Set-Default-Directory -- Internal
;;;
(defun %set-default-directory (new-val)
(multiple-value-bind (gr error)
(mach:unix-chdir (unix-namestring new-val t))
(setf (search-list "default:") (default-directory))
(error (mach:get-unix-error-msg error))))
new-val)
;;;
(defsetf default-directory %set-default-directory)
(defun filesys-init ()
(setf *default-pathname-defaults*
(%make-pathname *unix-host* nil nil nil nil :newest))
(setf (search-list "default:") (default-directory))
nil)