From: Stephen Adams Date: Fri, 7 Oct 1994 19:59:53 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: 20090517-FFI~7087 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fe6d7fb98c2d84a5814a35d8372032f062f43608;p=mit-scheme.git *** empty log message *** --- diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index ef1d08b5c..8aee70ad0 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -110,11 +110,9 @@ Includes the new backup. Must be > 0." (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) @@ -128,7 +126,7 @@ Includes the new backup. Must be > 0." (if (char-set-member? os/expand-char-set (string-ref string before)) before - (fix:1+ before))))) + (fix:+ before 1))))) (else string))))) @@ -139,50 +137,74 @@ Includes the new backup. Must be > 0." (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)))))))) -(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 + (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))) @@ -222,59 +244,69 @@ Includes the new backup. Must be > 0." (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)))))))) (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 "")) @@ -313,18 +345,15 @@ Includes the new backup. Must be > 0." (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))) @@ -418,26 +447,22 @@ Includes the new backup. Must be > 0." #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))) + +;;;; Scheme version of ls (define (generate-dired-listing! pathname point) (let ((files (directory-read (->namestring (merge-pathnames pathname))))) @@ -468,10 +493,8 @@ Includes the new backup. Must be > 0." (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)) @@ -480,7 +503,9 @@ Includes the new backup. Must be > 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)