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)) #\*)
Loading
Loading full blame...