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
;;; -*-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
;;;
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
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)
;;; -*-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
;;;
(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)))
\f
(define (save-buffer-changes buffer)
(if (and (buffer-pathname buffer)
;;; -*-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
;;;
(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
(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)))
(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)
(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))
+\f
(define (load-find-file-initialization buffer pathname)
(let ((filename (os/find-file-initialization-filename pathname)))
(if (and filename (file-exists? filename))
((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
"..."))
(write-buffer-interactive buffer backup-mode))
(message "(No changes need to be written)")))
+\f
+(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?)
\f
(define-command set-visited-file-name
"Change name of file visited in current buffer.
;;; -*-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
;;;
\f
;;;; 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)))
(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
(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))))
(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)))
\f
;;;; 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 ()
(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
(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)
(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)))
(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!
(loop start))))
-
)
\f
;;;; Output
"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
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?)
\f
(define (write-buffer-interactive buffer backup-mode)
(let ((truename (pathname->output-truename (buffer-pathname buffer))))
(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))))))))))
+\f
(define (verify-visited-file-modification-time? buffer)
(let ((truename (buffer-truename buffer))
(buffer-time (buffer-modification-time buffer)))
(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)
(file-modification-time truename))))))
\f
(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)
(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
#| -*-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
(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
;;; -*-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
;;;
(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!
;;; -*-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
;;;
(declare (usual-integrations))
\f
+(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))))
+\f
(define (os/trim-pathname-string string)
(let ((end (string-length string)))
(let loop ((index end))
(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)
(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)
projects / mit-scheme.git / commitdiff