From 73fb5cf875781af196945b4c89bda8f3f7698154 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 26 Oct 1997 01:35:59 +0000 Subject: [PATCH] Add support for compressed and encrypted files. --- v7/src/edwin/dirw32.scm | 61 ++++++-- v7/src/edwin/dos.scm | 145 +++++-------------- v7/src/edwin/dosfile.scm | 280 +++++++++++++++++++++++++++++++++++- v7/src/edwin/os2.scm | 299 +++------------------------------------ 4 files changed, 377 insertions(+), 408 deletions(-) diff --git a/v7/src/edwin/dirw32.scm b/v7/src/edwin/dirw32.scm index b531ddf9f..0e342e6dc 100644 --- a/v7/src/edwin/dirw32.scm +++ b/v7/src/edwin/dirw32.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dirw32.scm,v 1.1 1996/12/07 22:23:52 cph Exp $ +;;; $Id: dirw32.scm,v 1.2 1997/10/26 01:35:59 cph Exp $ ;;; ;;; Copyright (c) 1996 Massachusetts Institute of Technology ;;; @@ -47,13 +47,58 @@ (declare (usual-integrations)) +(define-key 'dired #\Z 'dired-do-compress) (define-key 'dired #\S 'dired-hidden-toggle) (define-key 'dired #\M 'dired-chmod) +(define-command dired-do-compress + "Compress or uncompress marked (or next ARG) files. +The files are compressed or uncompressed using gzip." + "P" + (lambda (argument) + (let ((n + (dired-change-files "compress" argument + (let ((gzip (os/find-program "gzip" #f)) + (directory (buffer-default-directory (current-buffer)))) + (lambda (pathname lstart) + (let ((type (pathname-type pathname)) + (namestring (->namestring pathname))) + (let ((decompress? (equal? type "gz"))) + (message (if decompress? "Unc" "C") + "ompressing file `" namestring "'...") + (run-synchronous-process #f #f directory #f + gzip + (if decompress? "-d" "") + namestring) + (dired-redisplay + (pathname-new-type + pathname + (and (not decompress?) + (if (string? type) + (string-append type ".gz") + "gz"))) + lstart)))))))) + (if (positive? n) + (message "Compressed or uncompressed " n " files."))))) + (define-command dired-hidden-toggle "Toggle display of hidden/system files on and off." () (lambda () (dired-toggle-switch #\a))) + +(define-command dired-chmod + "Change mode of this file." + "sChange to Mode\nP" + (lambda (spec argument) + (call-with-values (lambda () (win32/parse-attributes-spec spec)) + (lambda (plus minus) + (dired-change-files "change attributes of" argument + (lambda (pathname lstart) + (set-file-modes! pathname + (fix:or (fix:andc (file-modes pathname) + minus) + plus)) + (dired-redisplay pathname lstart))))))) (define (win32/parse-attributes-spec spec) (let ((end (string-length spec)) @@ -81,20 +126,6 @@ (values (win32/attribute-letters-to-mask plus) (win32/attribute-letters-to-mask minus)))))) -(define-command dired-chmod - "Change mode of this file." - "sChange to Mode\nP" - (lambda (spec argument) - (call-with-values (lambda () (win32/parse-attributes-spec spec)) - (lambda (plus minus) - (dired-change-files "change attributes of" argument - (lambda (pathname lstart) - (set-file-modes! pathname - (fix:or (fix:andc (file-modes pathname) - minus) - plus)) - (dired-redisplay pathname lstart))))))) - (define (win32/attribute-letters-to-mask letters) (let ((mask 0)) (for-each (lambda (letter) diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index cb46e5ec0..0ca5806cb 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.44 1997/01/06 00:18:19 cph Exp $ +;;; $Id: dos.scm,v 1.45 1997/10/26 01:35:43 cph Exp $ ;;; ;;; Copyright (c) 1992-97 Massachusetts Institute of Technology ;;; @@ -46,20 +46,22 @@ (declare (usual-integrations)) -(define dos/encoding-pathname-types - '()) - -(define dos/executable-pathname-types - ;; Not sure if there are other possibilities under WinNT and/or Win95. - '("exe" "com" "bat")) +(define dos/windows-type + (cond ((string-prefix? "Microsoft Windows NT" + microcode-id/operating-system-variant) + 'WINNT) + ((string-prefix? "Microsoft Windows 95" + microcode-id/operating-system-variant) + 'WIN95) + ((string-prefix? "Microsoft Win32s" + microcode-id/operating-system-variant) + 'WIN31) + (else #f))) (define dos/default-shell-file-name - ;; Not sure if this is right for WinNT and/or Win95. - "command.com") - -(define (os/form-shell-command command) - ;; Not sure if this is right. - (list "/c" command)) + (if (eq? 'WINNT dos/windows-type) + "cmd.exe" + "command.com")) (define (os/set-file-modes-writable! pathname) (set-file-modes! pathname @@ -93,8 +95,23 @@ ((ucode-primitive set-working-directory-pathname! 1) outside) (set-working-directory-pathname! outside) (start-thread-timer))))) + +(define (dos/read-dired-files file all-files?) + (map (lambda (entry) (cons (file-namestring (car entry)) (cdr entry))) + (let ((entries (directory-read file #f #t))) + (if all-files? + entries + (list-transform-positive entries + (let ((mask + (fix:or nt-file-mode/hidden nt-file-mode/system))) + (lambda (entry) + (fix:= (fix:and (file-attributes/modes (cdr entry)) mask) + 0)))))))) -(define cut-and-paste-active? #T) +;;;; Win32 Clipboard Interface + +(define cut-and-paste-active? + #t) (define (os/interprogram-cut string push?) push? @@ -163,104 +180,10 @@ (%substring-move! string start cr copy cindex) (loop (fix:+ cr 1) (fix:+ cindex (fix:- cr start))))))) copy))))) - -(define (os/read-file-methods) '()) -(define (os/write-file-methods) '()) -(define (os/alternate-pathnames group pathname) group pathname '()) + +;;;; Mail Customization (define (os/rmail-spool-directory) #f) (define (os/rmail-primary-inbox-list system-mailboxes) system-mailboxes '()) (define (os/sendmail-program) "sendmail.exe") -(define (os/rmail-pop-procedure) #f) -(define (os/hostname) (error "OS/HOSTNAME procedure unimplemented.")) - -;;;; Dired customization - -(define-variable dired-listing-switches - "Dired listing format. -Recognized switches are: - -a show all files including system and hidden files - -t sort files according to modification time - -l ignored (but allowed for unix compatibility) -Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." - "-l" - string?) - -(define-variable list-directory-brief-switches - "list-directory brief listing format. -Recognized switches are: - -a show all files including system and hidden files - -t sort files according to modification time - -l ignored (but allowed for unix compatibility) -Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." - "-l" - string?) - -(define-variable list-directory-verbose-switches - "list-directory verbose listing format. -Recognized switches are: - -a show all files including system and hidden files - -t sort files according to modification time - -l ignored (but allowed for unix compatibility) -Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." - "-l" - string?) - -(define (insert-directory! file switches mark type) - ;; Insert directory listing for FILE at MARK. - ;; SWITCHES are examined for the presence of "a" and "t". - ;; 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. - (let ((mark (mark-left-inserting-copy mark)) - (now (get-universal-time))) - (catch-file-errors (lambda (c) - (insert-string (condition/report-string c) mark) - (insert-newline mark)) - (lambda () - (for-each - (lambda (entry) - (insert-string (win32/dired-line-string (car entry) (cdr entry) now) - mark) - (insert-newline mark)) - (if (eq? 'FILE type) - (let ((attributes (file-attributes file))) - (if attributes - (list (cons (file-namestring file) attributes)) - '())) - (sort (win32/read-dired-files - file - (string-find-next-char switches #\a)) - (if (string-find-next-char switches #\t) - (lambda (x y) - (> (file-attributes/modification-time (cdr x)) - (file-attributes/modification-time (cdr y)))) - (lambda (x y) - (string-cistring (file-attributes/length attr)) 10 #\space) - " " - (file-time->ls-string (file-attributes/modification-time attr) now) - " " - name)) - -(define (win32/read-dired-files file all-files?) - (map (lambda (entry) (cons (file-namestring (car entry)) (cdr entry))) - (let ((entries (directory-read file #f #t))) - (if all-files? - entries - (list-transform-positive entries - (let ((mask - (fix:or nt-file-mode/hidden nt-file-mode/system))) - (lambda (entry) - (fix:= (fix:and (file-attributes/modes (cdr entry)) mask) - 0)))))))) - -(define dired-pathname-wild? - pathname-wild?) \ No newline at end of file +(define (os/rmail-pop-procedure) #f) \ No newline at end of file diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm index 1c2820f3d..e97c2068e 100644 --- a/v7/src/edwin/dosfile.scm +++ b/v7/src/edwin/dosfile.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dosfile.scm,v 1.11 1997/10/22 05:10:03 cph Exp $ +;;; $Id: dosfile.scm,v 1.12 1997/10/26 01:35:35 cph Exp $ ;;; ;;; Copyright (c) 1994-97 Massachusetts Institute of Technology ;;; @@ -64,6 +64,9 @@ Includes the new backup. Must be > 0." 2 (lambda (n) (and (exact-integer? n) (> n 0)))) +(define dos/encoding-pathname-types + '("gz" "bf" "ky")) + (define dos/backup-suffixes (cons "~" (map (lambda (type) (string-append "~." type)) @@ -142,6 +145,84 @@ Includes the new backup. Must be > 0." (directory-channel-close channel) result)))))) +;;;; Dired customization + +(define-variable dired-listing-switches + "Dired listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." + "-l" + string?) + +(define-variable list-directory-brief-switches + "list-directory brief listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." + "" + string?) + +(define-variable list-directory-verbose-switches + "list-directory verbose listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." + "-l" + string?) + +(define (insert-directory! file switches mark type) + ;; Insert directory listing for FILE at MARK. + ;; SWITCHES are examined for the presence of "a" and "t". + ;; 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. + (let ((mark (mark-left-inserting-copy mark)) + (now (get-universal-time))) + (catch-file-errors (lambda (c) + (insert-string (condition/report-string c) mark) + (insert-newline mark)) + (lambda () + (for-each + (lambda (entry) + (insert-string (dos/dired-line-string (car entry) (cdr entry) now) + mark) + (insert-newline mark)) + (if (eq? 'FILE type) + (let ((attributes (file-attributes file))) + (if attributes + (list (cons (file-namestring file) attributes)) + '())) + (sort (dos/read-dired-files file + (string-find-next-char switches #\a)) + (if (string-find-next-char switches #\t) + (lambda (x y) + (> (file-attributes/modification-time (cdr x)) + (file-attributes/modification-time (cdr y)))) + (lambda (x y) + (string-cistring (file-attributes/length attr)) 10 #\space) + " " + (file-time->ls-string (file-attributes/modification-time attr) now) + " " + name)) + +(define dired-pathname-wild? + pathname-wild?) + ;;;; Backup and Auto-Save Filenames (define (os/buffer-backup-pathname truename buffer) @@ -431,7 +512,7 @@ Includes the new backup. Must be > 0." (merge-pathnames (car path) default-directory))) (loop (cdr path)))))))))) - + (define (os/shell-file-name) (or (get-environment-variable "SHELL") (get-environment-variable "COMSPEC") @@ -442,6 +523,12 @@ Includes the new backup. Must be > 0." (pathname-name pathname) (file-namestring pathname))) +(define (os/form-shell-command command) + (list "/c" command)) + +(define dos/executable-pathname-types + '("exe" "com" "bat")) + (define (os/default-shell-prompt-pattern) "^\\[[^]]*] *") @@ -451,4 +538,191 @@ Includes the new backup. Must be > 0." (define (os/comint-filename-region start point end) (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---")) (let ((start (skip-chars-backward chars point start))) - (make-region start (skip-chars-forward chars start end))))) \ No newline at end of file + (make-region start (skip-chars-forward chars start end))))) + +(define (os/hostname) + (if (not dos/cached-hostname) + (let ((buffer (temporary-buffer "*hostname*"))) + (let ((status.reason + (run-synchronous-process #f (buffer-end buffer) #f #f + "hostname"))) + (if (not (equal? status.reason '(EXITED . 0))) + (begin + (pop-up-buffer buffer) + (error "Error running HOSTNAME program:" status.reason)))) + (set! dos/cached-hostname (string-trim (buffer-string buffer))) + (kill-buffer buffer))) + dos/cached-hostname) + +(define dos/cached-hostname #f) +(add-event-receiver! event:after-restore + (lambda () + (set! dos/cached-hostname #f) + unspecific)) + +;;;; File-Encoding Methods + +(define (os/read-file-methods) + `((,read/write-compressed-file? + . ,(lambda (pathname mark visit?) + visit? + (read-compressed-file "gzip -d" pathname mark))) + (,read/write-encrypted-file? + . ,(lambda (pathname mark visit?) + visit? + (read-encrypted-file pathname mark))))) + +(define (os/write-file-methods) + `((,read/write-compressed-file? + . ,(lambda (region pathname visit?) + visit? + (write-compressed-file "gzip" region pathname))) + (,read/write-encrypted-file? + . ,(lambda (region pathname visit?) + visit? + (write-encrypted-file region pathname))))) + +(define (os/alternate-pathnames group pathname) + (if (dos/fs-long-filenames? pathname) + (append (if (and (ref-variable enable-compressed-files group) + (not (equal? "gz" (pathname-type pathname)))) + (list (string-append (->namestring pathname) ".gz")) + '()) + (if (and (ref-variable enable-encrypted-files group) + (not (equal? "bf" (pathname-type pathname)))) + (list (string-append (->namestring pathname) ".bf")) + '()) + (if (and (ref-variable enable-encrypted-files group) + (not (equal? "ky" (pathname-type pathname)))) + (list (string-append (->namestring pathname) ".ky")) + '())) + '())) + +;;;; Compressed Files + +(define-variable enable-compressed-files + "If true, compressed files are automatically uncompressed when read, +and recompressed when written. A compressed file is identified by the +filename suffix \".gz\"." + #t + boolean?) + +(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) + (message "Uncompressing file " (->namestring pathname) "...") + (let ((value + (call-with-temporary-file-pathname + (lambda (temporary) + (if (not (equal? '(EXITED . 0) + (shell-command #f #f + (directory-pathname pathname) + #f + (string-append + program + " < " + (file-namestring pathname) + " > " + (->namestring temporary))))) + (error:file-operation pathname + program + "file" + "[unknown]" + read-compressed-file + (list pathname mark))) + (group-insert-file! (mark-group mark) + (mark-index mark) + temporary + (pathname-newline-translation pathname)))))) + (append-message "done") + value)) + +(define (write-compressed-file program region pathname) + (message "Compressing file " (->namestring pathname) "...") + (if (not (equal? '(EXITED . 0) + (shell-command region + #f + (directory-pathname pathname) + #f + (string-append program + " > " + (file-namestring pathname))))) + (error:file-operation pathname + program + "file" + "[unknown]" + write-compressed-file + (list region pathname))) + (append-message "done")) + +;;;; Encrypted files + +(define-variable enable-encrypted-files + "If true, encrypted files are automatically decrypted when read, +and recrypted when written. An encrypted file is identified by the +filename suffixes \".bf\" and \".ky\"." + #t + boolean?) + +(define (read/write-encrypted-file? group pathname) + (and (ref-variable enable-encrypted-files group) + (or (and (equal? "bf" (pathname-type pathname)) + (blowfish-available?)) + (equal? "ky" (pathname-type pathname))))) + +(define (read-encrypted-file pathname mark) + (let ((password (prompt-for-password "Password: ")) + (type (pathname-type pathname))) + (message "Decrypting file " (->namestring pathname) "...") + (cond ((equal? "bf" type) + (call-with-binary-input-file pathname + (lambda (input) + (read-blowfish-file-header input) + (call-with-output-mark mark + (lambda (output) + (blowfish-encrypt-port input output password #f)))))) + ((or (equal? "ky" type) (equal? "KY" type)) + (insert-string (let ((the-encrypted-file + (call-with-binary-input-file pathname + (lambda (port) + (read-string (char-set) port))))) + (decrypt the-encrypted-file password + (lambda () + (kill-buffer (mark-buffer mark)) + (editor-error "krypt: Password error!")) + (lambda (x) + (editor-beep) + (message "krypt: Checksum error!") + x))) + mark))) + ;; Disable auto-save here since we don't want to + ;; auto-save the unencrypted contents of the + ;; encrypted file. + (define-variable-local-value! (mark-buffer mark) + (ref-variable-object auto-save-default) + #f) + (append-message "done"))) + +(define (write-encrypted-file region pathname) + (let ((password (prompt-for-confirmed-password)) + (type (pathname-type pathname))) + (message "Encrypting file " (->namestring pathname) "...") + (cond ((equal? "bf" type) + (let ((input + (make-buffer-input-port (region-start region) + (region-end region)))) + (call-with-binary-output-file pathname + (lambda (output) + (write-blowfish-file-header output) + (blowfish-encrypt-port input output password #t))))) + ((or (equal? "ky" type) (equal? "KY" type)) + (let ((the-encrypted-file + (encrypt (extract-string (region-start region) + (region-end region)) + password))) + (call-with-binary-output-file pathname + (lambda (port) + (write-string the-encrypted-file port)))))) + (append-message "done"))) \ No newline at end of file diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index 938c46353..be0f3c1ff 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.40 1997/06/09 08:12:22 cph Exp $ +;;; $Id: os2.scm,v 1.41 1997/10/26 01:35:52 cph Exp $ ;;; ;;; Copyright (c) 1994-97 Massachusetts Institute of Technology ;;; @@ -45,18 +45,9 @@ (declare (usual-integrations)) -(define dos/encoding-pathname-types - '("gz" "bf" "ky")) - -(define dos/executable-pathname-types - '("exe" "cmd")) - (define dos/default-shell-file-name "cmd.exe") -(define (os/form-shell-command command) - (list "/c" command)) - (define (os/set-file-modes-writable! pathname) (set-file-modes! pathname (fix:andc (file-modes pathname) os2-file-mode/read-only))) @@ -71,25 +62,25 @@ dir (error "Can't quit.")) -(define (os/hostname) - (if (not os2/cached-hostname) - (let ((buffer (temporary-buffer "*hostname*"))) - (let ((status.reason - (run-synchronous-process #f (buffer-end buffer) #f #f - "hostname"))) - (if (not (equal? status.reason '(EXITED . 0))) - (begin - (pop-up-buffer buffer) - (error "Error running HOSTNAME program:" status.reason)))) - (set! os2/cached-hostname (string-trim (buffer-string buffer))) - (kill-buffer buffer))) - os2/cached-hostname) - -(define os2/cached-hostname #f) -(add-event-receiver! event:after-restore - (lambda () - (set! os2/cached-hostname #f) - unspecific)) +(define (dos/read-dired-files file all-files?) + (let loop + ((pathnames + (let ((pathnames (directory-read file #f))) + (if all-files? + pathnames + (list-transform-positive pathnames + (let ((mask + (fix:or os2-file-mode/hidden os2-file-mode/system))) + (lambda (pathname) + (fix:= (fix:and (file-modes pathname) mask) 0))))))) + (result '())) + (if (null? pathnames) + result + (loop (cdr pathnames) + (let ((attr (file-attributes (car pathnames)))) + (if attr + (cons (cons (file-namestring (car pathnames)) attr) result) + result)))))) ;;;; OS/2 Clipboard Interface @@ -159,256 +150,6 @@ (loop (fix:+ cr 1) (fix:+ cindex (fix:- cr start))))))) copy))))) -;;;; Dired customization - -(define-variable dired-listing-switches - "Dired listing format." - "-l" - string?) - -(define-variable list-directory-brief-switches - "list-directory brief listing format." - "" - string?) - -(define-variable list-directory-verbose-switches - "list-directory verbose listing format." - "-l" - string?) - -(define (insert-directory! file switches mark type) - ;; Insert directory listing for FILE at MARK. - ;; SWITCHES are examined for the presence of "a" and "t". - ;; 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. - (let ((mark (mark-left-inserting-copy mark)) - (now (get-universal-time))) - (catch-file-errors (lambda (c) - (insert-string (condition/report-string c) mark) - (insert-newline mark)) - (lambda () - (for-each - (lambda (entry) - (insert-string (os2/dired-line-string (car entry) (cdr entry) now) - mark) - (insert-newline mark)) - (if (eq? 'FILE type) - (let ((attributes (file-attributes file))) - (if attributes - (list (cons (file-namestring file) attributes)) - '())) - (sort (os2/read-dired-files file - (string-find-next-char switches #\a)) - (if (string-find-next-char switches #\t) - (lambda (x y) - (> (file-attributes/modification-time (cdr x)) - (file-attributes/modification-time (cdr y)))) - (lambda (x y) - (string-cistring (file-attributes/length attr)) 10 #\space) - " " - (file-time->ls-string (file-attributes/modification-time attr) now) - " " - name)) - -(define (os2/read-dired-files file all-files?) - (let loop - ((pathnames - (let ((pathnames (directory-read file #f))) - (if all-files? - pathnames - (list-transform-positive pathnames - (let ((mask - (fix:or os2-file-mode/hidden os2-file-mode/system))) - (lambda (pathname) - (fix:= (fix:and (file-modes pathname) mask) 0))))))) - (result '())) - (if (null? pathnames) - result - (loop (cdr pathnames) - (let ((attr (file-attributes (car pathnames)))) - (if attr - (cons (cons (file-namestring (car pathnames)) attr) result) - result)))))) - -(define dired-pathname-wild? - pathname-wild?) - -;;;; File-Encoding Methods - -(define (os/read-file-methods) - `((,read/write-compressed-file? - . ,(lambda (pathname mark visit?) - visit? - (read-compressed-file "gzip -d" pathname mark))) - (,read/write-encrypted-file? - . ,(lambda (pathname mark visit?) - visit? - (read-encrypted-file pathname mark))))) - -(define (os/write-file-methods) - `((,read/write-compressed-file? - . ,(lambda (region pathname visit?) - visit? - (write-compressed-file "gzip" region pathname))) - (,read/write-encrypted-file? - . ,(lambda (region pathname visit?) - visit? - (write-encrypted-file region pathname))))) - -(define (os/alternate-pathnames group pathname) - (if (dos/fs-long-filenames? pathname) - (append (if (and (ref-variable enable-compressed-files group) - (not (equal? "gz" (pathname-type pathname)))) - (list (string-append (->namestring pathname) ".gz")) - '()) - (if (and (ref-variable enable-encrypted-files group) - (not (equal? "bf" (pathname-type pathname)))) - (list (string-append (->namestring pathname) ".bf")) - '()) - (if (and (ref-variable enable-encrypted-files group) - (not (equal? "ky" (pathname-type pathname)))) - (list (string-append (->namestring pathname) ".ky")) - '())) - '())) - -;;;; Compressed Files - -(define-variable enable-compressed-files - "If true, compressed files are automatically uncompressed when read, -and recompressed when written. A compressed file is identified by the -filename suffix \".gz\"." - #t - boolean?) - -(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) - (message "Uncompressing file " (->namestring pathname) "...") - (let ((value - (call-with-temporary-file-pathname - (lambda (temporary) - (if (not (equal? '(EXITED . 0) - (shell-command #f #f - (directory-pathname pathname) - #f - (string-append - program - " < " - (file-namestring pathname) - " > " - (->namestring temporary))))) - (error:file-operation pathname - program - "file" - "[unknown]" - read-compressed-file - (list pathname mark))) - (group-insert-file! (mark-group mark) - (mark-index mark) - temporary - (pathname-newline-translation pathname)))))) - (append-message "done") - value)) - -(define (write-compressed-file program region pathname) - (message "Compressing file " (->namestring pathname) "...") - (if (not (equal? '(EXITED . 0) - (shell-command region - #f - (directory-pathname pathname) - #f - (string-append program - " > " - (file-namestring pathname))))) - (error:file-operation pathname - program - "file" - "[unknown]" - write-compressed-file - (list region pathname))) - (append-message "done")) - -;;;; Encrypted files - -(define-variable enable-encrypted-files - "If true, encrypted files are automatically decrypted when read, -and recrypted when written. An encrypted file is identified by the -filename suffixes \".bf\" and \".ky\"." - #t - boolean?) - -(define (read/write-encrypted-file? group pathname) - (and (ref-variable enable-encrypted-files group) - (or (and (equal? "bf" (pathname-type pathname)) - (blowfish-available?)) - (equal? "ky" (pathname-type pathname))))) - -(define (read-encrypted-file pathname mark) - (let ((password (prompt-for-password "Password: ")) - (type (pathname-type pathname))) - (message "Decrypting file " (->namestring pathname) "...") - (cond ((equal? "bf" type) - (call-with-binary-input-file pathname - (lambda (input) - (read-blowfish-file-header input) - (call-with-output-mark mark - (lambda (output) - (blowfish-encrypt-port input output password #f)))))) - ((or (equal? "ky" type) (equal? "KY" type)) - (insert-string (let ((the-encrypted-file - (call-with-binary-input-file pathname - (lambda (port) - (read-string (char-set) port))))) - (decrypt the-encrypted-file password - (lambda () - (kill-buffer (mark-buffer mark)) - (editor-error "krypt: Password error!")) - (lambda (x) - (editor-beep) - (message "krypt: Checksum error!") - x))) - mark))) - ;; Disable auto-save here since we don't want to - ;; auto-save the unencrypted contents of the - ;; encrypted file. - (define-variable-local-value! (mark-buffer mark) - (ref-variable-object auto-save-default) - #f) - (append-message "done"))) - -(define (write-encrypted-file region pathname) - (let ((password (prompt-for-confirmed-password)) - (type (pathname-type pathname))) - (message "Encrypting file " (->namestring pathname) "...") - (cond ((equal? "bf" type) - (let ((input - (make-buffer-input-port (region-start region) - (region-end region)))) - (call-with-binary-output-file pathname - (lambda (output) - (write-blowfish-file-header output) - (blowfish-encrypt-port input output password #t))))) - ((or (equal? "ky" type) (equal? "KY" type)) - (let ((the-encrypted-file - (encrypt (extract-string (region-start region) - (region-end region)) - password))) - (call-with-binary-output-file pathname - (lambda (port) - (write-string the-encrypted-file port)))))) - (append-message "done"))) - ;;;; Mail Customization (define (os/sendmail-program) -- 2.25.1