;;; -*-Scheme-*-
;;;
-;;; $Id: dos.scm,v 1.14 1994/03/16 23:26:47 cph Exp $
+;;; $Id: dos.scm,v 1.15 1994/10/07 19:59:53 adams Exp $
;;;
;;; Copyright (c) 1992-1994 Massachusetts Institute of Technology
;;;
(define (trim-for-duplicate-device string)
(let ((end (string-length string))
(sep (char-set-union (char-set #\:)
- (char-set-union
- os/expand-char-set
- os/directory-char-set))))
- (let ((colon
- (substring-find-previous-char string 0 end #\:)))
+ (char-set-union os/expand-char-set
+ os/directory-char-set))))
+ (let ((colon (substring-find-previous-char string 0 end #\:)))
(cond ((or (not colon) (zero? colon))
string)
((and (fix:< (fix:1+ colon) end)
(if (char-set-member? os/expand-char-set
(string-ref string before))
before
- (fix:1+ before)))))
+ (fix:+ before 1)))))
(else
string)))))
(define (os/filename->display-string filename)
(let ((name (string-copy filename)))
- (slash->backslash! name)
+ (let ((end (string-length name)))
+ (let loop ((index 0))
+ (let ((slash (substring-find-next-char name index end #\/)))
+ (if slash
+ (begin
+ (string-set! name slash #\\)
+ (loop (1+ slash)))))))
name))
-
-(define (slash->backslash! name)
- (let ((end (string-length name)))
- (let loop ((index 0))
- (let ((slash (substring-find-next-char name index end #\/)))
- (if (not slash)
- '()
- (begin
- (string-set! name slash #\\)
- (loop (1+ slash))))))))
\f
-(define (file-type->version type version)
+(define version-fill-char #\~ )
+(define version-radix 10)
+
+(define (file-name->version name version)
(let ((version-string
(and (fix:fixnum? version)
- (number->string (fix:remainder version 1000)))))
+ (number->string version version-radix))))
(if (not version-string)
(error "Illegal version" version)
- (let ((version-string
- (string-pad-left version-string 3 #\0)))
- (if (string? type)
- (if (fix:> (string-length type) 0)
- (string-append (substring type 0 1)
- (substring version-string 1 3))
- version-string)
+ (let* ((digits (string-length version-string))
+ (version-string
+ (string-append (string version-fill-char) version-string)))
+ (if (string? name)
+ (let ((cut-point (min (string-length name) (- 8 digits 1))))
+ (string-append (substring name 0 cut-point)
+ version-string))
version-string)))))
-(define (filename->version-number filename)
- (let ((type (pathname-type filename)))
- (and (string? type)
- (fix:= (string-length type) 3)
- (or (string->number type)
- (string->number (substring type 1 3))))))
+(define (filename->version-number-index name) ; string->#F or integer
+ (and (string? name)
+ (let loop ((i (- (string-length name) 1))
+ (first-digit #F))
+ (cond ((< i 0) #F)
+ ((char->digit (string-ref name i) version-radix)
+ (loop (- i 1) i))
+ ((and first-digit (char=? (string-ref name i) version-fill-char))
+ first-digit)
+ (else #F)))))
+(define (filename+index->version-number name first-digit)
+ (substring->number name first-digit (string-length name)))
+
+(define (filename->version-number filename)
+ (let ((name (pathname-name filename)))
+ (let ((first-digit (filename->version-number-index name)))
+ (and first-digit
+ (filename+index->version-number name first-digit)))))
+
+(define (plausible-backup? name possible-backup) ; both filename strings
+ ;; "foolish" "foolis76" -> #F
+ ;; "foolish" "fooli~76" -> #T
+ ;; "f" "f~76" -> #T
+ ;; "f" "foo~76" -> #F
+ (let ((index (filename->version-number-index possible-backup)))
+ (and index
+ (let ((end (min (string-length name) (- index 1))))
+ (and (substring-ci=? name 0 end possible-backup 0 end)
+ (or (= (string-length possible-backup) 8) ; truncated
+ (= end (string-length name)))))))) ; or exact match
+\f
(define (os/auto-save-pathname pathname buffer)
buffer
- (pathname-new-type pathname
- (file-type->version (pathname-type pathname) 0)))
+ (pathname-new-name pathname
+ (file-name->version (pathname-name pathname) 0)))
(define (os/precious-backup-pathname pathname)
;; Use the autosave name for the precious backup
- (pathname-new-type pathname
- (file-type->version (pathname-type pathname) 0)))
+ (pathname-new-name pathname
+ (file-name->version (pathname-name pathname) 0)))
(define (os/backup-buffer? truename)
(let ((attrs (file-attributes truename)))
(define (os/buffer-backup-pathname truename)
(let ((directory (directory-namestring truename))
- (type (pathname-type truename))
- (filename (pathname-name truename)))
+ (type (pathname-type truename))
+ (filename (pathname-name truename)))
(define (no-versions)
- (values (pathname-new-type truename (file-type->version type 0)) '()))
+ (values (version->pathname 0) '()))
(define (version->pathname version)
- (pathname-new-type truename (file-type->version type version)))
- (define (files->versions files)
+ (pathname-new-name truename (file-name->version filename version)))
+
+ (define (find-plausible-backups)
+ ;; all existing files of the form XXXX~NN.YYY where XXXX and YYY match
+ ;; truename
+ (let* ((plen (min (string-length filename)
+ (- 8 5))) ; max version is 99999
+ (pattern (string-append directory
+ (string-head filename plen)
+ "*." type))
+ (pathnames (directory-read pattern)))
+ (let loop ((pathnames pathnames)
+ (found '()))
+ ;; pathnames all have the form XXX*.YYY
+ (if (null? pathnames)
+ found
+ (let* ((pathname (car pathnames)))
+ (if (plausible-backup? filename (pathname-name pathname))
+ (loop (cdr pathnames)
+ (cons (file-namestring pathname) found))
+ (loop (cdr pathnames) found)))))))
+
+ (define (files->versions files accum)
(if (or (not files) (null? files))
- '()
- (let ((type-number (filename->version-number (car files))))
- (if type-number
- (cons type-number (files->versions (cdr files)))
- (files->versions (cdr files))))))
-
+ accum
+ (let ((number (filename->version-number (car files))))
+ (if number
+ (files->versions (cdr files) (cons number accum))
+ (files->versions (cdr files) accum)))))
+
(if (eq? 'NEVER (ref-variable version-control))
(no-versions)
- (let ((search-name (string-append filename ".")))
- (let ((filenames
- (os/directory-list-completions directory search-name)))
- (let ((versions (sort (files->versions filenames) <)))
- (let ((high-water-mark (apply max (cons 0 versions))))
- (if (or (ref-variable version-control)
- (positive? high-water-mark))
- (values
- (version->pathname (+ high-water-mark 1))
- (let ((start (ref-variable kept-old-versions))
- (end (fix:- (length versions)
- (fix:-1+
- (ref-variable kept-new-versions)))))
- (if (fix:< start end)
- (map version->pathname
- (sublist versions start end))
- '())))
- (no-versions)))))))))
+ (let ((filenames (find-plausible-backups)))
+ (let ((versions (sort (files->versions filenames '() ) <)))
+ (let ((high-water-mark (reduce max 0 versions)))
+ (if (or (ref-variable version-control)
+ (positive? high-water-mark))
+ (values
+ (version->pathname (+ high-water-mark 1))
+ (let ((start (ref-variable kept-old-versions))
+ (end (- (length versions)
+ (1+ (ref-variable kept-new-versions)))))
+ (if (fix:< start end)
+ (map version->pathname
+ (sublist versions start end))
+ '())))
+ (no-versions))))))))
\f
(define (os/directory-list-completions directory prefix)
(define (->directory-namestring s)
(->namestring (pathname-as-directory (->pathname s))))
- (define (->directory-wildcard s)
- (string-append (->directory-namestring s)
- "*.*"))
-
- (let ((plen (string-length prefix)))
- (let loop ((pathnames (directory-read (->directory-wildcard directory))))
- (if (null? pathnames)
- '()
- (let ((filename (file-namestring (car pathnames))))
- (if (and (fix:>= (string-length filename) plen)
- (string-ci=? prefix (substring filename 0 plen)))
- (cons filename (loop (cdr pathnames)))
- (loop (cdr pathnames))))))))
+ (map file-namestring
+ (directory-read
+ (string-append (->directory-namestring directory) ; "d:\\xxx\\yy\\"
+ prefix
+ (if (string-find-next-char prefix #\.) "*" "*.*")))))
(define (os/directory-list directory)
(os/directory-list-completions directory ""))
(fix:> version 0))))
(define (os/numeric-backup-filename? filename)
- (let ((type (pathname-type filename)))
- (and (string? type)
- (fix:= (string-length type) 3)
- (let ((version (string->number type)))
- (and version
- (cons (->namestring (pathname-new-type filename #f))
- version)))
- (let ((version (substring->number type 1 3)))
- (and version
- (cons (->namestring (pathname-new-type filename
- (string-head type 1)))
- version))))))
+ (let ((name (pathname-name filename)))
+ (and (string? name)
+ (let ((index (filename->version-number-index name)))
+ (and index
+ (cons (->namestring
+ (pathname-new-name filename
+ (string-head name (- index 1))))
+ (filename+index->version-number name index)))))))
+
(define (os/auto-save-filename? filename)
(let ((version (filename->version-number filename)))
#f
false?)
-(define (insert-directory! file switches mark type)
+(define (read-directory pathname switches mark)
switches ; ignored
- ;; Insert directory listing for FILE at MARK.
- ;; TYPE can have one of three values:
- ;; 'WILDCARD means treat FILE as shell wildcard.
- ;; 'DIRECTORY means FILE is a directory and a full listing is expected.
- ;; 'FILE means FILE itself should be listed, and not its contents.
- ;; SWITCHES are ignored.
- (case type
- ((WILDCARD)
- (generate-dired-listing! file mark))
- ((DIRECTORY)
- (generate-dired-listing!
- (string-append (->namestring (pathname-as-directory file))
- "*.*")
- mark))
- (else
- (generate-dired-entry! file mark))))
-
-;;; Scheme version of ls
+ (if (file-directory? pathname)
+ (generate-dired-listing!
+ (string-append (->namestring (pathname-as-directory pathname))
+ "*.*")
+ mark)
+ (generate-dired-listing! pathname mark)))
+
+(define (insert-dired-entry! pathname directory lstart)
+ directory ; ignored
+ (let ((start (mark-left-inserting lstart)))
+ (insert-string " " start)
+ (generate-dired-entry! pathname start)))
+\f
+;;;; Scheme version of ls
(define (generate-dired-listing! pathname point)
(let ((files (directory-read (->namestring (merge-pathnames pathname)))))
(string-pad-right ; Mod time
(file-attributes/ls-time-string attr) 26 #\Space)
name)))
- (let ((point (mark-left-inserting-copy point)))
- (insert-string entry point)
- (insert-newline point)
- (mark-temporary! point)))))
+ (insert-string entry point)
+ (insert-newline point))))
(define-integrable (dummy-file-attributes)
'#(#f 0 0 0 0 0 0 0 "----------" 0))
true)
(define (os/quit dir)
- (with-real-working-directory-pathname dir %quit))
+ (without-interrupts
+ (lambda ()
+ (with-real-working-directory-pathname dir %quit))))
(define (with-real-working-directory-pathname dir thunk)
(let ((inside dir)
projects / mit-scheme.git / commitdiff