;;; -*-Scheme-*-
;;;
-;;; $Id: dos.scm,v 1.26 1995/07/11 23:10:41 cph Exp $
+;;; $Id: dos.scm,v 1.27 1995/09/13 23:00:53 cph Exp $
;;;
;;; Copyright (c) 1992-95 Massachusetts Institute of Technology
;;;
pathname))))
(define (os/read-file-methods) '())
-
(define (os/write-file-methods) '())
+(define (os/alternate-pathnames group pathname) group pathname '())
\f
;;;; Dired customization
;;; -*-Scheme-*-
;;;
-;;; $Id: filcom.scm,v 1.186 1995/07/11 23:19:30 cph Exp $
+;;; $Id: filcom.scm,v 1.187 1995/09/13 23:00:55 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology
;;;
(ref-variable find-file-not-found-hooks buffer)
(cdr hooks)))
((or (null? hooks)
- ((car hooks) buffer)))))
+ ((car hooks) buffer))))
+ (maybe-change-buffer-name! buffer pathname))
(after-find-file buffer error? warn?))
buffer))))))
+(define (maybe-change-buffer-name! buffer pathname)
+ (let ((name (pathname->buffer-name pathname))
+ (name* (pathname->buffer-name (buffer-pathname buffer))))
+ (if (not (string=? name name*))
+ (rename-buffer buffer (new-buffer-name name*)))))
+
(define (after-find-file buffer error? warn?)
(let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
(let ((buffer-read-only?
;;; -*-Scheme-*-
;;;
-;;; $Id: fileio.scm,v 1.128 1995/09/13 03:57:14 cph Exp $
+;;; $Id: fileio.scm,v 1.129 1995/09/13 23:00:58 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+;;;; Special File I/O Methods
+
+(define (r/w-file-methods? objects)
+ (and (list? objects)
+ (for-all? objects
+ (lambda (object)
+ (and (pair? object)
+ (procedure? (car object))
+ (procedure? (cdr object)))))))
+
+(define-variable read-file-methods
+ "List of alternate methods to be used for reading a file into a buffer.
+Each method is a pair of a predicate and a procedure. The methods are
+tried, in order, until one of the predicates is satisfied, at which
+point the corresponding procedure is used to read the file. If none
+of the predicates is satisfied, the file is read in the usual way."
+ (os/read-file-methods)
+ r/w-file-methods?)
+
+(define-variable write-file-methods
+ "List of alternate methods to be used for writing a file into a buffer.
+Each method is a pair of a predicate and a procedure. The methods are
+tried, in order, until one of the predicates is satisfied, at which
+point the corresponding procedure is used to write the file. If none
+of the predicates is satisfied, the file is written in the usual way."
+ (os/write-file-methods)
+ r/w-file-methods?)
+
+(define (read-file-method group pathname)
+ (let loop ((methods (ref-variable read-file-methods group)))
+ (and (not (null? methods))
+ (if ((caar methods) group pathname)
+ (cdar methods)
+ (loop (cdr methods))))))
+
+(define (write-file-method group pathname)
+ (let loop ((methods (ref-variable write-file-methods group)))
+ (and (not (null? methods))
+ (if ((caar methods) group pathname)
+ (cdar methods)
+ (loop (cdr methods))))))
+
+(define (get-pathname-or-alternate group pathname)
+ (if (file-exists? pathname)
+ pathname
+ (let loop ((alternates (os/alternate-pathnames group pathname)))
+ (cond ((null? alternates)
+ pathname)
+ ((file-exists? (car alternates))
+ (car alternates))
+ (else
+ (loop (cdr alternates)))))))
+\f
;;;; Input
(define (read-buffer buffer pathname visit?)
(set-buffer-writable! buffer)
(let ((truename false)
- (file-error false))
+ (file-error false)
+ (group (buffer-group buffer)))
;; Set modified so that file supercession check isn't done.
- (set-group-modified?! (buffer-group buffer) true)
+ (set-group-modified?! group true)
(region-delete! (buffer-unclipped-region buffer))
+ (set! pathname (get-pathname-or-alternate group pathname))
(call-with-current-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:file-error)
(continuation unspecific))
(lambda ()
(set! truename (->truename pathname))
- (if truename
- (begin
- (%insert-file (buffer-start buffer) truename visit?)
- (if visit?
- (set-buffer-modification-time!
- buffer
- (file-modification-time truename)))))))))
+ (%insert-file (buffer-start buffer) truename visit?)
+ (if visit?
+ (set-buffer-modification-time!
+ buffer
+ (file-modification-time truename)))))))
(set-buffer-point! buffer (buffer-start buffer))
(if visit?
(begin
condition
(editor-error "File " (->namestring filename) " not found"))
(lambda ()
- (->truename filename)))
+ (->truename (get-pathname-or-alternate (mark-group mark) filename))))
false))
\f
(define-variable read-file-message
false
boolean?)
-(define-variable read-file-methods
- "List of procedures to be called before reading a file into a buffer.
-The procedures are called in order; if one of them returns true the file
-is considered already read and the rest are not called.
-Each procedure is called with three arguments:
- the pathname of the file to be read,
- the mark at which the file's contents should be inserted, and
- a flag that is true iff the buffer being filled is visiting the file."
- (os/read-file-methods)
- list?)
-
(define-variable translate-file-data-on-input
"If true (the default), end-of-line translation is done on file input."
#t
(define (%insert-file mark truename visit?)
(let ((do-it
(lambda ()
- (let loop ((methods (ref-variable read-file-methods mark)))
- (cond ((null? methods)
- (group-insert-file! (mark-group mark)
- (mark-index mark)
- truename))
- ((not ((car methods) truename mark visit?))
- (loop (cdr methods))))))))
+ (let ((method (read-file-method (mark-group mark) truename)))
+ (if method
+ (method truename mark visit?)
+ (group-insert-file! (mark-group mark)
+ (mark-index mark)
+ truename))))))
(if (ref-variable read-file-message)
(let ((msg
(string-append "Reading file \""
'()
list?)
-(define-variable write-file-methods
- "List of procedures to be called before writing a region to a file.
-The procedures are called in order; if one of them returns true the file
-is considered already written and the rest are not called.
-Each procedure is called with three arguments:
- the region that should be written to the file,
- the pathname of the file to be written, and
- a flag that is true iff the buffer being written is visiting the file."
- (os/write-file-methods)
- list?)
-
(define-variable enable-emacs-write-file-message
"If true, generate Emacs-style message when writing files.
Otherwise, a message is written both before and after long file writes."
(write-region* region pathname message? true))
(define (write-region* region pathname message? append?)
- (let ((translation
- (and (ref-variable translate-file-data-on-output
- (region-group region))
- (pathname-newline-translation pathname)))
- (filename (->namestring pathname))
- (group (region-group region))
+ (let ((group (region-group region))
(start (region-start-index region))
- (end (region-end-index region)))
- (let ((do-it
- (if append?
- (lambda ()
- (group-append-to-file translation group start end filename))
- (lambda ()
- (let ((visit? (eq? 'VISIT message?)))
- (let loop
- ((methods (ref-variable write-file-methods group)))
- (cond ((null? methods)
- (group-write-to-file translation group start end
- filename))
- ((not ((car methods) region pathname visit?))
- (loop (cdr methods))))))))))
- (cond ((not message?)
- (do-it))
- ((or (ref-variable enable-emacs-write-file-message)
- (<= (- end start) 50000))
- (do-it)
- (message "Wrote " filename))
- (else
- (let ((msg (string-append "Writing file " filename "...")))
- (message msg)
+ (end (region-end-index region))
+ (pathname (get-pathname-or-alternate (region-group region) pathname)))
+ (let ((translation
+ (and (ref-variable translate-file-data-on-output group)
+ (pathname-newline-translation pathname)))
+ (filename (->namestring pathname)))
+ (let ((do-it
+ (let ((method (write-file-method group pathname)))
+ (if append?
+ (lambda ()
+ (if method
+ (let ((rmethod (read-file-method group pathname)))
+ (if (not rmethod)
+ (error "Can't append: no read method:"
+ pathname))
+ (call-with-temporary-buffer " append region"
+ (lambda (buffer)
+ (let ((vcopy
+ (lambda (v)
+ (define-variable-local-value! buffer v
+ (variable-local-value group v)))))
+ (vcopy
+ (ref-variable-object
+ translate-file-data-on-input))
+ (vcopy
+ (ref-variable-object
+ translate-file-data-on-output)))
+ (rmethod pathname (buffer-start buffer) #f)
+ (insert-region (region-start region)
+ (region-end region)
+ (buffer-end buffer))
+ (method (buffer-region buffer) pathname #f))))
+ (group-append-to-file translation group start end
+ filename)))
+ (lambda ()
+ (if method
+ (method region pathname (eq? 'VISIT message?))
+ (group-write-to-file translation group start end
+ filename)))))))
+ (cond ((not message?)
+ (do-it))
+ ((or (ref-variable enable-emacs-write-file-message)
+ (<= (- end start) 50000))
(do-it)
- (message msg "done")))))
- ;; This isn't the correct truename on systems that support version
- ;; numbers. For those systems, the truename must be supplied by
- ;; the operating system after the channel is closed.
- filename))
+ (message "Wrote " filename))
+ (else
+ (let ((msg (string-append "Writing file " filename "...")))
+ (message msg)
+ (do-it)
+ (message msg "done")))))
+ ;; This isn't the correct truename on systems that support version
+ ;; numbers. For those systems, the truename must be supplied by
+ ;; the operating system after the channel is closed.
+ filename)))
\f
(define (group-write-to-file translation group start end filename)
(let ((channel (file-open-output-channel filename)))
;;; -*-Scheme-*-
;;;
-;;; $Id: os2.scm,v 1.20 1995/07/24 22:08:39 cph Exp $
+;;; $Id: os2.scm,v 1.21 1995/09/13 23:01:01 cph Exp $
;;;
;;; Copyright (c) 1994-95 Massachusetts Institute of Technology
;;;
\f
;;;; Compressed Files
-(define (os/read-file-methods) (list maybe-read-compressed-file))
-
-(define (os/write-file-methods) (list maybe-write-compressed-file))
+(define (os/read-file-methods)
+ `((,read/write-compressed-file?
+ . ,(lambda (pathname mark visit?)
+ visit?
+ (read-compressed-file "gzip -d" pathname mark)))))
+
+(define (os/write-file-methods)
+ `((,read/write-compressed-file?
+ . ,(lambda (region pathname visit?)
+ visit?
+ (write-compressed-file "gzip" region pathname)))))
+
+(define (os/alternate-pathnames group pathname)
+ (if (and (ref-variable enable-compressed-files group)
+ (os2/fs-long-filenames? pathname)
+ (not (equal? "gz" (pathname-type pathname))))
+ (list (string-append (->namestring pathname) ".gz"))
+ '()))
(define-variable enable-compressed-files
"If true, compressed files are automatically uncompressed when read,
#t
boolean?)
-(define (maybe-read-compressed-file pathname mark visit?)
- visit?
- (and (ref-variable enable-compressed-files mark)
- (equal? "gz" (pathname-type pathname))
- (begin
- (read-compressed-file "gzip -d" pathname mark)
- #t)))
+(define (read/write-compressed-file? group pathname)
+ (and (ref-variable enable-compressed-files group)
+ (equal? "gz" (pathname-type pathname))))
(define (read-compressed-file program pathname mark)
(let ((do-it
(do-it)
(append-message "done")))))
-(define (maybe-write-compressed-file region pathname visit?)
- visit?
- (and (ref-variable enable-compressed-files (region-start region))
- (equal? "gz" (pathname-type pathname))
- (begin
- (write-compressed-file "gzip" region pathname)
- #t)))
-
(define (write-compressed-file program region pathname)
(if (not (equal? '(EXITED . 0)
(shell-command region
;;; -*-Scheme-*-
;;;
-;;; $Id: process.scm,v 1.37 1995/04/10 16:50:04 cph Exp $
+;;; $Id: process.scm,v 1.38 1995/09/13 23:01:03 cph Exp $
;;;
;;; Copyright (c) 1991-95 Massachusetts Institute of Technology
;;;
(cons status reason))))))
\f
(define (synchronous-process-wait process input-region output-mark)
+ ;; Initialize the subprocess line-translation appropriately.
+ ;; Buffers that disable translation should have it disabled for
+ ;; subprocess I/O as well as normal file I/O, since subprocesses are
+ ;; used for reading and writing compressed files and such.
+ (subprocess-i/o-port process
+ (and (or (not output-mark)
+ (ref-variable translate-file-data-on-input
+ output-mark))
+ 'DEFAULT)
+ (and (or (not input-region)
+ (ref-variable translate-file-data-on-output
+ (region-start input-region)))
+ 'DEFAULT))
(if input-region
(call-with-protected-continuation
(lambda (continuation)
;;; -*-Scheme-*-
;;;
-;;; $Id: unix.scm,v 1.52 1995/07/11 23:10:49 cph Exp $
+;;; $Id: unix.scm,v 1.53 1995/09/13 23:01:05 cph Exp $
;;;
;;; Copyright (c) 1989-95 Massachusetts Institute of Technology
;;;
(string-find-next-char filename #\#)))
(define (os/read-file-methods)
- (list maybe-read-compressed-file
- maybe-read-encrypted-file))
+ `((,read/write-compressed-file?
+ . ,(lambda (pathname mark visit?)
+ visit?
+ (let ((type (pathname-type pathname)))
+ (cond ((equal? "gz" type)
+ (read-compressed-file "gzip -d" pathname mark))
+ ((equal? "Z" type)
+ (read-compressed-file "uncompress" pathname mark))))))
+ (,read/write-encrypted-file?
+ . ,(lambda (pathname mark visit?)
+ visit?
+ (read-encrypted-file pathname mark)))))
(define (os/write-file-methods)
- (list maybe-write-compressed-file
- maybe-write-encrypted-file))
+ `((,read/write-compressed-file?
+ . ,(lambda (region pathname visit?)
+ visit?
+ (let ((type (pathname-type pathname)))
+ (cond ((equal? "gz" type)
+ (write-compressed-file "gzip" region pathname))
+ ((equal? "Z" type)
+ (write-compressed-file "compress" region pathname))))))
+ (,read/write-encrypted-file?
+ . ,(lambda (region pathname visit?)
+ visit?
+ (write-encrypted-file region pathname)))))
+
+(define (os/alternate-pathnames group pathname)
+ (let ((filename (->namestring pathname)))
+ `(,@(if (ref-variable enable-compressed-files group)
+ (map (lambda (suffix) (string-append filename "." suffix))
+ unix/compressed-file-suffixes)
+ '())
+ ,@(if (ref-variable enable-encrypted-files group)
+ (map (lambda (suffix) (string-append filename "." suffix))
+ unix/encrypted-file-suffixes)
+ '()))))
\f
;;;; Compressed Files
true
boolean?)
-(define (maybe-read-compressed-file pathname mark visit?)
- visit?
- (and (ref-variable enable-compressed-files mark)
- (let ((type (pathname-type pathname)))
- (cond ((equal? "gz" type)
- (read-compressed-file "gunzip" pathname mark)
- #t)
- ((equal? "Z" type)
- (read-compressed-file "uncompress" pathname mark)
- #t)
- (else
- #f)))))
+(define (read/write-compressed-file? group pathname)
+ (and (ref-variable enable-compressed-files group)
+ (member (pathname-type pathname) unix/compressed-file-suffixes)))
+
+(define unix/compressed-file-suffixes
+ '("gz" "Z"))
(define (read-compressed-file program pathname mark)
(let ((do-it
(lambda ()
(if (not (equal? '(EXITED . 0)
- (shell-command false
+ (shell-command #f
mark
(directory-pathname pathname)
- false
+ #f
(string-append
program
" < "
(do-it)
(append-message "done")))))
-(define (maybe-write-compressed-file region pathname visit?)
- visit?
- (and (ref-variable enable-compressed-files (region-start region))
- (let ((type (pathname-type pathname)))
- (cond ((equal? "gz" type)
- (write-compressed-file "gzip" region pathname)
- #t)
- ((equal? "Z" type)
- (write-compressed-file "compress" region pathname)
- #t)
- (else
- #f)))))
-
(define (write-compressed-file program region pathname)
(if (not (equal? '(EXITED . 0)
(shell-command region
- false
+ #f
(directory-pathname pathname)
- false
+ #f
(string-append program
" > "
(file-namestring pathname)))))
true
boolean?)
-(define (maybe-read-encrypted-file pathname mark visit?)
- visit?
- (and (ref-variable enable-encrypted-files mark)
- (equal? "KY" (pathname-type pathname))
- (begin
- (read-encrypted-file pathname mark)
- true)))
+(define (read/write-encrypted-file? group pathname)
+ (and (ref-variable enable-encrypted-files group)
+ (member (pathname-type pathname) unix/encrypted-file-suffixes)))
+
+(define unix/encrypted-file-suffixes
+ '("KY"))
(define (read-encrypted-file pathname mark)
(let ((the-encrypted-file
(ref-variable-object auto-save-default)
#f)))
-(define (maybe-write-encrypted-file region pathname visit?)
- visit?
- (and (ref-variable enable-encrypted-files (region-start region))
- (equal? "KY" (pathname-type pathname))
- (begin
- (write-encrypted-file region pathname)
- true)))
-
(define (write-encrypted-file region pathname)
(let* ((password
(prompt-for-confirmed-password))
projects / mit-scheme.git / commitdiff