Skip to content
Snippets Groups Projects
filesys.lisp 49.5 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Log: code.log; Package: Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: src/code/filesys.lisp $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;; File system interface functions.  This file is pretty UNIX specific.
ram's avatar
ram committed
;;;
;;; Written by William Lott
ram's avatar
ram committed
;;;
;;; **********************************************************************
(export '(truename probe-file user-homedir-pathname directory
          rename-file delete-file file-write-date file-author))
ram's avatar
ram committed

(use-package "EXTENSIONS")

(in-package "EXTENSIONS")
(export '(print-directory complete-file ambiguous-files default-directory
	  purge-backup-files file-writable unix-namestring))
ram's avatar
ram committed

;;;; Unix pathname host support.
ram's avatar
ram committed

;;; Unix namestrings have the following format:
ram's avatar
ram committed
;;;
;;; namestring := [ directory ] [ file [ type [ version ]]]
;;; directory := [ "/" | search-list ] { file "/" }*
;;; search-list := [^:/]*:
;;; file := [^/]*
;;; type := "." [^/.]*
;;; version := ".*" | ".~" ([1-9]+[0-9]* | "*") "~"
ram's avatar
ram committed
;;;
toy's avatar
toy committed
;;; Note: this grammar is ambiguous.  The string foo.bar.~5~ can be parsed
;;; as either just the file specified or as specifying the file, type, and
;;; version.  Therefore, we use the following rules when confronted with
;;; an ambiguous file.type.version string:
ram's avatar
ram committed
;;;
;;; - If the first character is a dot, it's part of the file.  It is not
;;; considered a dot in the following rules.
ram's avatar
ram committed
;;;
toy's avatar
toy committed
;;; - If there is only one dot, it separates the file and the type.
;;;
;;; - If there are multiple dots and the stuff following the last dot
;;; is a valid version, then that is the version and the stuff between
;;; the second to last dot and the last dot is the type.
;;;
;;; Wildcard characters:
;;;
;;; If the directory, file, type components contain any of the following
;;; characters, it is considered part of a wildcard pattern and has the
;;; following meaning.
;;;
;;; ? - matches any character
;;; * - matches any zero or more characters.
;;; [abc] - matches any of a, b, or c.
;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
;;;
toy's avatar
toy committed
;;; Any of these special characters can be preceded by a backslash to
;;; cause it to be treated as a regular character.
ram's avatar
ram committed
;;;

(defun remove-backslashes (namestr start end)
  "Remove any occurrences of \\ from the string because we've already
toy's avatar
toy committed
   checked for whatever may have been backslashed."
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let* ((result (make-string (- end start)))
	 (dst 0)
	 (quoted nil))
    (do ((src start (1+ src)))
	((= src end))
      (cond (quoted
	     (setf (schar result dst) (schar namestr src))
	     (setf quoted nil)
	     (incf dst))
	    (t
	     (let ((char (schar namestr src)))
	       (cond ((char= char #\\)
		      (setq quoted t))
		     (t
		      (setf (schar result dst) char)
		      (incf dst)))))))
    (when quoted
      (error 'namestring-parse-error
	     :complaint (intl:gettext "Backslash in bad place.")
	     :namestring namestr
	     :offset (1- end)))
    (shrink-vector result dst)))

