Skip to content
Snippets Groups Projects
Commit 5276437a authored by chiles's avatar chiles
Browse files

Modified COMPLETE-FILE to correctly complete files relative to the defaults.
It was previously relying on MERGE-PATHNAMES solely, but MERGE-PATHNAMES cannot
do what COMPLETE-FILE requires when presented with a partial (non-absolute)
pathname that includes some directories.  What the user wants is the partial
pathname to be merged with the absolute defaults including any directories
specified in pathname.  MERGE-PATHNAMES cannot do this since partial pathnames
have independent uses, and it cannot clobber a non-nil slot in the partial
pathname structure.  However, COMPLETE-FILE obtains its partial pathnames from
users specifying against defaults with the intent of deriving an absolute name,
so when the defaults contain an absolute directory slot, the partial directory
spec of the supplied pathname (if any) gets tacked onto the end of the defaults
directory spec.

This fixes a long standing Hemlock problem: you could find files relative to
the defaults with subdirectory specs, but you could not complete them.

Fixed DIRECTORY to no longer signal errors.  It's job is to return a list of
files matching its argument, and it should return nil when the spec is in
accurate.
parent c421a414
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.12 1991/09/03 20:44:02 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.13 1991/10/22 16:31:32 chiles Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -256,19 +256,18 @@
(defaults *default-pathname-defaults*)
default-version)
"Fills in unspecified slots of Pathname from Defaults (defaults to
*default-pathname-defaults*). If the version remains unspecified,
gets it from Default-Version."
*default-pathname-defaults*). If the version remains unspecified,
gets it from Default-Version."
;;
;; finish hairy argument defaulting
(let ((pathname (pathname pathname))
(defaults (pathname defaults)))
;;
;; make a new pathname
(let ((name (%pathname-name pathname))
(device (%pathname-device pathname)))
(let ((name (%pathname-name pathname)))
(%make-pathname
(or (%pathname-host pathname) (%pathname-host defaults))
(or device (%pathname-device defaults))
(or (%pathname-device pathname) (%pathname-device defaults))
(or (%pathname-directory pathname) (%pathname-directory defaults))
(or name (%pathname-name defaults))
(or (%pathname-type pathname) (%pathname-type defaults))
......@@ -689,13 +688,13 @@
(let* ((pathname (if (pathnamep pathname) pathname (pathname pathname)))
(device (%pathname-device pathname))
(pattern (parse-pattern pathname))
(results nil)
(really-won nil))
(results nil))
(if (or (eq device :absolute)
(null device)
(string= device "Default"))
(multiple-value-setq (results really-won)
(matching-files-in-dir (directory-namestring pathname) pattern all))
(setf results
(matching-files-in-dir (directory-namestring pathname)
pattern all))
(let ((remainder (namestring-without-device
(directory-namestring pathname))))
(do-search-list (dir device)
......@@ -709,11 +708,7 @@
(when won
(setf really-won t))
(setf results (append results files))))))
(unless really-won
(error "Could not find ~S." pathname))
(setf results
(sort (delete-duplicates results :test #'string=)
#'string<))
(setf results (sort (delete-duplicates results :test #'string=) #'string<))
(mapcar #'(lambda (name)
(if (and check-for-subdirs
(eq (mach:unix-file-kind name) :directory))
......@@ -937,14 +932,12 @@
;;;; File completion.
;;; COMPLETE-FILE -- Public
;;;
(defun complete-file (pathname &key (defaults *default-pathname-defaults*)
ignore-types)
;; Find all possible pathnames.
(let ((files
(directory (concatenate 'string
(namestring (merge-pathnames pathname
defaults))
"*")
(directory (complete-file-directory-arg pathname defaults)
:check-for-subdirs nil)))
(cond ((null files)
(values nil nil))
......@@ -981,12 +974,49 @@
(values (merge-pathnames common pathname)
nil)))))))
;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
;;;
;;; This is necessary to make COMPLETE-FILE reasonable. The problem is that
;;; MERGE-PATHNAMES of pathname and defaults fails us when pathname has a
;;; non-nil directory slot, and pathname is relative to the "default" device.
;;; There is no good argument for making MERGE-PATHNAMES do what COMPLETE-FILE
;;; wants, but since COMPLETE-FILE is used in the context of the defaults
;;; argument, it should always complete relative to the defaults, not relative
;;; to the "default" logical name. That is, what users want when pathname is
;;; not absolute and specifies directories is something relative to the
;;; absolute defaults supplied.
;;;
(defun complete-file-directory-arg (pathname defaults)
(let ((pathname (pathname pathname))
(defaults (pathname defaults)))
(concatenate 'simple-string
(namestring
(cond
((not (and (string= (pathname-device pathname) "Default")
(pathname-directory pathname)))
(merge-pathnames pathname defaults))
((eq (pathname-device defaults) :absolute)
;;
(make-pathname
:host (or (pathname-host pathname) (pathname-host defaults))
:device :absolute
:directory (concatenate 'simple-vector
(pathname-directory defaults)
(pathname-directory pathname))
:name (or (pathname-name pathname) (pathname-name defaults))
:type (or (pathname-type pathname)
(pathname-type defaults))))
(t
;; This branch should never fire, but just in case ...
(merge-pathnames pathname defaults))))
"*")))
;;; Ambiguous-Files -- Public
;;;
(defun ambiguous-files (pathname &optional 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."
We look in the directory specified by Defaults as well as looking down
the search list."
(directory (concatenate 'string
(namestring
(merge-pathnames pathname
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment