[Import fname.scm from scsh
clinton@unknownlamer.org**20100417035308
 Ignore-this: 47faf9a0d4dce68965d0919649f62d47
] addfile ./module/scsh/filenames.scm
hunk ./module/scsh/filenames.scm 1
+;;; Code for processing Unix file names.
+;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
+;;; See file COPYING
+
+;;; 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)))
+               (if (null? (cdr pathlist)) ; special case for 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))))
+
+
+
+
+