From: Chris Hanson Date: Tue, 14 May 1991 02:29:09 +0000 (+0000) Subject: * Change save-some-buffers to accept two required arguments. New X-Git-Tag: 20090517-FFI~10592 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ecc3111142e508a75bce3c805cb4d082189da11;p=mit-scheme.git * Change save-some-buffers to accept two required arguments. New second argument, if true, says that we're about to kill the editor. In that case, buffer-local variable buffer-offer-save says what to do with buffers that aren't visiting files. * Change name of initialize-buffer! to normal-mode; this procedure now takes two arguments. The second argument, if false, means use any local variable specifications found in the buffer; otherwise, if inhibit-local-variables is true, the user is asked for confirmation. * Implement variables: file-precious-flag find-file-hooks find-file-not-found-hooks find-file-run-dired write-file-hooks --- diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index f06f7b450..79655ffc6 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.110 1991/05/06 00:57:03 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.111 1991/05/14 02:26:19 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -261,7 +261,7 @@ With argument, saves visited file first." With prefix arg, silently save all file-visiting buffers, then kill." "P" (lambda (no-confirmation?) - (save-some-buffers no-confirmation?) + (save-some-buffers no-confirmation? true) (if (prompt-for-yes-or-no? "Kill Scheme") (begin (set! edwin-finalization @@ -275,7 +275,7 @@ With prefix arg, silently save all file-visiting buffers, then kill." With prefix arg, silently save all file-visiting buffers, then kill." "P" (lambda (no-confirmation?) - (save-some-buffers no-confirmation?) + (save-some-buffers no-confirmation? true) (if (and (or (not (there-exists? (buffer-list) (lambda (buffer) (and (buffer-modified? buffer) diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm index 482e4aca0..d63d3e540 100644 --- a/v7/src/edwin/bufcom.scm +++ b/v7/src/edwin/bufcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.88 1991/05/07 03:10:30 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.89 1991/05/14 02:26:52 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -184,11 +184,12 @@ Reads the new name in the echo area." (rename-buffer (current-buffer) name))) (define-command normal-mode - "Reset mode and local variable bindings to their default values. -Just like what happens when the file is first visited." + "Choose the major mode for this buffer automatically. +Also sets up any specified local variables of the file. +Uses the visited file name, the -*- line, and the local variables spec." () (lambda () - (initialize-buffer! (current-buffer)))) + (normal-mode (current-buffer) false))) (define (save-buffer-changes buffer) (if (and (buffer-pathname buffer) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 3c75a58b5..a3077c9ee 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.152 1991/05/08 22:49:53 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.153 1991/05/14 02:27:13 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -58,7 +58,9 @@ (define (find-file-noselect filename warn?) (let ((pathname (pathname->absolute-pathname (->pathname filename)))) (if (file-directory? pathname) - (make-dired-buffer (pathname-as-directory pathname)) + (if (ref-variable find-file-run-dired) + (make-dired-buffer (pathname-as-directory pathname)) + (editor-error (pathname->string pathname) " is a directory.")) (let ((buffer (pathname->buffer pathname))) (if buffer (begin @@ -68,6 +70,11 @@ (visit-file buffer pathname) buffer)))))) +(define-variable find-file-run-dired + "True says run dired if find-file is given the name of a directory." + true + boolean?) + (define (find-file-revert buffer) (if (not (verify-visited-file-modification-time? buffer)) (let ((pathname (buffer-pathname buffer))) @@ -189,8 +196,17 @@ Argument means don't offer to use auto-save file." (define (read-buffer-interactive buffer pathname visit?) (let ((truename - (catch-file-errors (lambda () false) - (lambda () (read-buffer buffer pathname visit?))))) + (catch-file-errors + (lambda () + (if visit? + (let loop + ((hooks (ref-variable find-file-not-found-hooks buffer))) + (if (and (not (null? hooks)) + (not ((car hooks) buffer))) + (loop (cdr hooks))))) + false) + (lambda () + (read-buffer buffer pathname visit?))))) (let ((pathname (or truename pathname))) (let ((msg (cond ((file-writable? pathname) @@ -207,14 +223,29 @@ Argument means don't offer to use auto-save file." (message msg)))) truename)) +(define-variable find-file-not-found-hooks + "List of procedures to be called for find-file on nonexistent file. +These functions are called as soon as the error is detected. +The functions are called in the order given, +until one of them returns non-false." + '() + list?) + (define (after-find-file buffer pathname) (if (file-writable? pathname) (set-buffer-writeable! buffer) (set-buffer-read-only! buffer)) (setup-buffer-auto-save! buffer) - (initialize-buffer! buffer) + (normal-mode buffer true) + (event-distributor/invoke! (ref-variable find-file-hooks buffer)) (load-find-file-initialization buffer pathname)) +(define-variable find-file-hooks + "Event distributor to be invoked after a buffer is loaded from a file. +The buffer's local variables (if any) will have been processed before the +invocation." + (make-event-distributor)) + (define (load-find-file-initialization buffer pathname) (let ((filename (os/find-file-initialization-filename pathname))) (if (and filename (file-exists? filename)) @@ -290,13 +321,6 @@ If `trim-versions-without-asking' is false, system will query user ((64) 'BACKUP-BOTH) (else false))))) -(define-command save-some-buffers - "Saves some modified file-visiting buffers. Asks user about each one. -With argument, saves all with no questions." - "P" - (lambda (no-confirmation?) - (save-some-buffers no-confirmation?))) - (define (save-buffer buffer backup-mode) (if (buffer-modified? buffer) (begin @@ -312,26 +336,47 @@ With argument, saves all with no questions." "...")) (write-buffer-interactive buffer backup-mode)) (message "(No changes need to be written)"))) + +(define-command save-some-buffers + "Saves some modified file-visiting buffers. Asks user about each one. +With argument, saves all with no questions." + "P" + (lambda (no-confirmation?) + (save-some-buffers no-confirmation? false))) -(define (save-some-buffers #!optional no-confirmation?) +(define (save-some-buffers no-confirmation? exiting?) (let ((buffers - (list-transform-positive (buffer-list) - (lambda (buffer) - (and (buffer-modified? buffer) - (buffer-pathname buffer)))))) + (let ((exiting? (and (not (default-object? exiting?)) exiting?))) + (list-transform-positive (buffer-list) + (lambda (buffer) + (and (buffer-modified? buffer) + (or (buffer-pathname buffer) + (and exiting? + (ref-variable buffer-offer-save buffer) + (> (buffer-length buffer) 0))))))))) (if (null? buffers) - (temporary-message "(No files need saving)") + (message "(No files need saving)") (for-each (if (and (not (default-object? no-confirmation?)) no-confirmation?) (lambda (buffer) (write-buffer-interactive buffer false)) (lambda (buffer) (if (prompt-for-confirmation? - (string-append - "Save file " - (pathname->string (buffer-pathname buffer)))) + (let ((pathname (buffer-pathname buffer))) + (if pathname + (string-append "Save file " + (pathname->string pathname)) + (string-append "Save buffer " + (buffer-name buffer))))) (write-buffer-interactive buffer false)))) buffers)))) + +(define-variable-per-buffer buffer-offer-save + "True in a buffer means offer to save the buffer on exit +even if the buffer is not visiting a file. Automatically local in +all buffers." + false + boolean?) (define-command set-visited-file-name "Change name of file visited in current buffer. diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 085808768..81864e16a 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.98 1991/05/02 01:13:09 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.99 1991/05/14 02:27:42 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -48,6 +48,11 @@ ;;;; Input +(define-variable read-file-message + "If true, messages are displayed when files are read into the editor." + false + boolean?) + (define (read-buffer buffer pathname visit?) (set-buffer-writeable! buffer) (let ((truename (pathname->input-truename pathname))) @@ -69,10 +74,6 @@ (undo-done! (buffer-point buffer)))) truename)) -(define (initialize-buffer! buffer) - (initialize-buffer-modes! buffer) - (initialize-buffer-local-variables! buffer)) - (define (insert-file mark filename) (%insert-file mark @@ -82,22 +83,16 @@ (editor-error "File " (pathname->string pathname) " not found")) truename)))) -(define-variable read-file-message - "If true, messages are displayed when files are read into the editor." - false) - (define (%insert-file mark truename) - (let ((doit - (lambda () - (group-insert-file! (mark-group mark) (mark-index mark) truename)))) - (if (ref-variable read-file-message) - (begin - (temporary-message "Reading file \"" - (pathname->string truename) - "\"") - (doit) - (append-message " -- done")) - (doit)))) + (if (ref-variable read-file-message) + (let ((msg + (string-append "Reading file \"" + (pathname->string truename) + "\"..."))) + (temporary-message msg) + (group-insert-file! (mark-group mark) (mark-index mark) truename) + (temporary-message msg "done")) + (group-insert-file! (mark-group mark) (mark-index mark) truename))) (define (group-insert-file! group index truename) (let ((channel (file-open-input-channel (pathname->string truename)))) @@ -107,10 +102,7 @@ (move-gap-to! group index) (guarantee-gap-length! group length))) (let ((n - (channel-read channel - (group-text group) - index - (+ index length)))) + (channel-read channel (group-text group) index (+ index length)))) (without-interrupts (lambda () (let ((gap-start* (fix:+ index n))) @@ -132,6 +124,10 @@ ;;;; Buffer Mode Initialization +(define (normal-mode buffer find-file?) + (initialize-buffer-modes! buffer) + (initialize-buffer-local-variables! buffer find-file?)) + (define initialize-buffer-modes!) (let () @@ -186,13 +182,22 @@ (define-variable local-variable-search-limit "The maximum number of characters searched when looking for local variables at the end of a file." - 3000) + 3000 + exact-nonnegative-integer?) + +(define-variable inhibit-local-variables + "True means query before obeying a file's local-variables list. +This applies when the local-variables list is scanned automatically +after you find a file. If you explicitly request such a scan with +\\[normal-mode], there is no query, regardless of this variable." + false + boolean?) (define initialize-buffer-local-variables!) (let () (set! initialize-buffer-local-variables! -(named-lambda (initialize-buffer-local-variables! buffer) +(named-lambda (initialize-buffer-local-variables! buffer find-file?) (let ((end (buffer-end buffer))) (let ((start (with-text-clipped @@ -201,9 +206,15 @@ at the end of a file." (lambda () (backward-one-page end))))) (if start (if (re-search-forward "Edwin Variables:[ \t]*" start end true) - (parse-local-variables buffer - (re-match-start 0) - (re-match-end 0)))))))) + (let ((start (re-match-start 0)) + (end (re-match-end 0))) + (if (or (not find-file?) + (not (ref-variable inhibit-local-variables buffer)) + (prompt-for-confirmation? + (string-append + "Set local variables as specified at end of " + (pathname-name-string (buffer-pathname buffer))))) + (parse-local-variables buffer start end))))))))) (define (evaluate sexp) (scode-eval (syntax sexp system-global-syntax-table) @@ -222,13 +233,12 @@ at the end of a file." (define (do-line start end) (define (check-suffix mark) (if (and suffix? (not (match-forward suffix mark))) - (editor-error "Local variables entry is missing the suffix"))) + (editor-error "Local variables entry missing suffix"))) (let ((m1 (horizontal-space-end (if prefix? (or (match-forward prefix start end false) - (editor-error - "Local variables entry is missing the prefix")) + (editor-error "Local variables entry missing prefix")) start)))) (let ((m2 (let ((m2 (char-search-forward #\: m1 end))) @@ -242,9 +252,9 @@ at the end of a file." (lambda (val m4) (check-suffix (horizontal-space-end m4)) (if (string-ci=? var "Mode") - (let ((mode (string-table-get - editor-modes - (extract-string m3 m4)))) + (let ((mode + (string-table-get editor-modes + (extract-string m3 m4)))) (if mode ((if (mode-major? mode) set-buffer-major-mode! @@ -277,7 +287,6 @@ at the end of a file." (loop start)))) - ) ;;;; Output @@ -286,10 +295,11 @@ at the end of a file." "True says silently put a newline at the end whenever a file is saved. Neither false nor true says ask user whether to add a newline in each such case. False means don't add newlines." - false) + false + boolean?) (define-variable make-backup-files - "*Create a backup of each file when it is saved for the first time. + "Create a backup of each file when it is saved for the first time. This can be done by renaming the file or by copying. Renaming means that Edwin renames the existing file so that it is a @@ -305,17 +315,33 @@ The file's owner and group are unchanged. The choice of renaming or copying is controlled by the variables backup-by-copying , backup-by-copying-when-linked and backup-by-copying-when-mismatch ." - true) + true + boolean?) (define-variable backup-by-copying - "*True means always use copying to create backup files. + "True means always use copying to create backup files. See documentation of variable make-backup-files." - false) + false + boolean?) + +(define-variable file-precious-flag + "True means protect against I/O errors while saving files. +Some modes set this true in particular buffers." + false + boolean?) (define-variable trim-versions-without-asking - "*If true, deletes excess backup versions silently. + "True means delete excess backup versions silently. Otherwise asks confirmation." - false) + false + boolean?) + +(define-variable write-file-hooks + "List of procedures to be called before writing out a buffer to a file. +If one of them returns non-false, the file is considered already written +and the rest are not called." + '() + list?) (define (write-buffer-interactive buffer backup-mode) (let ((truename (pathname->output-truename (buffer-pathname buffer)))) @@ -335,21 +361,57 @@ Otherwise asks confirmation." (editor-error "Save not confirmed")) (let ((modes (backup-buffer! buffer truename backup-mode))) (require-newline buffer) - (if (not (or writable? modes)) - (begin - (set! modes (file-modes truename)) - (set-file-modes! truename #o777))) - (write-buffer buffer) + (cond ((let loop ((hooks (ref-variable write-file-hooks buffer))) + (and (not (null? hooks)) + (or ((car hooks) buffer) + (loop (cdr hooks))))) + unspecific) + ((ref-variable file-precious-flag buffer) + (let ((old (os/precious-backup-pathname truename))) + (let ((rename-back? + (catch-file-errors (lambda () false) + (lambda () + (rename-file truename old) + (set! modes (file-modes old)) + true)))) + (dynamic-wind + (lambda () unspecific) + (lambda () + (clear-visited-file-modification-time! buffer) + (write-buffer buffer) + (if rename-back? + (begin + (set! rename-back? false) + (catch-file-errors + (lambda () unspecific) + (lambda () (delete-file old)))))) + (lambda () + (if rename-back? + (begin + (rename-file old truename) + (clear-visited-file-modification-time! + buffer)))))))) + (else + (if (and (not writable?) + (not modes) + (file-exists? truename)) + (bind-condition-handler + (list condition-type:file-error) + (lambda (condition) + condition + (editor-error + "Can't get write permission for file: " + (pathname->string truename))) + (lambda () + (let ((m (file-modes truename))) + (set-file-modes! truename #o777) + (set! modes m))))) + (write-buffer buffer))) (if modes - (call-with-current-continuation - (lambda (continuation) - (bind-condition-handler (list condition-type:error) - (lambda (condition) - condition - (continuation unspecific)) - (lambda () - (set-file-modes! truename modes)))))))))))) - + (catch-file-errors + (lambda () unspecific) + (lambda () (set-file-modes! truename modes)))))))))) + (define (verify-visited-file-modification-time? buffer) (let ((truename (buffer-truename buffer)) (buffer-time (buffer-modification-time buffer))) @@ -359,7 +421,7 @@ Otherwise asks confirmation." (and file-time (< (abs (- buffer-time file-time)) 2)))))) -(define (clear-visited-file-modification-time! buffer) +(define-integrable (clear-visited-file-modification-time! buffer) (set-buffer-modification-time! buffer false)) (define (write-buffer buffer) @@ -378,46 +440,49 @@ Otherwise asks confirmation." (file-modification-time truename)))))) (define-variable enable-emacs-write-file-message - "If true, generate Emacs-style message when writing files." - true + "If true, generate Emacs-style message when writing files. +Otherwise, a message is written both before and after long file writes." + false boolean?) (define (write-region region filename message?) - (let ((filename (canonicalize-output-filename filename))) + (let ((filename (canonicalize-output-filename filename)) + (start (region-start-index region)) + (end (region-end-index region))) (let ((do-it (lambda () - (group-write-to-file (region-group region) - (region-start-index region) - (region-end-index region) - filename)))) + (group-write-to-file (region-group region) start end filename)))) (cond ((not message?) (do-it)) - ((ref-variable enable-emacs-write-file-message) + ((or (ref-variable enable-emacs-write-file-message) + (< (- end start) 50000)) (do-it) (message "Wrote " filename)) (else - (temporary-message "Writing file \"" filename "\"") - (do-it) - (append-message " -- done")))) + (let ((msg (string-append "Writing file " filename "..."))) + (message msg) + (do-it) + (message msg "done"))))) filename)) (define (append-to-file region filename message?) - (let ((filename (canonicalize-overwrite-filename filename))) + (let ((filename (canonicalize-overwrite-filename filename)) + (start (region-start-index region)) + (end (region-end-index region))) (let ((do-it (lambda () - (group-append-to-file (region-group region) - (region-start-index region) - (region-end-index region) - filename)))) + (group-append-to-file (region-group region) start end filename)))) (cond ((not message?) (do-it)) - ((ref-variable enable-emacs-write-file-message) + ((or (ref-variable enable-emacs-write-file-message) + (< (- end start) 50000)) (do-it) (message "Wrote " filename)) (else - (temporary-message "Writing file \"" filename "\"") - (do-it) - (append-message " -- done")))) + (let ((msg (string-append "Writing file " filename "..."))) + (message msg) + (do-it) + (message msg "done"))))) filename)) (define (group-write-to-file group start end filename) @@ -488,7 +553,8 @@ Otherwise asks confirmation." (copy-file truename (string->pathname filename)) false)) (lambda () - (if (or (file-symbolic-link? truename) + (if (or (ref-variable file-precious-flag buffer) + (file-symbolic-link? truename) (ref-variable backup-by-copying buffer) (os/backup-by-copying? truename)) (begin diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 8e4e2c414..b0562b8dd 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.43 1991/05/10 05:14:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.44 1991/05/14 02:29:09 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 43 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 44 '())) \ No newline at end of file diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 53e28d742..92ec06225 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.1 1991/05/08 22:51:35 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.2 1991/05/14 02:28:01 cph Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -158,7 +158,7 @@ w Edit the current message. C-c C-c to return to Rmail." (let ((buffer (current-buffer))) (local-set-variable! mode-line-modified "--- ") (local-set-variable! version-control 'NEVER) - ;;(local-set-variable! file-precious-flag true) + (local-set-variable! file-precious-flag true) (local-set-variable! require-final-newline false) (local-set-variable! rmail-last-file (ref-variable rmail-last-file)) (local-set-variable! diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index 50a087701..033eba49e 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.15 1991/04/21 00:52:35 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.16 1991/05/14 02:28:17 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -46,6 +46,41 @@ (declare (usual-integrations)) +(define-variable backup-by-copying-when-linked + "True means use copying to create backups for files with multiple names. +This causes the alternate names to refer to the latest version as edited. +This variable is relevant only if backup-by-copying is false." + false + boolean?) + +(define-variable backup-by-copying-when-mismatch + "True means create backups by copying if this preserves owner or group. +Renaming may still be used (subject to control of other variables) +when it would not result in changing the owner or group of the file; +that is, for files which are owned by you and whose group matches +the default for a new file created there by you. +This variable is relevant only if Backup By Copying is false." + false + boolean?) + +(define-variable version-control + "Control use of version numbers for backup files. +#T means make numeric backup versions unconditionally. +#F means make them for files that have some already. +'NEVER means do not make them." + false) + +(define-variable kept-old-versions + "Number of oldest versions to keep when a new numbered backup is made." + 2 + exact-nonnegative-integer?) + +(define-variable kept-new-versions + "Number of newest versions to keep when a new numbered backup is made. +Includes the new backup. Must be > 0." + 2 + (lambda (n) (and (exact-integer? n) (> n 0)))) + (define (os/trim-pathname-string string) (let ((end (string-length string))) (let loop ((index end)) @@ -62,6 +97,12 @@ (else (loop (-1+ slash)))))))) +(define (os/pathname->display-string pathname) + (let ((relative (pathname-relative? pathname (home-directory-pathname)))) + (if relative + (string-append "~/" (pathname->string relative)) + (pathname->string pathname)))) + (define (os/auto-save-pathname pathname buffer) (let ((wrap (lambda (name directory) @@ -73,42 +114,8 @@ (wrap (pathname-name-string pathname) (pathname-directory-path pathname))))) -(define (os/pathname->display-string pathname) - (let ((relative (pathname-relative? pathname (home-directory-pathname)))) - (if relative - (string-append "~/" (pathname->string relative)) - (pathname->string pathname)))) - -(define-variable backup-by-copying-when-linked - "*Non-false means use copying to create backups for files with multiple names. -This causes the alternate names to refer to the latest version as edited. -This variable is relevant only if Backup By Copying is false." - false) - -(define-variable backup-by-copying-when-mismatch - "*Non-false means create backups by copying if this preserves owner or group. -Renaming may still be used (subject to control of other variables) -when it would not result in changing the owner or group of the file; -that is, for files which are owned by you and whose group matches -the default for a new file created there by you. -This variable is relevant only if Backup By Copying is false." - false) - -(define-variable version-control - "*Control use of version numbers for backup files. -#T means make numeric backup versions unconditionally. -#F means make them for files that have some already. -'NEVER means do not make them." - false) - -(define-variable kept-old-versions - "*Number of oldest versions to keep when a new numbered backup is made." - 2) - -(define-variable kept-new-versions - "*Number of newest versions to keep when a new numbered backup is made. -Includes the new backup. Must be > 0" - 2) +(define (os/precious-backup-pathname pathname) + (string->pathname (string-append (pathname->string pathname) "#"))) (define (os/backup-buffer? truename) (and (memv (string-ref (vector-ref (file-attributes truename) 8) 0)