#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.188 1996/04/24 01:20:29 cph Exp $
+$Id: edwin.pkg,v 1.189 1996/04/24 01:29:31 cph Exp $
Copyright (c) 1989-96 Massachusetts Institute of Technology
reduction-expression
set-current-subproblem!
set-dstate/environment-list!
- set-dstate/reduction-number!
- write-restarts)
+ set-dstate/reduction-number!)
(import (runtime debugger-utilities)
print-binding
output-to-string
(import (edwin buffer-output-port)
port/mark)
(import (runtime rep)
- default/repl-eval))
+ default/repl-eval
+ write-restarts))
\f
(define-package (edwin text-properties)
(files "txtprp")
get-handle
get-window-rect
load-icon
- make-rect rect/top rect/left rect/bottom rect/right
+ make-rect
message-beep
+ rect/bottom
+ rect/left
+ rect/right
+ rect/top
send-message
set-active-window
set-focus
set-window-pos
set-window-text
- sleep
show-window
+ sleep
sw_showminnoactive
- SWP_NOSIZE
- SWP_NOZORDER
+ swp_nosize
+ swp_nozorder
update-window)
(export (edwin win-commands)
win32-screen/get-position
- win32-screen/set-name!
+ win32-screen/set-background-color!
win32-screen/set-font!
+ win32-screen/set-foreground-color!
win32-screen/set-icon!
- win32-screen/set-size!
+ win32-screen/set-name!
win32-screen/set-position!
- win32-screen/set-foreground-color!
- win32-screen/set-background-color!)
+ win32-screen/set-size!)
(initialization (initialize-package!)))
(define-package (edwin win32-keys)
edwin-mode$mail
edwin-variable$mail-archive-file-name
edwin-variable$mail-default-reply-to
+ edwin-variable$mail-full-name
edwin-variable$mail-header-function
edwin-variable$mail-header-separator
+ edwin-variable$mail-host-address
+ edwin-variable$mail-identify-reader
edwin-variable$mail-interactive
edwin-variable$mail-mode-hook
+ edwin-variable$mail-organization
edwin-variable$mail-reply-buffer
- edwin-variable$mail-setup-hook
edwin-variable$mail-self-blind
+ edwin-variable$mail-setup-hook
edwin-variable$mail-yank-ignored-headers
edwin-variable$send-mail-procedure
edwin-variable$sendmail-program
+ edwin-variable$user-mail-address
mail-field-end
mail-field-end!
mail-field-region
mail-field-start
+ mail-from-string
mail-header-end
mail-insert-field
mail-match-header-separator
+ mail-organization-string
mail-position-on-field
mail-position-on-cc-field
mail-setup
+ mailer-version-string
make-mail-buffer
prepare-mail-buffer-for-sending
- send-mail-buffer))
+ send-mail-buffer)
+ (import (runtime system)
+ known-systems))
(define-package (edwin mail-alias)
(files "malias")
;;; -*-Scheme-*-
;;;
-;;; $Id: sendmail.scm,v 1.33 1996/04/23 23:07:43 cph Exp $
+;;; $Id: sendmail.scm,v 1.34 1996/04/24 01:30:11 cph Exp $
;;;
;;; Copyright (c) 1991-96 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+(define-variable user-mail-address
+ "Full mailing address of this user.
+This is initialized based on `mail-host-address',
+after your init file is read, in case it sets `mail-host-address'."
+ #f
+ string-or-false?)
+
+(define-variable mail-host-address
+ "Name of this machine, for purposes of naming users."
+ #f
+ string-or-false?)
+
+(define-variable mail-full-name
+ "Your full name.
+Appears in the From: field of mail and news messages, following the address.
+If set to the null string, From: field contains only the email address."
+ ""
+ string?)
+
+(define-variable mail-organization
+ "The name of your organization.
+Appears in the Organization: field of mail and news messages.
+If set to the null string, no Organization: field is generated."
+ ""
+ string?)
+
+(define-variable mail-identify-reader
+ "Switch controlling generation of X-Mailer headers in messages."
+ #t
+ boolean?)
+
(define-variable mail-default-reply-to
"Address to insert as default Reply-to field of outgoing messages."
false
string?)
(define-variable mail-header-function
- "A function of one argument, POINT (the current point), which
-inserts additional header lines into a mail message. By default,
-this function inserts the header line \"X-Scheme-Mailer: Edwin\"
-followed by the version number of Edwin. The function is called
-immediately after the Reply-to: header is inserted, if any. If this
-variable is false, it is ignored."
- (lambda (point)
- (insert-string "X-Scheme-Mailer:" point)
- (for-each-system!
- (lambda (system)
- (if (string=? "Edwin"
- (system/name system))
- (begin
- (insert-string " " point)
- (insert-string
- (system/identification-string system)
- point)))))
- (insert-newline point))
+ "A function of one argument, POINT (the current point), which inserts
+additional header lines into a mail message. The function is called
+after all other headers are inserted. If this variable is false, it
+is ignored."
+ #f
(lambda (object)
(or (false? object)
(and (procedure? object)
(lambda (no-erase?) (mail-command no-erase? select-buffer)))
(define-command mail-other-window
- "Like \\[mail] command, but display mail buffer in another window."
+ "Like \\[mail], but display mail buffer in another window."
"P"
(lambda (no-erase?) (mail-command no-erase? select-buffer-other-window)))
(define-command mail-other-frame
- "Like \\[mail] command, but display mail buffer in another frame."
+ "Like \\[mail], but display mail buffer in another frame."
"P"
(lambda (no-erase?) (mail-command no-erase? select-buffer-other-screen)))
(or (and (not (default-object? mode)) mode)
(ref-mode-object mail)))
(local-set-variable! mail-reply-buffer reply-buffer buffer)
- (let ((point (mark-left-inserting-copy (buffer-start buffer)))
+ (let ((headers (add-standard-headers headers buffer))
+ (point (mark-left-inserting-copy (buffer-start buffer)))
(fill
(lambda (start end)
(fill-region-as-paragraph start end
(insert-newline point)))))
headers)
(mark-temporary! start))
- (let ((mail-default-reply-to (ref-variable mail-default-reply-to buffer)))
- (let ((mail-default-reply-to
- (if (procedure? mail-default-reply-to)
- (mail-default-reply-to)
- mail-default-reply-to)))
- (if (string? mail-default-reply-to)
- (begin
- (insert-string "Reply-to: " point)
- (insert-string mail-default-reply-to point)
- (insert-newline point)))))
(let ((mail-header-function (ref-variable mail-header-function buffer)))
(if mail-header-function
(mail-header-function point)))
- (if (ref-variable mail-self-blind buffer)
- (begin
- (insert-string "BCC: " point)
- (insert-string (current-user-name) point)
- (insert-newline point)))
- (let ((mail-archive-file-name
- (ref-variable mail-archive-file-name buffer)))
- (if mail-archive-file-name
- (begin
- (insert-string "FCC: " point)
- (insert-string mail-archive-file-name point)
- (insert-newline point))))
(insert-string (ref-variable mail-header-separator buffer) point)
(insert-newline point)
- (mark-temporary! point))
- (let ((given-header?
- (lambda (name null-true?)
- (let ((header
- (list-search-positive headers
- (lambda (header)
- (string-ci=? (car header) name)))))
- (and header
- (cadr header)
- (if null-true?
- (string-null? (cadr header))
- (not (string-null? (cadr header)))))))))
- (set-buffer-point! buffer
- (if (given-header? "To" #t)
- (mail-position-on-field buffer "To")
- (buffer-end buffer)))
- (if (not (or (given-header? "To" #f)
- (given-header? "Subject" #f)
- (given-header? "In-reply-to" #f)))
- (buffer-not-modified! buffer)))
+ (mark-temporary! point)
+ (let ((given-header?
+ (lambda (name null-true?)
+ (let ((header
+ (list-search-positive headers
+ (lambda (header)
+ (string-ci=? (car header) name)))))
+ (and header
+ (cadr header)
+ (if null-true?
+ (string-null? (cadr header))
+ (not (string-null? (cadr header)))))))))
+ (set-buffer-point! buffer
+ (if (given-header? "To" #t)
+ (mail-position-on-field buffer "To")
+ (buffer-end buffer)))
+ (if (not (or (given-header? "To" #f)
+ (given-header? "Subject" #f)
+ (given-header? "In-reply-to" #f)))
+ (buffer-not-modified! buffer))))
(event-distributor/invoke! (ref-variable mail-setup-hook buffer) buffer))
\f
+(define (add-standard-headers headers buffer)
+ (let ((add
+ (lambda (key value)
+ (if (string? value)
+ (list (list key value #f))
+ '()))))
+ (let ((add-unique
+ (lambda (key value)
+ (add key
+ (and (not (list-search-positive headers
+ (lambda (header)
+ (string-ci=? (car header) key))))
+ value)))))
+ (append headers
+ (add "Reply-to"
+ (let ((mail-default-reply-to
+ (ref-variable mail-default-reply-to buffer)))
+ (if (procedure? mail-default-reply-to)
+ (mail-default-reply-to)
+ mail-default-reply-to)))
+ (add "BCC"
+ (and (ref-variable mail-self-blind buffer)
+ (mail-from-string buffer)))
+ (add "FCC" (ref-variable mail-archive-file-name buffer))
+ (add-unique "Organization" (mail-organization-string buffer))
+ (add-unique "X-Mailer" (mailer-version-string buffer))))))
+
+(define (mail-from-string buffer)
+ (string-append (or (ref-variable user-mail-address buffer)
+ (string-append (current-user-name)
+ "@"
+ (or (ref-variable mail-host-address buffer)
+ (os/hostname))))
+ (let ((full-name (ref-variable mail-full-name buffer)))
+ (if (string-null? full-name)
+ ""
+ (string-append " (" full-name ")")))))
+
+(define (mail-organization-string buffer)
+ (let ((organization (ref-variable mail-organization buffer)))
+ (and (not (string-null? organization))
+ organization)))
+
+(define (mailer-version-string buffer)
+ (and (ref-variable mail-identify-reader buffer)
+ (let ((id
+ (system/identification-string
+ (list-search-positive known-systems
+ (lambda (system)
+ (string-ci=? "edwin" (system/name system)))))))
+ (let ((space (string-find-next-char id #\space)))
+ (string-append (string-head id space)
+ " [version"
+ (string-tail id space)
+ ", MIT Scheme Release "
+ microcode-id/release-string
+ "]")))))
+\f
(define-variable mail-setup-hook
"An event distributor invoked immediately after a mail buffer is initialized.
The mail buffer is passed as an argument; it is not necessarily selected."
(insert-string "From " end)
(insert-string (current-user-name) end)
(insert-string " " end)
- (insert-string (file-time->string (current-file-time)) end)
+ (insert-string (universal-time->string (get-universal-time)) end)
(insert-newline end)
(insert-region (buffer-start mail-buffer)
(buffer-end mail-buffer)
projects / mit-scheme.git / commitdiff