(defvar *ignore-wildcards* nil
  "If non-NIL, Unix shell-style wildcards are ignored when parsing
  pathname namestrings.  They are also ignored when computing
  namestrings for pathname objects.  Thus, *, ?, etc. are not
  wildcards when parsing a namestring, and are not escaped when
  printing pathnames.")

(defun maybe-make-pattern (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (if *ignore-wildcards*
      (subseq namestr start end)
      (collect ((pattern))
	(let ((quoted nil)
	      (any-quotes nil)
	      (last-regular-char nil)
	      (index start))
	  (flet ((flush-pending-regulars ()
		   (when last-regular-char
		     (pattern (if any-quotes
				  (remove-backslashes namestr
						      last-regular-char
						      index)
				  (subseq namestr last-regular-char index)))
		     (setf any-quotes nil)
		     (setf last-regular-char nil))))
	    (loop
	      (when (>= index end)
		(return))
	      (let ((char (schar namestr index)))
		(cond (quoted
		       (incf index)
		       (setf quoted nil))
		      ((char= char #\\)
		       (setf quoted t)
		       (setf any-quotes t)
		       (unless last-regular-char
			 (setf last-regular-char index))
		       (incf index))
		      ((char= char #\?)
		       (flush-pending-regulars)
		       (pattern :single-char-wild)
		       (incf index))
		      ((char= char #\*)
		       (flush-pending-regulars)
		       (pattern :multi-char-wild)
		       (incf index))
		      ((char= char #\[)
		       (flush-pending-regulars)
		       (let ((close-bracket
			      (position #\] namestr :start index :end end)))
			 (unless close-bracket
			   (error 'namestring-parse-error
				  :complaint (intl:gettext "``['' with no corresponding ``]''")
				  :namestring namestr
				  :offset index))
			 (pattern (list :character-set
					(subseq namestr
						(1+ index)
						close-bracket)))
			 (setf index (1+ close-bracket))))
		      (t
		       (unless last-regular-char
			 (setf last-regular-char index))
		       (incf index)))))
	    (flush-pending-regulars)))
	(cond ((null (pattern))
	       "")
	      ((null (cdr (pattern)))
	       (let ((piece (first (pattern))))
		 (typecase piece
		   ((member :multi-char-wild) :wild)
		   (simple-string piece)
		   (t
		    (make-pattern (pattern))))))
;;; extract-name-type-and-version  --  Internal.
;;;
(defun extract-name-type-and-version (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (labels
      ((explicit-version (namestr start end)
	 ;; Look for something like "~*~" at the end of the
	 ;; namestring, where * can be #\* or some digits.  This
	 ;; denotes a version.
rtoy's avatar
rtoy committed
	 ;;(format t "explicit-version ~S ~A ~A~%" namestr start end)
	 (cond ((or (< (- end start) 4)
rtoy's avatar
rtoy committed
		    (and (char/= (schar namestr (1- end)) #\~)
			 (char/= (schar namestr (1- end)) #\*)))
		;; No explicit version given, so return NIL to
		;; indicate we don't want file versions, unless
		;; requested in other ways.
rtoy's avatar
rtoy committed
		;;(format t "case 1: ~A ~A~%" nil end)
rtoy's avatar
rtoy committed
	       ((and (not *ignore-wildcards*)
		     (char= (schar namestr (- end 2)) #\*)
		     (char= (schar namestr (- end 3)) #\~)
		     (char= (schar namestr (- end 4)) #\.))
		;; Found "~*~", so it's a wild version
rtoy's avatar
rtoy committed
		;;(format t "case 2: ~A ~A~%" :wild (- end 4))
		;; Look for a version number.  Start at the end, just
		;; before the ~ and keep looking for digits.  If the
		;; first non-digit is ~, and the leading character is
		;; a non-zero digit, we have a version number, so get
		;; it.  If not, we didn't find a version number, so we
		;; call it :newest
rtoy's avatar
rtoy committed
		    ((< i (+ start 1))
		     ;;(format t "case 3: ~A ~A~%" :newest end)
		     (values :newest end))
		  (let ((char (schar namestr i)))
		    (when (eql char #\~)
		      (return (if (char= (schar namestr (1- i)) #\.)
				  (if (char= (schar namestr (1+ i)) #\0)
				      (values nil end)
				      (values (parse-integer namestr :start (1+ i)
							     :end (1- end))
					      (1- i)))
				  (values :newest end))))
		    (unless (char<= #\0 char #\9)
rtoy's avatar
rtoy committed
		      ;; It's not a digit.  Give up, and say the
		      ;; version is NIL.
		      ;;(format t "case 3 return: ~A ~A~%" nil end)
		      (return (values nil end))))))))
       (any-version (namestr start end)
	 ;; process end of string looking for a version candidate.
	 (multiple-value-bind (version where)
toy's avatar
toy committed
	     (explicit-version namestr start end)
	   (cond ((not (eq version :newest))
		  (values version where))
rtoy's avatar
rtoy committed
		 ((and (not *ignore-wildcards*)
		       (>= (- end 2) start)
		       (char= (schar namestr (- end 1)) #\*)
		       (char= (schar namestr (- end 2)) #\.)
		       (find #\. namestr
			     :start (min (1+ start) (- end 2))
			     :end (- end 2)))
		  (values :wild (- end 2)))
		 (t (values version where)))))
       (any-type (namestr start end)
	 ;; Process end of string looking for a type. A leading "."
	 ;; is part of the name.
	 (let ((where (position #\. namestr
				:start (min (1+ start) end)
				:end end :from-end t)))
	   (when where
	     (values where end))))
       (any-name (namestr start end)
	 (declare (ignore namestr))
	 (values start end)))
toy's avatar
toy committed
    (multiple-value-bind (version vstart)
	(any-version namestr start end)
      (multiple-value-bind (tstart tend)
	  (any-type namestr start vstart)
	(multiple-value-bind (nstart nend)
	    (any-name namestr start (or tstart vstart))
	  (values
	   (maybe-make-pattern namestr nstart nend)
	   (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
	   version))))))
;;; Take a string and return a list of cons cells that mark the char
;;; separated subseq. The first value t if absolute directories location.
;;;
(defun split-at-slashes (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let ((absolute (and (/= start end)
		       (char= (schar namestr start) #\/))))
toy's avatar
toy committed
    ;; Next, split the remainder into slash separated chunks.
	(let ((slash (position #\/ namestr :start start :end end)))
	  (pieces (cons start (or slash end)))
	  (unless slash
      (values absolute (pieces)))))

(defun maybe-extract-search-list (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (let ((quoted nil))
    (do ((index start (1+ index)))
	((= index end)
	 (values nil start))
      (if quoted
	  (setf quoted nil)
	  (case (schar namestr index)
	    (#\\
	     (setf quoted t))
	    (#\:
	     (return (values (remove-backslashes namestr start index)
			     (1+ index)))))))))

(defun parse-unix-namestring (namestr start end)
  (declare (type simple-base-string namestr)
	   (type index start end))
  (multiple-value-bind
      (absolute pieces)
      (split-at-slashes namestr start end)
    (let ((search-list
	   (if absolute
	       nil
	       (let ((first (car pieces)))
		 (multiple-value-bind
toy's avatar
toy committed
		       (search-list new-start)
		     (maybe-extract-search-list namestr
						(car first) (cdr first))
		   (when search-list
rtoy's avatar
rtoy committed
		     ;; Lose if this search-list is already defined as
		     ;; a logical host.  Since the syntax for
		     ;; search-lists and logical pathnames are the
		     ;; same, we can't allow the creation of one when
		     ;; the other is defined.
		     (when (find-logical-host search-list nil)
		       (error (intl:gettext "~A already names a logical host") search-list))
		     (setf absolute t)
		     (setf (car first) new-start))
		   search-list)))))
rtoy's avatar
rtoy committed
      (multiple-value-bind (name type version)
	  (let* ((tail (car (last pieces)))
		 (tail-start (car tail))
		 (tail-end (cdr tail)))
	    (unless (= tail-start tail-end)
	      (setf pieces (butlast pieces))
rtoy's avatar
rtoy committed
	      (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
		     ;; ".." is a directory.  Add this piece to the
		     ;; list of pieces, and make the name/type/version
		     ;; nil.
		     (setf pieces (append pieces (list (cons tail-start tail-end))))
		     (values nil nil nil))
		    ((string= namestr "." :start1 tail-start :end1 tail-end)
		     ;; "." is a directory as well.
		     (setf pieces (append pieces (list (cons tail-start tail-end))))
		     (values nil nil nil))
rtoy's avatar
rtoy committed
		    ((not (find-if-not #'(lambda (c)
					   (char= c #\.))
				       namestr :start tail-start :end tail-end))
		     ;; Got a bunch of dots.  Make it a file of the
		     ;; same name, and type the empty string.
		     (values (subseq namestr tail-start (1- tail-end)) "" nil))
rtoy's avatar
rtoy committed
		    (t
		     (extract-name-type-and-version namestr tail-start tail-end)))))
	;; PVE: Make sure there are no illegal characters in the name
	;; such as #\Null and #\/.
	(when (and (stringp name)
                   (find-if #'(lambda (x)
				(or (char= x #\Null) (char= x #\/)))
			    name))
	  (error 'parse-error))
	;; Now we have everything we want.  So return it.
	(values nil ; no host for unix namestrings.
		nil ; no devices for unix namestrings.
		(collect ((dirs))
		  (when search-list
		    (dirs (intern-search-list search-list)))
		  (dolist (piece pieces)
		    (let ((piece-start (car piece))
			  (piece-end (cdr piece)))
		      (unless (= piece-start piece-end)
			(cond ((string= namestr ".." :start1 piece-start
			       (dirs :up))
			      ((string= namestr "**" :start1 piece-start
					:end1 piece-end)
			       (dirs :wild-inferiors))
			      (t
			       (dirs (maybe-make-pattern namestr
							 piece-start
							 piece-end)))))))
		  (cond (absolute
			 (cons :absolute (dirs)))
			((dirs)
			 ;; "." in a :relative directory is the same
			 ;; as if it weren't there, so remove them.
			 (cons :relative (delete "." (dirs) :test #'equal)))
			 ;; If there is no directory and the name is
			 ;; "." and the type is NIL, we really got
			 ;; directory ".", so make it so.
			 (if (and (equal name ".")
				  (null type))
		;; A file with name "." and type NIL can't be the name
		;; of file on Unix because it's a directory.  This was
		;; handled above, so we can just set the name to nil.
		(if (and (equal name ".")
			 (null type))
		type
		version)))))

(defun unparse-unix-host (pathname)
  (declare (type pathname pathname)
	   (ignore pathname))
  ;; this host designator needs to be recognized as a physical host in
  ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
  ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
  ;; 
  ;; No it isn't - in fact, I'm pretty sure "" is illegal here (and if
  ;; it isn't, it should be - it ought to mean "the default host", from
  ;; *default-pathname-defaults*)  -- P. Foley

(defun unparse-unix-piece (thing)
  (etypecase thing
    ((member :unspecific)
     ;; CLHS 19.2.2.2.3.1 says "That is, both nil and :unspecific
     ;; cause the component not to appear in the namestring."
     "")
     (if *ignore-wildcards*
	 thing
	 (let* ((srclen (length thing))
		(dstlen srclen))
	   (dotimes (i srclen)
	     (case (schar thing i)
		(incf dstlen))))
	   (let ((result (make-string dstlen))
		 (dst 0))
	     (dotimes (src srclen)
	       (let ((char (schar thing src)))
		 (case char
		   ((#\* #\? #\[)
		    (setf (schar result dst) #\\)
		    (incf dst)))
		 (setf (schar result dst) char)
		 (incf dst)))
	     result))))
    (pattern
     (collect ((strings))
       (dolist (piece (pattern-pieces thing))
	 (etypecase piece
	   (simple-string
	    (strings piece))
	   (symbol
	      (:multi-char-wild
	       (strings "*"))
	      (:single-char-wild
	   (cons
	    (case (car piece)
	      (:character-set
	       (strings "[")
	       (error (intl:gettext "Invalid pattern piece: ~S") piece))))))
       (apply #'concatenate
	      'simple-string
	      (strings))))))

(defun unparse-unix-directory-list (directory)
  (declare (type list directory))
  (collect ((pieces))
    (when directory
      (ecase (pop directory)
	(:absolute
	 (cond ((search-list-p (car directory))
		(pieces (search-list-name (pop directory)))
		(pieces ":"))
	       (t
		(pieces "/"))))
	(:relative
	 ;; Nothing special, except if we were given '(:relative).
	 (unless directory
	   (pieces "./"))
	 ))
      (dolist (dir directory)
	(typecase dir
	  ((member :up)
	   (pieces "../"))
	  ((member :back)
	   (error (intl:gettext ":BACK cannot be represented in namestrings.")))
	  ((member :wild-inferiors)
	   (pieces "**/"))
Raymond Toy's avatar
Raymond Toy committed
	  (simple-string
	   (when (zerop (length dir))
	     (error (intl:gettext "Cannot represent \"\" in namestrings.")))
	   (when (string-equal dir "/")
	     (error (intl:gettext "Cannot represent an explicit directory separator in namestrings.")))
	   (pieces (unparse-unix-piece dir))
	   (pieces "/"))
	  ((or pattern (eql :wild))
	   (pieces (unparse-unix-piece dir))
	   (pieces "/"))
	  (t
	   (error (intl:gettext "Invalid directory component: ~S") dir)))))
    (apply #'concatenate 'simple-string (pieces))))

(defun unparse-unix-directory (pathname)
  (declare (type pathname pathname))
  (unparse-unix-directory-list (%pathname-directory pathname)))
(defun unparse-unix-file (pathname)
  (declare (type pathname pathname))
  (collect ((strings))
    (let* ((name (%pathname-name pathname))
	   (type (%pathname-type pathname))
	   (type-supplied (not (or (null type) (eq type :unspecific))))
	   (logical-p (logical-pathname-p pathname))
	   (version (%pathname-version pathname))
rtoy's avatar
rtoy committed
	   ;; Preserve version :newest for logical pathnames.
toy's avatar
toy committed
	   (version-supplied (not (or (null version)
rtoy's avatar
rtoy committed
				      (member version (if logical-p
							  '(:unspecific)
							  '(:newest
							    :unspecific)))))))
	(when (stringp name)
	  (when (find #\/ name)
	    (error (intl:gettext "Cannot specify a directory separator in a pathname name: ~S") name))
	  (when (and (not type-supplied)
		     (find #\. name :start 1))
	    ;; A single leading dot is ok.
	    (error (intl:gettext "Cannot specify a dot in a pathname name without a pathname type: ~S") name))
	  (when (or (and (string= ".." name)
			 (not type-supplied))
		    (and (string= "." name)
			 (not type-supplied)))
	    ;; Can't have a name of ".." or "." without a type.
	    (error (intl:gettext "Invalid value for a pathname name: ~S") name)))
	(strings (unparse-unix-piece name)))
      (when type-supplied
	(unless name
	  (error (intl:gettext "Cannot specify the type without a file: ~S") pathname))
	(when (stringp type)
	  (when (find #\/ type)
	    (error (intl:gettext "Cannot specify a directory separator in a pathname type: ~S") type))
	    (error (intl:gettext "Cannot specify a dot in a pathname type: ~S") type)))
	(strings ".")
	(strings (unparse-unix-piece type)))
      (when (and (not (member version '(nil :newest :unspecific)))
		 (not name))
	;; We don't want version without a name, because when we try
	;; to read #p".~*~" back, the name is "", not NIL.
	(error (intl:gettext "Cannot specify a version without a file: ~S") pathname))
      (when version-supplied
	(strings (if (eq version :wild)
		     (if logical-p ".*" ".~*~")
rtoy's avatar
rtoy committed
		     (format nil (if logical-p ".~A" ".~~~D~~")
    (and (strings) (apply #'concatenate 'simple-string (strings)))))

(defun unparse-unix-namestring (pathname)
  (declare (type pathname pathname))
  (concatenate 'simple-string
	       (unparse-unix-directory pathname)
	       (unparse-unix-file pathname)))

(defun unparse-unix-enough (pathname defaults)
  (declare (type pathname pathname defaults))
  (flet ((lose ()
	   (error (intl:gettext "~S cannot be represented relative to ~S")
    ;; Only the first path in a search-list is considered.
    (enumerate-search-list (pathname pathname)
      (enumerate-search-list (defaults defaults)
	(collect ((strings))
	  (let* ((pathname-directory (%pathname-directory pathname))
		 (defaults-directory (%pathname-directory defaults))
		 (prefix-len (length defaults-directory))
		 (result-dir
		  (cond ((null pathname-directory)
rtoy's avatar
rtoy committed
			 ;; No directory, so relative to default.  But
			 ;; if we're relative to default, NIL is as
			 ;; good as '(:relative) and it results in a
			 ;; shorter namestring.
			 #+nil (list :relative)
			 nil)
			      (>= (length pathname-directory) prefix-len)
			      (compare-component (subseq pathname-directory
							 0 prefix-len)
						 defaults-directory))
			 ;; Pathname starts with a prefix of default,
			 ;; which also means both are either :relative
			 ;; or :absolute directories.  So just use a
			 ;; relative directory from then on out.
			 (let ((dir-tail (nthcdr prefix-len pathname-directory)))
			   ;; If both directories are identical, don't
			   ;; return just :relative.  Returning NIL
			   ;; results in a shorter string.
			   (if dir-tail
			       (cons :relative dir-tail)
			       nil)))
			((and (eq (car pathname-directory) :relative)
			      (not (eq (car defaults-directory) :absolute)))
			 ;; Can't represent a relative directory
			 ;; relative to an absolute directory.  But
			 ;; there's no problem if both are relative;
			 ;; we just return our path.
			 pathname-directory)
			((eq (car pathname-directory) :absolute)
			 ;; We are an absolute pathname, so we can just use it.
			 pathname-directory)
			(t
			 ;; We are a relative directory.  So we lose.
			 (lose)))))
	    (strings (unparse-unix-directory-list result-dir)))
	  (let* ((pathname-version (%pathname-version pathname))
		 (version-needed (and pathname-version
				      (not (eq pathname-version :newest))))
		 (pathname-type (%pathname-type pathname))
		 (type-needed (or version-needed
				  (and pathname-type
				       (not (eq pathname-type :unspecific)))))
		 (pathname-name (%pathname-name pathname))
		 (name-needed (or type-needed
				  (and pathname-name
				       (not (compare-component pathname-name
							       (%pathname-name
								defaults)))))))
	    (when name-needed
	      (unless pathname-name (lose))
	      (strings (unparse-unix-piece pathname-name)))
	    (when type-needed
	      (when (or (null pathname-type) (eq pathname-type :unspecific))
		(lose))
	      (strings ".")
	      (strings (unparse-unix-piece pathname-type)))
	    (when version-needed
	      (typecase pathname-version
		((member :wild)
		 (strings ".~*~"))
		(integer
		 (strings (format nil ".~~~D~~" pathname-version)))
		(t
		 (lose)))))
	  (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings))))))))


(defstruct (unix-host
	    (:include host
		      (:parse #'parse-unix-namestring)
		      (:unparse #'unparse-unix-namestring)
		      (:unparse-host #'unparse-unix-host)
		      (:unparse-directory #'unparse-unix-directory)
		      (:unparse-file #'unparse-unix-file)
		      (:unparse-enough #'unparse-unix-enough)
		      (:customary-case :lower))
	    (:make-load-form-fun make-unix-host-load-form))
  )

(defvar *unix-host* (make-unix-host))

(defun make-unix-host-load-form (host)
  (declare (ignore host))
  '*unix-host*)
ram's avatar
ram committed


;;;; Wildcard matching stuff.

(defmacro enumerate-matches ((var pathname &optional result
				  &key (verify-existence t) (follow-links t))
			     &body body)
  (let ((body-name (gensym)))
    `(block nil
       (flet ((,body-name (,var)
		,@body))
	 (%enumerate-matches (pathname ,pathname)
			     ,verify-existence ,follow-links
(defun %enumerate-matches (pathname verify-existence follow-links function)
  (when (pathname-type pathname)
    (unless (pathname-name pathname)
      (error (intl:gettext "Cannot supply a type without a name:~%  ~S") pathname)))
  (let ((directory (pathname-directory pathname)))
    (if directory
	(ecase (car directory)
	  (:absolute
	   (%enumerate-directories "/" (cdr directory) pathname
				   verify-existence follow-links
	  (:relative
	   (%enumerate-directories "" (cdr directory) pathname
				   verify-existence follow-links
	(%enumerate-files "" pathname verify-existence function))))
;;; %enumerate-directories  --   Internal
;;;
;;; The directory node and device numbers are maintained for the current path
toy's avatar
toy committed
;;; during the search for the detection of path loops upon :wild-inferiors.
(defun %enumerate-directories (head tail pathname verify-existence
			       follow-links nodes function)
  (declare (simple-string head))
  (macrolet ((unix-xstat (name)
	       `(if follow-links
		    (unix:unix-stat ,name)
		    (unix:unix-lstat ,name)))
	     (with-directory-node-noted ((head) &body body)
	       `(multiple-value-bind (res dev ino mode)
		    (unix-xstat ,head)
		  ;; Even if the directory does not exist, we want to
		  ;; continue recursing.
		  (let ((nodes (if (and res (eql (logand mode unix:s-ifmt)
						 unix:s-ifdir))
				   (cons (cons dev ino) nodes)
				   nodes)))
		    ,@body)))
	     (do-directory-entries ((name directory) &body body)
	       `(let ((dir (unix:open-dir ,directory)))
		  (when dir
		    (unwind-protect
			 (loop
			  (let ((,name (unix:read-dir dir)))
			    (cond ((null ,name)
				   (return))
				  ((string= ,name "."))
				  ((string= ,name ".."))
				  (t
				   ,@body))))
		      (unix:close-dir dir))))))
    (if tail
	(let ((piece (car tail)))
	  (etypecase piece
	    (simple-string
	     (let ((head (concatenate 'string head piece)))
	       (%enumerate-directories (concatenate 'string head "/")
				       (cdr tail) pathname
				       verify-existence follow-links
				       nodes function)))
	    ((member :wild-inferiors)
	     (%enumerate-directories head (rest tail) pathname
				     verify-existence follow-links
				     nodes function)
	     (do-directory-entries (name head)
	       (let ((subdir (concatenate 'string head name)))
		 (multiple-value-bind (res dev ino mode)
		     (unix-xstat subdir)
		   (declare (type (or fixnum null) mode))
		   (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
		     (unless (dolist (dir nodes nil)
			       (when (and (eql (car dir) dev)
					  (eql (cdr dir) ino))
				 (return t)))
		       (let ((nodes (cons (cons dev ino) nodes))
			     (subdir (concatenate 'string subdir "/")))
			 (%enumerate-directories subdir tail pathname
						 verify-existence follow-links
						 nodes function))))))))
	    ((or pattern (member :wild))
	     (do-directory-entries (name head)
	       (when (or (eq piece :wild) (pattern-matches piece name))
		 (let ((subdir (concatenate 'string head name)))
		   (multiple-value-bind (res dev ino mode)
		       (unix-xstat subdir)
		     (declare (type (or fixnum null) mode))
		     (when (and res
				(eql (logand mode unix:s-ifmt) unix:s-ifdir))
		       (let ((nodes (cons (cons dev ino) nodes))
			     (subdir (concatenate 'string subdir "/")))
			 (%enumerate-directories subdir (rest tail) pathname
						 verify-existence follow-links
						 nodes function))))))))
	    ((member :up)
	     (let ((head (concatenate 'string head "..")))
	       (with-directory-node-noted (head)
		 (%enumerate-directories (concatenate 'string head "/")
					 (rest tail) pathname
					 verify-existence follow-links
	(%enumerate-files head pathname verify-existence function))))
(defun %enumerate-files (directory pathname verify-existence function)
  (declare (simple-string directory))
  (let ((name (%pathname-name pathname))
	(type (%pathname-type pathname))
	(version (%pathname-version pathname)))
    (cond ((member name '(nil :unspecific))
	   (when (or (not verify-existence)
		     (unix:unix-file-kind directory))
	     (funcall function directory)))
	  ((or (pattern-p name)
	       (pattern-p type)
rtoy's avatar
rtoy committed
	       (eq type :wild)
	       (eq version :wild))
	   (let ((dir (unix:open-dir directory)))
		     (let ((file (unix:read-dir dir)))
			   (unless (or (string= file ".")
				       (string= file ".."))
			     (multiple-value-bind
				 (file-name file-type file-version)
				 (let ((*ignore-wildcards* t))
				   (extract-name-type-and-version
				    file 0 (length file)))
			       ;; Match also happens if the file has
			       ;; no explicit version and we're asking
			       ;; for version :NEWEST, since that's
			       ;; what no version means.
			       (when (and (components-match file-name name)
					  (components-match file-type type)
					  (or (components-match file-version
								version)
					      (and (eq file-version nil)
						   (eq version :newest))))
				 (funcall function
					  (concatenate 'string
						       directory
						       file)))))
		 (unix:close-dir dir)))))
	  (t
	   (let ((file (concatenate 'string directory name)))
	     (unless (or (null type) (eq type :unspecific))
	       (setf file (concatenate 'string file "." type)))
	     (unless (member version '(nil :newest :wild :unspecific))
	       (setf file (concatenate 'string file ".~"
				       (quick-integer-to-string version)
				       "~")))
	     (when (or (not verify-existence)
		       (unix:unix-file-kind file t))
	       (funcall function file)))))))
ram's avatar
ram committed

(defun quick-integer-to-string (n)
  (cond ((not (fixnump n))
	 (write-to-string n :base 10 :radix nil))
	((zerop n) "0")
ram's avatar
ram committed
	((eql n 1) "1")
	((minusp n)
	 (concatenate 'simple-string "-"
		      (the simple-string (quick-integer-to-string (- n)))))
	(t
	 (do* ((len (1+ (truncate (integer-length n) 3)))
	       (res (make-string len))
	       (i (1- len) (1- i))
	       (q n)
	       (r 0))
	      ((zerop q)
	       (incf i)
	       (replace res res :start2 i :end2 len)
	       (shrink-vector res (- len i)))
ram's avatar
ram committed
	   (declare (simple-string res)
ram's avatar
ram committed
	   (multiple-value-setq (q r) (truncate q 10))
	   (setf (schar res i) (schar "0123456789" r))))))

(defun unix-namestring (pathname &optional (for-input t) executable-only)
  "Convert PATHNAME into a string that can be used with UNIX system calls.
   Search-lists and wild-cards are expanded. If optional argument
   FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned.
   If optional argument EXECUTABLE-ONLY is true, NIL is returned
   unless an executable version of PATHNAME exists."
ram's avatar
ram committed
  ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
  ;; pathnames too.
  (let ((path (let ((lpn (pathname pathname)))
		(if (logical-pathname-p lpn)
		    (namestring (translate-logical-pathname lpn))
		    pathname))))
ram's avatar
ram committed
      (pathname path)
      (enumerate-matches (name pathname nil :verify-existence for-input
	(when (or (not executable-only)
		  (and (eq (unix:unix-file-kind name) :file)
		       (unix:unix-access name unix:x_ok)))
	  (names name)))
      (let ((names (names)))
	(when names
	  (when (cdr names)
		   :format-control (intl:gettext "~S is ambiguous:~{~%  ~A~}")
		   :format-arguments (list pathname names)))
ram's avatar
ram committed
	  (return (car names))))))))
ram's avatar
ram committed


;;;; TRUENAME and PROBE-FILE.
ram's avatar
ram committed

;;; Truename  --  Public
;;;
;;; Another silly file function trivially different from another function.
ram's avatar
ram committed
;;;
(defun truename (pathname)
  "Return the pathname for the actual file described by the pathname
  An error of type file-error is signalled if no such file exists,
  or the pathname is wild."
  (if (wild-pathname-p pathname)
      (error 'simple-file-error
	     :format-control (intl:gettext "Bad place for a wild pathname.")
	     :pathname pathname)
      (let ((result (probe-file pathname)))
	(unless result
	  (error 'simple-file-error
		 :format-control (intl:gettext "The file ~S does not exist.")
		 :format-arguments (list (namestring pathname))))
	result)))
ram's avatar
ram committed

;;; Probe-File  --  Public
;;;
toy's avatar
toy committed
;;; If PATHNAME exists, return its truename, otherwise NIL.
ram's avatar
ram committed
;;;
(defun probe-file (pathname)
  "Return a pathname which is the truename of the file if it exists, NIL
toy's avatar
toy committed
  otherwise. An error of type file-error is signalled if pathname is wild."
  (if (wild-pathname-p pathname)
      (error 'simple-file-error 
	     :format-control (intl:gettext "Bad place for a wild pathname."))
      (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
	(when (and namestring (unix:unix-file-kind namestring))
	  (let ((truename (unix:unix-resolve-links
			   (unix:unix-maybe-prepend-current-directory
			    namestring))))
	    (when truename
	      (let ((*ignore-wildcards* t))
		(pathname (unix:unix-simplify-pathname truename)))))))))
ram's avatar
ram committed


;;;; Other random operations.
ram's avatar
ram committed

;;; Rename-File  --  Public
;;;
(defun rename-file (file new-name)
  "Rename File to have the specified New-Name.  If file is a stream
  open to a file, then the associated file is renamed.

  Three values are returned if successful: the defaulted new name
  composed of New-Name with missing components filled in from File;
  the truename of File before it was renamed; the new truename of the
  File after it was renamed."
  (let* ((original (truename file))
	 (original-namestring (unix-namestring original t))
	 (new-name (merge-pathnames new-name file))
	 (new-namestring (unix-namestring new-name nil)))
      (error 'simple-file-error
	     :format-control (intl:gettext "~S can't be created.")
	     :format-arguments (list new-name)))
    (multiple-value-bind (res error)
			 (unix:unix-rename original-namestring
	(error 'simple-file-error
	       :format-control (intl:gettext "Failed to rename ~A to ~A: ~A")
	       :format-arguments (list original new-name
				       (unix:get-unix-error-msg error))))
      (when (streamp file)
	(file-name file new-namestring))
      (values new-name original (truename new-name)))))
ram's avatar
ram committed

;;; Delete-File  --  Public
;;;
;;;    Delete the file, Man.
;;;
(defun delete-file (file)
  "Delete the specified file."
rtoy's avatar
rtoy committed
  (let ((namestring (unix-namestring (merge-pathnames file) t)))
ram's avatar
ram committed
    (when (streamp file)
      ;; Close the file, but don't try to revert or anything.  We want
      ;; to delete it, man!
      (close file))
      (error 'simple-file-error
	     :format-control (intl:gettext "~S doesn't exist.")
	     :format-arguments (list file)))
    (multiple-value-bind (res err) (unix:unix-unlink namestring)
	(error 'simple-file-error
	       :format-control (intl:gettext "Could not delete ~A: ~A.")
	       :format-arguments (list namestring
				       (unix:get-unix-error-msg err))))))
ram's avatar
ram committed
  t)
;;; Purge-Backup-Files  --  Public
toy's avatar
toy committed
;;;