Skip to content
Snippets Groups Projects
filesys.lisp 42.9 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
toy's avatar
toy committed
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.67 2002/07/10 16:15:58 toy Exp $")
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
			  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 := ".*" | ".~" ([0-9]+ | "*") "~"
ram's avatar
ram committed
;;;
;;; Note: this grammer 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
;;;
;;; - If there is only one dot, it seperates 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.
;;;
;;; Any of these special characters can be preceeded 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 and occurences of \\ from the string because we've already
   checked for whatever they 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 "Backslash in bad place."
	     :namestring namestr
	     :offset (1- end)))
    (shrink-vector result dst)))

(defvar *ignore-wildcards* nil)

(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 "``['' 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)
	 (cond ((or (< (- end start) 5)
		    (char/= (schar namestr (1- end)) #\~))
		(values :newest end))
	       ((and (char= (schar namestr (- end 2)) #\*)
		     (char= (schar namestr (- end 3)) #\~)
		     (char= (schar namestr (- end 4)) #\.))
		(values :wild (- end 4)))
	       (t
		(do ((i (- end 2) (1- i)))
		    ((< i (+ start 2)) (values :newest end))
		  (let ((char (schar namestr i)))
		    (when (eql char #\~)
		      (return (if (char= (schar namestr (1- i)) #\.)
				  (values (parse-integer namestr :start (1+ i)
							 :end (1- end))
					  (1- i))
				  (values :newest end))))
		    (unless (char<= #\0 char #\9)
		      (return (values :newest end))))))))
       (any-version (namestr start end)
	 ;; process end of string looking for a version candidate.
	 (multiple-value-bind (version where)
	   (explicit-version namestr start end)
	   (cond ((not (eq version :newest))
		  (values version where))
		 ((and (>= (- 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)))
    (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) #\/))))
    ;; Next, split the remainder into slash seperated 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
		     (search-list new-start)
		     (maybe-extract-search-list namestr
						(car first) (cdr first))
		   (when search-list
		     (setf absolute t)
		     (setf (car first) new-start))
		   search-list)))))
      (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))
	      (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
					:end1 piece-end)
			       (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)
			 (cons :relative (dirs)))
			(t
			 nil)))
		name
		type
		version)))))

(defun unparse-unix-host (pathname)
  (declare (type pathname pathname)
	   (ignore pathname))
  "Unix")

(defun unparse-unix-piece (thing)
  (etypecase thing
    (simple-string
     (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 "[")
	       (strings (cdr piece))
	       (strings "]"))
	      (t
	       (error "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.
	 ))
      (dolist (dir directory)
	(typecase dir
	  ((member :up)
	   (pieces "../"))
	  ((member :back)
	   (error ":BACK cannot be represented in namestrings."))
	  ((member :wild-inferiors)
	   (pieces "**/"))
	  ((or simple-string pattern)
	   (pieces (unparse-unix-piece dir))
	   (pieces "/"))
	  (t
	   (error "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))
	   (version-supplied (not (or (null version) (eq version :newest)))))
      (when name
	(strings (unparse-unix-piece name)))
      (when type-supplied
	(unless name
	  (error "Cannot specify the type without a file: ~S" pathname))
	(strings ".")
	(strings (unparse-unix-piece type)))
      (when version-supplied
	(strings (if (eq version :wild)
		     (if logical-p ".*" ".~*~")
		     (format nil (if logical-p ".~D" ".~~~D~~")
			     version)))))
    (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 "~S cannot be represented relative to ~S"
		  pathname defaults)))
    (collect ((strings))
      (let* ((pathname-directory (%pathname-directory pathname))
	     (defaults-directory (%pathname-directory defaults))
	     (prefix-len (length defaults-directory))
	     (result-dir
	      (cond ((and (> prefix-len 1)
			  (>= (length pathname-directory) prefix-len)
			  (compare-component (subseq pathname-directory
						     0 prefix-len)
					     defaults-directory))
		     ;; Pathname starts with a prefix of default.  So just
		     ;; use a relative directory from then on out.
		     (cons :relative (nthcdr prefix-len 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 (format nil ".~~~D~~" pathname-version)))
	    (t
	     (lose)))))
      (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-existance t) (follow-links t))
			     &body body)
  (let ((body-name (gensym)))
    `(block nil
       (flet ((,body-name (,var)
		,@body))
	 (%enumerate-matches (pathname ,pathname)
			     ,verify-existance ,follow-links
(defun %enumerate-matches (pathname verify-existance follow-links function)
  (when (pathname-type pathname)
    (unless (pathname-name pathname)
      (error "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-existance follow-links
				   nil function))
	  (:relative
	   (%enumerate-directories "" (cdr directory) pathname
				   verify-existance follow-links
				   nil function)))
	(%enumerate-files "" pathname verify-existance function))))
;;; %enumerate-directories  --   Internal
;;;
;;; The directory node and device numbers are maintained for the current path
;;; during the search for the detection of paths loops upon :wild-inferiors.
;;;
(defun %enumerate-directories (head tail pathname verify-existance
			       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)
		  (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
		    (let ((nodes (cons (cons dev ino) 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)))
	       (with-directory-node-noted (head)
		 (%enumerate-directories (concatenate 'string head "/")
					 (cdr tail) pathname
					 verify-existance follow-links
					 nodes function))))
	    ((member :wild-inferiors)
	     (%enumerate-directories head (rest tail) pathname
				     verify-existance 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-existance 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-existance 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-existance follow-links
					 nodes function))))))
	(%enumerate-files head pathname verify-existance function))))

(defun %enumerate-files (directory pathname verify-existance function)
  (declare (simple-string directory))
  (let ((name (%pathname-name pathname))
	(type (%pathname-type pathname))
	(version (%pathname-version pathname)))
    (cond ((member name '(nil :unspecific))
Loading
Loading full blame...