scsh-0.6/scsh/fname.scm

;;; Code for processing Unix file names.
;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.

;;; We adhere to Posix file name rules, plus we treat files beginning with
;;; ~ as absolute paths.

;;; Relevant bits of CScheme:
;;;    pathnm sfile strnin unxcwd unxdir unxpar unxprm unxpth unxunp wrkdir

(define (file-name-directory? fname)
  (or (string=? fname "")			; Note! "" is directory (cwd)
      (char=? #\/ (string-ref fname (- (string-length fname) 1)))))

(define (file-name-non-directory? fname)
  (or (string=? fname "")			; and file-name (root).
      (not (char=? #\/ (string-ref fname (- (string-length fname) 1))))))

(define (file-name-as-directory fname)
  (if (string=? fname ".")
      ""
      (let ((len (string-length fname)))
	(if (and (> len 0)
		 (char=? #\/ (string-ref fname (- len 1))))
	    fname
	    (string-append fname "/")))))


;;; Return #f if str doesn't contain a slash at all.
(define (last-non-slash str)
  (let lp ((i (- (string-length str) 1)))
    (and (>= i 0)
	 (if (char=? #\/ (string-ref str i))
	     (lp (- i 1))
	     i))))

(define (directory-as-file-name fname)
  (let ((len (string-length fname)))
    (if (zero? len)
	"."		; "" -> "."
	;; Trim trailing slashes.
	(cond ((last-non-slash fname) =>
	       (lambda (i)
		 (if (= i (- len 1))
		     fname ; No slash.
		     (substring fname 0 (+ i 1))))) ; Trim slashes.

	      ;;; Solid slashes -- invoke weird Posix rule.
	      (else (if (= len 2) "//" "/"))))))


(define (ensure-file-name-is-directory fname)
  (if (string=? fname "")
      ""
      (file-name-as-directory fname)))


(define (ensure-file-name-is-nondirectory fname)
  (if (string=? fname "")
      ""
      (directory-as-file-name fname)))


(define (file-name-absolute? fname)
  (or (= (string-length fname) 0)
      (char=? #\/ (string-ref fname 0))
      (char=? #\~ (string-ref fname 0))))


;;; Returns FNAME's directory component in *directory form.*
(define (file-name-directory fname)
  (cond ((string-index-right fname #\/) =>
	 (lambda (rslash)
	   (if (last-non-slash fname)
	       (substring fname 0 (+ 1 rslash))
	       ""))) ; Posix strangeness: solid slashes are root.
	(else "")))


(define (file-name-nondirectory fname)
  (cond ((string-index-right fname #\/) =>
	 (lambda (rslash)
	   (if (last-non-slash fname)
	       (substring fname (+ 1 rslash) (string-length fname))
	       fname)))	; Posix strangeness: solid slashes are root.
	(else fname)))

    
(define (split-file-name fname)
  (let* ((fname (ensure-file-name-is-nondirectory fname))
	 (len (string-length fname)))
    (let split ((start 0))
      (cond ((>= start len) '())
	    ((string-index fname #\/ start) =>
	     (lambda (slash)
	       (cons (substring fname start slash)
		     (split (+ slash 1)))))
	    (else (list (substring fname start len)))))))


(define (path-list->file-name pathlist . maybe-dir)
  (let ((root (ensure-file-name-is-nondirectory (:optional maybe-dir ".")))
	;; Insert slashes *between* elts of PATHLIST.
	(w/slashes (if (pair? pathlist)
		       (let insert-slashes ((pathlist pathlist))
			 (let ((elt (car pathlist))
			       (pathlist (cdr pathlist)))
			   (cons elt (if (pair? pathlist)
					 (cons "/" (insert-slashes pathlist))
					 '()))))
		       '(""))))
    (apply string-append
	   (if (and (pair? pathlist)
		    (string=? "" (car pathlist)))
	       w/slashes ; Absolute path not relocated.
	       (cons (file-name-as-directory root) w/slashes)))))
		   

(define (parse-file-name fname)
  (let ((nd (file-name-nondirectory fname)))
    (values (file-name-directory fname)
	    (file-name-sans-extension nd)
	    (file-name-extension nd))))


;;; Return the index of the . separating the extension from the rest of
;;; the file name. If no extension, returns an index pointing off the
;;; end of the string, i.e. (string-length fname). "Dot-files," such as
;;; /usr/shivers/.login are not considered extensions.

(define (file-name-extension-index fname)
  (let ((dot (string-index-right fname #\.))
	(slash (string-index-right fname #\/)))
    (if (and dot
	     (> dot 0)
	     (if slash (> dot slash) #t)
	     (not (char=? #\/ (string-ref fname (- dot 1)))))
	dot
	(string-length fname))))

(define (file-name-sans-extension fname)
  (substring fname 0 (file-name-extension-index fname)))

(define (file-name-extension fname)
  (substring fname (file-name-extension-index fname)
	           (string-length fname)))

(define (replace-extension fname ext)
  (string-append (file-name-sans-extension fname) ext))

;;; - Remove leading and internal occurrences of dot. A trailing dot
;;;   is left alone, in case the parent is a symlink.
;;; - Remove internal and trailing double-slashes. A leading double-slash
;;;   is left alone, in accordance w/Posix. However, triple and more leading
;;;   slashes are reduced to a single slash, in accordance w/Posix.
;;; - Double-dots are left alone, in case they come after symlinks.

(define (simplify-file-name fname)
  ;; First, we simplify leading multiple slashes:
  ;; 1 or >2 slashes -> /, 2 slashes -> //
  (receive (slashes fname)
	   (let ((len (string-length fname)))
	     (if (and (> len 0) (char=? #\/ (string-ref fname 0)))
		 (let ((j (let lp ((i 1)) ; j is index of first non-slash.
			    (if (and (< i len)
				     (char=? (string-ref fname i) #\/))
				(lp (+ i 1))
				i))))
		   (if (< j 3)
		       (values (substring fname 0 j); One or two slashes - OK.
			       (substring fname j len))
		       (values "/" (substring fname (- j 1) len))))
		 (values "" fname)))

    ;; At this point, all leading slashes have been pulled off of FNAME.
    ;; Any remaining repeated slashes are fair game for removal.
    (let* ((path-list (split-file-name fname))
	   (ans (if (pair? path-list)
		    (reverse (let lp ((path-list path-list)
				      (ans (list slashes)))
			       (let ((elt (car path-list))
				     (path-list (cdr path-list)))
				 (if (pair? path-list)
				     (lp path-list
					 (if (or (string=? "." elt) ; kill .
						 (string=? "" elt)) ; and //
					     ans
					     `("/" ,elt ,@ans)))
				     (cons elt ans)))))
		    (list slashes))))
      (apply string-append ans))))