Skip to content
Snippets Groups Projects
filesys.lisp 36 KiB
Newer Older
(defun complete-file (pathname &key (defaults *default-pathname-defaults*)
			       ignore-types)
  (let ((files (directory (complete-file-directory-arg pathname defaults)
			  :check-for-subdirs nil
			  :follow-links nil)))
    (cond ((null files)
	   (values nil nil))
	  ((null (cdr files))
	   (values (merge-pathnames (file-namestring (car files))
				    pathname)
		   t))
	  (t
	   (let ((good-files
		  (delete-if #'(lambda (pathname)
				 (and (simple-string-p
				       (pathname-type pathname))
				      (member (pathname-type pathname)
					      ignore-types
					      :test #'string=)))
			     files)))
	     (cond ((null good-files))
		   ((null (cdr good-files))
		    (return-from complete-file
				 (values (merge-pathnames (file-namestring
							   (car good-files))
							  pathname)
					 t)))
		   (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)))))))

chiles's avatar
 
chiles committed
;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
;;;
(defun complete-file-directory-arg (pathname defaults)
  (let* ((pathname (merge-pathnames pathname (directory-namestring 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)))))))
chiles's avatar
 
chiles committed

;;; Ambiguous-Files  --  Public
ram's avatar
ram committed
;;;
(defun ambiguous-files (pathname
			&optional (defaults *default-pathname-defaults*))
  "Return a list of all files which are possible completions of Pathname.
chiles's avatar
 
chiles committed
   We look in the directory specified by Defaults as well as looking down
   the search list."
  (directory (complete-file-directory-arg pathname defaults)
ram's avatar
ram committed

;;; File-writable -- exported from extensions.
;;;
;;;   Determines whether the single argument (which should be a pathname)
;;;   can be written by the the current task.
ram's avatar
ram committed
(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)))
	  ((unix:unix-file-kind name)
	   (values (unix:unix-access name unix:w_ok)))
	    (unix:unix-access (subseq name
				      0
				      (or (position #\/ name :from-end t)
					  0))
			      (logior unix:w_ok unix:x_ok)))))))
ram's avatar
ram committed


;;; 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)
		       (unix:unix-current-directory)
ram's avatar
ram committed
    (if gr
	(let ((*ignore-wildcards* t))
	  (pathname (concatenate 'simple-string dir-or-error "/")))
	(error dir-or-error))))
ram's avatar
ram committed

;;; %Set-Default-Directory  --  Internal
;;; 
(defun %set-default-directory (new-val)
  (let ((namestring (unix-namestring new-val t)))
    (unless namestring
      (error "~S doesn't exist." new-val))
    (multiple-value-bind (gr error)
			 (unix:unix-chdir namestring)
      (if gr
	  (setf (search-list "default:") (default-directory))
	  (error (unix:get-unix-error-msg error))))
;;;
(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)