1#| -*-Scheme-*- 2 3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8This file is part of MIT/GNU Scheme. 9 10MIT/GNU Scheme is free software; you can redistribute it and/or modify 11it under the terms of the GNU General Public License as published by 12the Free Software Foundation; either version 2 of the License, or (at 13your option) any later version. 14 15MIT/GNU Scheme is distributed in the hope that it will be useful, but 16WITHOUT ANY WARRANTY; without even the implied warranty of 17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18General Public License for more details. 19 20You should have received a copy of the GNU General Public License 21along with MIT/GNU Scheme; if not, write to the Free Software 22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23USA. 24 25|# 26 27;;;; RMAIL Mail Reader 28 29(declare (usual-integrations)) 30 31(define rmail-spool-directory 32 #f) 33 34(define-variable rmail-file-name 35 "" 36 "~/RMAIL" 37 string?) 38 39(define-variable rmail-last-file 40 "Last file used by \\[rmail-output]." 41 "~/xmail" 42 string?) 43 44(define-variable rmail-last-rmail-file 45 "Last file used by \\[rmail-output-to-rmail-file]." 46 "~/XMAIL" 47 string?) 48 49(define-variable rmail-inbox-list 50 "" 51 '() 52 list-of-strings?) 53 54(define-variable rmail-primary-inbox-list 55 "List of files which are inboxes for user's primary mail file ~/RMAIL. 56Empty list means the default, which is (\"~/mbox\" \"/usr/spool/mail/$USER\") 57\(the second name varies depending on the operating system)." 58 '() 59 list-of-strings?) 60 61(define-variable rmail-dont-reply-to-names 62 "A regular expression specifying names to prune in replying to messages. 63#f means don't reply to yourself." 64 false 65 string-or-false?) 66 67(define-variable rmail-default-dont-reply-to-names 68 "A regular expression specifying part of the value of the default value of 69the variable `rmail-dont-reply-to-names', for when the user does not set 70`rmail-dont-reply-to-names' explicitly. (The other part of the default 71value is the user's name.) 72It is useful to set this variable in the site customisation file." 73 "info-" 74 string?) 75 76(define-variable rmail-ignored-headers 77 "Gubbish header fields one would rather not see." 78 "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^[a-z-]*message-id:\\|^summary-line:\\|^errors-to:" 79 string-or-false?) 80 81(define-variable rmail-message-filter 82 "If not #f, is a filter procedure for new headers in RMAIL. 83Called with the start and end marks of the header as arguments." 84 false 85 (lambda (object) (or (not object) (procedure? object)))) 86 87(define-variable rmail-delete-after-output 88 "True means automatically delete a message that is copied to a file." 89 false 90 boolean?) 91 92(define-variable rmail-reply-with-re 93 "True means prepend subject with Re: in replies." 94 false 95 boolean?) 96 97(define-variable rmail-mode-hook 98 "An event distributor that is invoked when entering RMAIL mode." 99 (make-event-distributor)) 100 101(define-variable rmail-new-mail-hook 102 "An event distributor that is invoked when RMAIL incorporates new mail." 103 (make-event-distributor)) 104 105(define-major-mode rmail read-only "RMAIL" 106 "Rmail Mode is used by \\[rmail] for editing Rmail files. 107All normal editing commands are turned off. 108Instead, these commands are available: 109 110. Move point to front of this message (same as \\[beginning-of-buffer]). 111SPC Scroll to next screen of this message. 112DEL Scroll to previous screen of this message. 113n Move to Next non-deleted message. 114p Move to Previous non-deleted message. 115M-n Move to Next message whether deleted or not. 116M-p Move to Previous message whether deleted or not. 117> Move to the last message in Rmail file. 118j Jump to message specified by numeric position in file. 119M-s Search for string and show message it is found in. 120d Delete this message, move to next nondeleted. 121C-d Delete this message, move to previous nondeleted. 122u Undelete message. Tries current message, then earlier messages 123 till a deleted message is found. 124e Expunge deleted messages. 125s Expunge and save the file. 126q Quit Rmail: expunge, save, then switch to another buffer. 127C-x C-s Save without expunging. 128g Move new mail from system spool directory or mbox into this file. 129m Mail a message (same as \\[mail-other-window]). 130c Continue composing outgoing message started before. 131r Reply to this message. Like m but initializes some fields. 132f Forward this message to another user. 133o Output this message to an Rmail file (append it). 134C-o Output this message to a Unix-format mail file (append it). 135i Input Rmail file. Run Rmail on that file. 136a Add label to message. It will be displayed in the mode line. 137k Kill label. Remove a label from current message. 138C-M-n Move to Next message with specified label 139 (label defaults to last one specified). 140 Standard labels: filed, unseen, answered, forwarded, deleted. 141 Any other label is present only if you add it with `a'. 142C-M-p Move to Previous message with specified label 143C-M-h Show headers buffer, with a one line summary of each message. 144C-M-l Like h only just messages with particular label(s) are summarized. 145C-M-r Like h only just messages with particular recipient(s) are summarized. 146t Toggle header, show Rmail header if unformatted or vice versa. 147w Edit the current message. C-c C-c to return to Rmail." 148 (lambda (buffer) 149 (guarantee-rmail-variables-initialized) 150 (define-variable-local-value! buffer 151 (ref-variable-object mode-line-modified) 152 "--- ") 153 (define-variable-local-value! buffer (ref-variable-object version-control) 154 'NEVER) 155 (define-variable-local-value! buffer 156 (ref-variable-object file-precious-flag) 157 true) 158 (define-variable-local-value! buffer 159 (ref-variable-object require-final-newline) 160 false) 161 (define-variable-local-value! buffer 162 (ref-variable-object translate-file-data-on-output) 163 #f) 164 (define-variable-local-value! buffer (ref-variable-object rmail-last-file) 165 (ref-variable rmail-last-file buffer)) 166 (define-variable-local-value! buffer (ref-variable-object rmail-inbox-list) 167 (let ((inboxes (parse-file-inboxes buffer))) 168 (if (and (null? inboxes) 169 (pathname=? (buffer-pathname buffer) 170 (ref-variable rmail-file-name buffer))) 171 (ref-variable rmail-primary-inbox-list buffer) 172 inboxes))) 173 (buffer-put! buffer 'REVERT-BUFFER-METHOD rmail-revert-buffer) 174 (memoize-buffer buffer) 175 (set-buffer-read-only! buffer) 176 (disable-group-undo! (buffer-group buffer)) 177 (event-distributor/invoke! (ref-variable rmail-mode-hook buffer) buffer))) 178 179(define-major-mode rmail-edit text "RMAIL Edit" 180 "Major mode for editing the contents of an RMAIL message. 181The editing commands are the same as in Text mode, 182together with two commands to return to regular RMAIL: 183 * \\[rmail-abort-edit] cancels the changes you have made and returns to RMAIL 184 * \\[rmail-cease-edit] makes them permanent." 185 (lambda (buffer) 186 (enable-group-undo! (buffer-group buffer)))) 187 188(define (guarantee-rmail-variables-initialized) 189 (if (not rmail-spool-directory) 190 (set! rmail-spool-directory (os/rmail-spool-directory))) 191 (if (not (ref-variable rmail-pop-procedure)) 192 (set-variable! rmail-pop-procedure (os/rmail-pop-procedure))) 193 (if (null? (ref-variable rmail-primary-inbox-list)) 194 (set-variable! rmail-primary-inbox-list 195 (os/rmail-primary-inbox-list 196 (let ((server 197 (and (ref-variable rmail-pop-procedure) 198 (ref-variable rmail-primary-pop-server)))) 199 (cond (server 200 (list (string-append "pop:" server))) 201 (rmail-spool-directory 202 (list (string-append rmail-spool-directory 203 (current-user-name)))) 204 (else '())))))) 205 (if (not (ref-variable rmail-dont-reply-to-names)) 206 (set-variable! 207 rmail-dont-reply-to-names 208 (string-append 209 (let ((rmail-default-dont-reply-to-names 210 (ref-variable rmail-default-dont-reply-to-names))) 211 (if rmail-default-dont-reply-to-names 212 (string-append rmail-default-dont-reply-to-names "\\|") 213 "")) 214 (re-quote-string (current-user-name)) 215 "\\>"))) 216 (if (not umail-message-end-regexp) 217 (set! umail-message-end-regexp 218 (string-append "\\(^" 219 umail-message-start-regexp 220 "\\|" 221 mmdf-message-start-regexp 222 "\\|" 223 babyl-header-start-regexp 224 "\\|^[\037]?" 225 babyl-message-start-regexp 226 "\\)"))) 227 unspecific) 228 229(define (parse-file-inboxes buffer) 230 (let ((start (buffer-start buffer)) 231 (end (buffer-end buffer))) 232 (if (re-match-forward babyl-header-start-regexp start end false) 233 (let ((end 234 (if (re-search-forward babyl-header-end-regexp start end false) 235 (re-match-start 0) 236 end))) 237 (let ((start (search-forward "\nMail:" start end true))) 238 (if start 239 (parse-comma-list start (line-end start 0)) 240 '()))) 241 '()))) 242 243(define (parse-comma-list start end) 244 (let loop ((start start)) 245 (let ((start (skip-chars-forward " " start end))) 246 (let ((m (skip-chars-forward "^," start end))) 247 (cons (extract-string start (skip-chars-backward " " m start)) 248 (if (mark< m end) 249 (loop (mark1+ m)) 250 '())))))) 251 252(define-key 'rmail #\. 'beginning-of-buffer) 253(define-key 'rmail #\space 'scroll-up) 254(define-key 'rmail #\rubout 'scroll-down) 255(define-key 'rmail #\n 'rmail-next-undeleted-message) 256(define-key 'rmail #\p 'rmail-previous-undeleted-message) 257(define-key 'rmail #\m-n 'rmail-next-message) 258(define-key 'rmail #\m-p 'rmail-previous-message) 259(define-key 'rmail #\c-m-n 'rmail-next-labeled-message) 260(define-key 'rmail #\c-m-p 'rmail-previous-labeled-message) 261(define-key 'rmail #\a 'rmail-add-label) 262(define-key 'rmail #\k 'rmail-kill-label) 263(define-key 'rmail #\d 'rmail-delete-forward) 264(define-key 'rmail #\u 'rmail-undelete-previous-message) 265(define-key 'rmail #\e 'rmail-expunge) 266(define-key 'rmail #\x 'rmail-expunge) 267(define-key 'rmail #\s 'rmail-expunge-and-save) 268(define-key 'rmail #\g 'rmail-get-new-mail) 269(define-key 'rmail #\h 'rmail-summary) 270(define-key 'rmail #\c-m-h 'rmail-summary) 271(define-key 'rmail #\l 'rmail-summary-by-labels) 272(define-key 'rmail #\c-m-l 'rmail-summary-by-labels) 273(define-key 'rmail #\c-m-r 'rmail-summary-by-recipients) 274(define-key 'rmail #\t 'rmail-toggle-header) 275(define-key 'rmail #\m 'rmail-mail) 276(define-key 'rmail #\r 'rmail-reply) 277(define-key 'rmail #\c 'rmail-continue) 278(define-key 'rmail #\f 'rmail-forward) 279(define-key 'rmail #\m-s 'rmail-search) 280(define-key 'rmail #\j 'rmail-show-message) 281(define-key 'rmail #\o 'rmail-output-to-rmail-file) 282(define-key 'rmail #\c-o 'rmail-output) 283(define-key 'rmail #\i 'rmail-input) 284(define-key 'rmail #\q 'rmail-quit) 285(define-key 'rmail #\> 'rmail-last-message) 286(define-key 'rmail #\? 'describe-mode) 287(define-key 'rmail #\w 'rmail-edit-current-message) 288(define-key 'rmail #\c-d 'rmail-delete-backward) 289 290(define-key 'rmail-edit '(#\c-c #\c-c) 'rmail-cease-edit) 291(define-key 'rmail-edit '(#\c-c #\c-\]) 'rmail-abort-edit) 292 293(define-command rmail 294 "Read and edit incoming mail. 295Moves messages into file named by rmail-file-name (a babyl format file) 296 and edits that file in RMAIL Mode. 297Type \\[describe-mode] once editing that file, for a list of RMAIL commands. 298 299May be called with filename as argument; 300then performs rmail editing on that file, 301but does not copy any new mail into the file." 302 (lambda () 303 (list (and (command-argument) 304 (prompt-for-existing-file "Run rmail on RMAIL file" #f)))) 305 (lambda (filename) 306 (rmail-find-file (or filename (ref-variable rmail-file-name))) 307 (let ((mode (current-major-mode))) 308 (cond ((eq? mode (ref-mode-object rmail-edit)) 309 (editor-error "Exit rmail-edit mode before getting new mail")) 310 ((not (eq? mode (ref-mode-object rmail))) 311 (set-current-major-mode! (ref-mode-object rmail))))) 312 ;; This guarantees that a message is selected. This is desirable 313 ;; because the process of getting mail may perform prompting, and 314 ;; since this buffer is selected, it will appear to the user when 315 ;; the prompting occurs. By selecting a message, the buffer at 316 ;; least appears as the user expects it to. 317 (let ((buffer (current-buffer))) 318 (show-message buffer 319 (let ((memo (buffer-msg-memo buffer))) 320 (if (msg-memo? memo) 321 (msg-memo/number memo) 322 0)))) 323 (if (not filename) ((ref-command rmail-get-new-mail) #f)))) 324 325(define-command rmail-input 326 "Run RMAIL on file FILENAME." 327 "FRun rmail on RMAIL file" 328 (ref-command rmail)) 329 330(define (rmail-find-file filename) 331 (fluid-let ((after-find-file rmail-after-find-file)) 332 (find-file filename))) 333 334(define (rmail-find-file-revert buffer) 335 (fluid-let ((after-find-file rmail-after-find-file)) 336 (find-file-revert buffer))) 337 338(define (rmail-revert-buffer buffer dont-use-auto-save? dont-confirm?) 339 (let ((n 340 (let ((memo (buffer-msg-memo buffer))) 341 (and (msg-memo? memo) 342 (msg-memo/number memo))))) 343 (fluid-let ((after-find-file rmail-after-find-file)) 344 (revert-buffer-default buffer dont-use-auto-save? dont-confirm?)) 345 (show-message buffer 346 (and n 347 (let ((memo (buffer-msg-memo buffer))) 348 (and (msg-memo? memo) 349 (<= n (msg-memo/number (msg-memo/last memo))) 350 n))))) 351 buffer) 352 353(define (rmail-after-find-file buffer error? warn?) 354 error? warn? 355 (disable-buffer-auto-save! buffer) ;No need to auto save RMAIL files. 356 (convert-buffer-to-babyl-format buffer) 357 (set-buffer-major-mode! buffer (ref-mode-object rmail)) 358 buffer) 359 360(define-command rmail-quit 361 "Quit out of RMAIL." 362 () 363 (lambda () 364 ((ref-command rmail-expunge-and-save)) 365 ((ref-command bury-buffer)))) 366 367(define-command rmail-expunge-and-save 368 "Expunge and save RMAIL file." 369 () 370 (lambda () 371 ((ref-command rmail-expunge)) 372 ((ref-command save-buffer) false))) 373 374;;;; Mail input 375 376(define-command rmail-get-new-mail 377 "Move any new mail from this RMAIL file's inbox files. 378The inbox files can be specified with the file's Mail: option. 379The variable rmail-primary-inbox-list specifies the inboxes for 380your primary RMAIL file if it has no Mail: option. 381These are normally your ~/mbox and your /usr/spool/mail/$USER. 382 383You can also specify the file to get new mail from. In this 384case, the file of new mail is not changed or deleted. 385Noninteractively, you can pass the inbox file name as an argument. 386Interactively, a prefix argument causes us to read a file name 387and use that file as the inbox." 388 (lambda () 389 (list (and (command-argument) 390 (prompt-for-existing-file "Get new mail from file" #f)))) 391 (lambda (filename) 392 (let ((buffer (rmail-find-file-revert (current-buffer)))) 393 (let ((n-messages 394 (let ((memo (buffer-msg-memo buffer))) 395 (if (msg-memo? memo) 396 (msg-memo/number (msg-memo/last memo)) 397 0)))) 398 (with-buffer-open buffer 399 (lambda () 400 (with-buffer-undo-disabled buffer 401 (lambda () 402 (if filename 403 (get-new-mail buffer (list filename) false) 404 (get-new-mail buffer 405 (ref-variable rmail-inbox-list) 406 true)))))) 407 (show-message 408 buffer 409 (let ((memo (buffer-msg-memo buffer))) 410 (cond ((not (msg-memo? memo)) 0) 411 ((> (msg-memo/number (msg-memo/last memo)) n-messages) 412 (+ n-messages 1)) 413 (else (msg-memo/number memo))))) 414 (event-distributor/invoke! (ref-variable rmail-new-mail-hook)))))) 415 416(define (get-new-mail buffer inbox-list delete-inboxes?) 417 (let ((start (mark-right-inserting-copy (buffer-end buffer))) 418 (end (mark-left-inserting-copy (buffer-end buffer))) 419 (modified? (buffer-modified? buffer))) 420 (delete-string (skip-chars-backward " \t\n" end) end) 421 (let ((inserted-inboxes 422 (let loop ((filenames inbox-list) (result '())) 423 (if (null? filenames) 424 result 425 (loop (cdr filenames) 426 (let ((pathname 427 (insert-inbox-text buffer 428 end 429 (car filenames) 430 delete-inboxes?))) 431 (if pathname 432 (cons pathname result) 433 result))))))) 434 (let ((new-messages (convert-region-to-babyl-format start end))) 435 (if (> new-messages 0) 436 (begin 437 (memoize-messages buffer start end) 438 (save-buffer buffer 439 ;; If buffer has not changed yet, and has 440 ;; not been saved yet, don't replace the 441 ;; old backup file now. 442 (if (and (ref-variable make-backup-files buffer) 443 modified?) 444 false 445 'NO-BACKUP)))) 446 (if delete-inboxes? 447 (for-each delete-file-no-errors inserted-inboxes)) 448 (cond ((> new-messages 0) 449 (message new-messages 450 " new message" 451 (if (= new-messages 1) "" "s") 452 " read")) 453 ((not (null? inbox-list)) 454 (message "(No new mail has arrived)"))) 455 (mark-temporary! end) 456 (mark-temporary! start) 457 new-messages)))) 458 459(define (insert-inbox-text buffer mark inbox-name rename?) 460 (let ((insert 461 (lambda (pathname) 462 (and (file-exists? pathname) 463 (let ((mark (mark-left-inserting-copy mark))) 464 (insert-file mark pathname) 465 (if (let ((char (mark-left-char mark))) 466 (and char 467 (not (char=? char #\newline)) 468 (not (char=? char (integer->char #o037))))) 469 (insert-newline mark)) 470 (mark-temporary! mark) 471 pathname))))) 472 (cond ((string-prefix? "pop:" inbox-name) 473 (get-mail-from-pop-server (string-tail inbox-name 4) 474 insert 475 buffer)) 476 ((not rename?) 477 (insert inbox-name)) 478 ((string=? rmail-spool-directory (directory-namestring inbox-name)) 479 (rename-inbox-using-movemail inbox-name 480 insert 481 (buffer-default-directory buffer))) 482 (else 483 (rename-inbox-using-rename inbox-name insert))))) 484 485(define (rename-inbox-using-rename inbox-name insert) 486 (let ((target (string-append inbox-name "+"))) 487 (let ((msg (string-append "Getting mail from " inbox-name "..."))) 488 (message msg) 489 (if (and (file-exists? inbox-name) (not (file-exists? target))) 490 (rename-file inbox-name target)) 491 (let ((value (insert target))) 492 (message msg "done") 493 value)))) 494 495(define (rename-inbox-using-movemail inbox-name insert directory) 496 (let ((source 497 ;; On some systems, /usr/spool/mail/foo is a directory and 498 ;; the actual inbox is /usr/spool/mail/foo/foo. 499 (if (file-directory? inbox-name) 500 (merge-pathnames (pathname-name inbox-name) 501 (pathname-as-directory inbox-name)) 502 inbox-name)) 503 (target (merge-pathnames ".newmail" directory))) 504 (let ((msg 505 (string-append "Getting mail from " (->namestring source) "..."))) 506 (message msg) 507 (if (and (file-exists? source) 508 (not (file-exists? target))) 509 (let ((error-buffer (temporary-buffer " movemail errors"))) 510 (let ((start (buffer-start error-buffer)) 511 (end (buffer-end error-buffer))) 512 (run-synchronous-process 513 false start false false 514 (os/find-program "movemail" 515 (edwin-etc-directory) 516 (ref-variable exec-path)) 517 (->namestring source) 518 (->namestring target)) 519 (if (mark< start end) 520 (error 521 (let ((m 522 (or (match-forward "movemail: " start end false) 523 start))) 524 (string-append 525 "movemail: " 526 (extract-string 527 m 528 (skip-chars-backward " \t" (line-end m 0) m))))))) 529 (kill-buffer error-buffer))) 530 (let ((value (insert target))) 531 (message msg "done") 532 value)))) 533 534;;;; POP Support 535 536(define-variable rmail-pop-procedure 537 "A procedure that will get mail from a POP server. 538This procedure will be called with four arguments: 539 1. The server's name. 540 2. The user name on that server. 541 3. The password for that user. 542 4. The directory in which to temporarily store the mail. 543The procedure must return the name of the file in which the mail is 544stored. If there is no mail, this file must exist but be empty. 545 546A value of #F means there is no mechanism to get POP mail." 547 #f 548 (lambda (object) (or (not object) (procedure? object)))) 549 550(define-variable rmail-primary-pop-server 551 "The host name of a POP server to use as a default, or #F. 552If not #F, this server is used to initialize rmail-primary-inbox-list. 553Otherwise, rmail-primary-inbox-list is initialized to the operating 554system's mail inbox. 555 556If this variable is set, it is useful to initialize the variable 557rmail-pop-accounts with the corresponding account information. 558 559This variable is ignored if rmail-pop-procedure is #F." 560 #f 561 string-or-false?) 562 563(define-variable rmail-pop-accounts 564 "A list of lists, each of which specifies a POP account. 565Each element of the list is a list of three items: 566 567 1. The POP server host name, a string. 568 2. The user name to use with that server, a string. 569 3. The password to use for that account. 570 571Each server host name should appear only once; only the first entry 572with that name is used. 573 574The password field can take on several values. A string is the 575password to use. The symbol 'PROMPT-ONCE means to prompt the first 576time the password is needed, saving the password and reusing it 577subsequently. The symbol 'PROMPT-ALWAYS means to prompt each time 578that the password is needed. A list (FILE <filename>) means that the 579password is in the file <filename>. 580 581This variable is ignored if rmail-pop-procedure is #F." 582 '() 583 (lambda (object) 584 (and (list? object) 585 (for-all? object 586 (lambda (object) 587 (and (list? object) 588 (= 3 (length object)) 589 (string? (car object)) 590 (string? (cadr object)) 591 (let ((password (caddr object))) 592 (or (string? password) 593 (symbol? password) 594 (and (pair? password) 595 (eq? 'FILE (car password)) 596 (pair? (cdr password)) 597 (or (string? (cadr password)) 598 (pathname? (cadr password))) 599 (null? (cddr password))))))))))) 600 601(define (get-mail-from-pop-server server insert buffer) 602 (let ((procedure (ref-variable rmail-pop-procedure buffer))) 603 (and procedure 604 (call-with-values (lambda () (get-pop-account-info server buffer)) 605 (lambda (user-name password save-password?) 606 (let ((msg 607 (string-append "Getting mail from POP server " 608 server 609 "..."))) 610 (message msg) 611 (let ((value 612 (insert 613 (let ((filename 614 (procedure server user-name password 615 (buffer-default-directory buffer)))) 616 (if save-password? 617 ;; Password is saved only after 618 ;; successful execution of the client, to 619 ;; prevent saving an incorrect password. 620 (save-pop-server-password server 621 user-name 622 password)) 623 filename)))) 624 (message msg "done") 625 value))))))) 626 627(define (get-pop-account-info server buffer) 628 (let ((entry (assoc server (ref-variable rmail-pop-accounts buffer)))) 629 (if entry 630 (let ((user-name (cadr entry)) 631 (password (caddr entry))) 632 (cond ((eq? 'PROMPT-ONCE password) 633 (let ((password 634 (get-saved-pop-server-password server user-name))) 635 (if password 636 (values user-name password #f) 637 (values user-name 638 (prompt-for-pop-server-password server) 639 #t)))) 640 ((eq? 'PROMPT-ALWAYS password) 641 (values user-name (prompt-for-pop-server-password server) #f)) 642 ((or (string? password) (symbol? password)) 643 (values user-name password #f)) 644 ((and (pair? password) (eq? 'FILE (car password))) 645 (values user-name 646 (list 'FILE 647 (->namestring 648 (merge-pathnames (cadr password) 649 (user-homedir-pathname)))) 650 #f)) 651 (else 652 (error "Illegal password value in rmail-pop-accounts entry:" 653 password)))) 654 (let ((user-name 655 (prompt-for-string 656 (string-append "User name for POP server " server) 657 (current-user-name)))) 658 (values user-name (prompt-for-pop-server-password server) #f))))) 659 660(define (get-saved-pop-server-password server user-name) 661 (let ((entry (assoc (cons server user-name) saved-pop-passwords))) 662 (and entry 663 (cdr entry)))) 664 665(define (save-pop-server-password server user-name password) 666 (set! saved-pop-passwords 667 (cons (cons (cons server user-name) password) 668 saved-pop-passwords)) 669 unspecific) 670 671(define (delete-saved-pop-server-password server user-name) 672 (set! saved-pop-passwords 673 (del-assoc! (cons server user-name) saved-pop-passwords)) 674 unspecific) 675 676(define saved-pop-passwords '()) 677 678(define (prompt-for-pop-server-password server) 679 (call-with-pass-phrase (string-append "Password for POP server " server) 680 string-copy)) 681 682;;;; Moving around 683 684(define-command rmail-next-message 685 "Show following message whether deleted or not. 686With prefix argument N, moves forward N messages, 687or backward if N is negative." 688 "p" 689 (lambda (n) (move-to-message n (lambda (memo) memo #t) "message"))) 690 691(define-command rmail-previous-message 692 "Show previous message whether deleted or not. 693With prefix argument N, moves backward N messages, 694or forward if N is negative." 695 "p" 696 (lambda (n) ((ref-command rmail-next-message) (- n)))) 697 698(define-command rmail-next-undeleted-message 699 "Show following non-deleted message. 700With prefix argument N, moves forward N non-deleted messages, 701or backward if N is negative." 702 "p" 703 (lambda (n) 704 (move-to-message n 705 (lambda (memo) (not (msg-memo/deleted? memo))) 706 "undeleted message"))) 707 708(define-command rmail-previous-undeleted-message 709 "Show previous non-deleted message. 710With prefix argument N, moves backward N non-deleted messages, 711or forward if N is negative." 712 "p" 713 (lambda (n) ((ref-command rmail-next-undeleted-message) (- n)))) 714 715(define (move-to-message n predicate noun) 716 (if (not (= n 0)) 717 (call-with-values 718 (lambda () 719 (if (< n 0) 720 (values (- n) msg-memo/previous "previous") 721 (values n msg-memo/next "next"))) 722 (lambda (n step direction) 723 (let loop ((n n) (memo (current-msg-memo)) (winner #f)) 724 (let ((next 725 (let loop ((memo memo)) 726 (let ((next (step memo))) 727 (if (or (not next) (predicate next)) 728 next 729 (loop next)))))) 730 (cond ((not next) 731 (if winner (set-current-msg-memo! winner)) 732 (message "No " direction " " noun)) 733 ((= n 1) 734 (set-current-msg-memo! next)) 735 (else 736 (loop (- n 1) next next))))))))) 737 738(define-command rmail-next-labeled-message 739 "Show next message with one of the labels LABELS. 740LABELS should be a comma-separated list of label names. 741If LABELS is empty, the last set of labels specified is used. 742With prefix argument N moves forward N messages with these labels." 743 "p\nsMove to next msg with labels" 744 (lambda (n labels) 745 (let ((labels (check-multi-labels labels))) 746 (move-to-message n 747 (multi-labels-predicate labels) 748 (string-append "message with labels " labels))))) 749 750(define-command rmail-previous-labeled-message 751 "Show previous message with one of the labels LABELS. 752LABELS should be a comma-separated list of label names. 753If LABELS is empty, the last set of labels specified is used. 754With prefix argument N moves backward N messages with these labels." 755 "p\nsMove to previous msg with labels" 756 (lambda (n labels) ((ref-command rmail-next-labeled-message) (- n) labels))) 757 758(define (check-multi-labels labels) 759 (let ((labels (if (string-null? labels) rmail-last-multi-labels labels))) 760 (if (not labels) 761 (editor-error "No labels to find have been specified previously")) 762 (set! rmail-last-multi-labels labels) 763 labels)) 764 765(define rmail-last-multi-labels #f) 766 767(define (multi-labels-predicate labels) 768 (let ((regexp 769 (string-append " ?\\(" (multi-labels->regexp labels) "\\),"))) 770 (lambda (memo) 771 (let ((start (msg-memo/start memo))) 772 (with-group-open (mark-group start) 773 (lambda () 774 (let ((start (attributes-start-mark start))) 775 (re-search-forward regexp start (line-end start 0) #t)))))))) 776 777(define (multi-labels->regexp labels) 778 (apply string-append 779 (let ((labels (map string-trim (burst-string labels #\,)))) 780 (cons (car labels) 781 (append-map (lambda (label) (list "\\|" label)) 782 (cdr labels)))))) 783 784(define (burst-string string delimiter) 785 (let ((end (string-length string))) 786 (let loop ((start 0) (result '())) 787 (let ((index (substring-find-next-char string start end delimiter))) 788 (if index 789 (loop (fix:+ index 1) 790 (cons (substring string start index) result)) 791 (reverse! (cons (substring string start end) result))))))) 792 793(define-command rmail-show-message 794 "Show message number N (prefix argument), counting from start of file." 795 "p" 796 (lambda (n) 797 (show-message (current-buffer) n))) 798 799(define-command rmail-last-message 800 "Show last message in file." 801 () 802 (lambda () 803 (set-current-msg-memo! (last-msg-memo)))) 804 805(define-command rmail-search 806 "Show message containing next match for REGEXP. 807Search in reverse (earlier messages) with 2nd arg REVERSEP true. 808Interactively, empty argument means use same regexp used last time, 809and reverse search is specified by a negative numeric arg." 810 (lambda () 811 (let ((reverse? (< (command-argument-numeric-value (command-argument)) 0))) 812 (let ((regexp 813 (prompt-for-string (string-append (if reverse? "Reverse " "") 814 "Rmail search (regexp)") 815 search-last-regexp))) 816 (set! search-last-regexp regexp) 817 (list regexp reverse?)))) 818 (lambda (regexp reverse?) 819 (let ((buffer (current-buffer)) 820 (memo (current-msg-memo)) 821 (msg 822 (string-append (if reverse? "Reverse " "") 823 "Rmail search for " 824 regexp 825 "..."))) 826 (message msg) 827 (with-values 828 (lambda () 829 (without-clipping buffer 830 (lambda () 831 (if reverse? 832 (let loop ((memo memo)) 833 (let ((memo (msg-memo/previous memo))) 834 (cond ((not memo) 835 (values false false)) 836 ((re-search-backward regexp 837 (msg-memo/end-body memo) 838 (msg-memo/start-body memo)) 839 => 840 (lambda (mark) (values memo mark))) 841 (else 842 (loop memo))))) 843 (let loop ((memo memo)) 844 (let ((memo (msg-memo/next memo))) 845 (cond ((not memo) 846 (values false false)) 847 ((re-search-forward regexp 848 (msg-memo/start-body memo) 849 (msg-memo/end-body memo)) 850 => 851 (lambda (mark) (values memo mark))) 852 (else 853 (loop memo))))))))) 854 (lambda (memo mark) 855 (if memo 856 (let ((mark (mark-left-inserting-copy mark))) 857 (select-message buffer memo) 858 (set-current-point! mark) 859 (mark-temporary! mark) 860 (message msg "done")) 861 (editor-failure "Search failed: " regexp))))))) 862 863(define search-last-regexp 864 false) 865 866(define (show-message buffer n) 867 (if (not (eq? (buffer-major-mode buffer) (ref-mode-object rmail))) 868 (error "Can't change buffer message -- not in Rmail mode")) 869 (let ((memo (buffer-msg-memo buffer))) 870 (if (not (msg-memo? memo)) 871 (begin 872 (let ((start (buffer-start buffer))) 873 (let ((m 874 (re-search-backward babyl-header-end-regexp 875 (buffer-end buffer) 876 start 877 false))) 878 (if m 879 (narrow-to-region start (mark1+ m)))) 880 (set-buffer-point! buffer start)) 881 (if (current-buffer? buffer) 882 (begin 883 (update-mode-line! buffer) 884 (message "No messages")))) 885 (let ((last (msg-memo/last memo))) 886 (cond ((not n) 887 (select-message buffer last)) 888 ((<= 1 n (msg-memo/number last)) 889 (select-message buffer (msg-memo/nth memo n))) 890 ((current-buffer? buffer) 891 (message "No such message"))))))) 892 893(define (current-msg-memo) 894 (let ((memo (buffer-msg-memo (current-buffer)))) 895 (if (not (msg-memo? memo)) 896 (editor-error "No messages")) 897 memo)) 898 899(define (last-msg-memo) 900 (msg-memo/last (current-msg-memo))) 901 902(define (set-current-msg-memo! memo) 903 (select-message (mark-buffer (msg-memo/start memo)) memo)) 904 905(define (select-message buffer memo) 906 (let ((start (msg-memo/start memo))) 907 (set-buffer-msg-memo! buffer memo) 908 (widen start) 909 (let ((end (msg-memo/end memo))) 910 (if (match-forward "\f\n0" start end false) 911 (with-read-only-defeated start 912 (lambda () 913 (reformat-message start end)))) 914 (clear-attribute! memo 'UNSEEN) 915 (update-mode-line! buffer) 916 (let ((start (re-search-forward babyl-eooh-regexp start end false))) 917 (narrow-to-region start (mark-1+ end)) 918 (set-buffer-point! buffer start)) 919 (set-buffer-mark! buffer (mark-1+ end))))) 920 921(define (update-mode-line! buffer) 922 (define-variable-local-value! buffer (ref-variable-object mode-line-process) 923 (mode-line-summary-string buffer)) 924 (buffer-modeline-event! buffer 'PROCESS-STATUS)) 925 926(define (mode-line-summary-string buffer) 927 (let ((memo (buffer-msg-memo buffer))) 928 (and (msg-memo? memo) 929 (apply string-append 930 " " 931 (number->string (msg-memo/number memo)) 932 "/" 933 (number->string (msg-memo/number (msg-memo/last memo))) 934 (append-map! 935 (lambda (label) (list "," label)) 936 (append! (map symbol-name (msg-memo/attributes memo)) 937 (parse-labels (msg-memo/start memo)))))))) 938 939;;;; Message deletion 940 941(define-command rmail-delete-message 942 "Delete this message and stay on it." 943 () 944 (lambda () (set-attribute! (current-msg-memo) 'DELETED))) 945 946(define-command rmail-undelete-previous-message 947 "Back up to deleted message, select it, and undelete it." 948 () 949 (lambda () 950 (let ((memo (current-msg-memo))) 951 (if (msg-memo/deleted? memo) 952 (clear-attribute! memo 'DELETED) 953 (let ((memo (msg-memo/previous-deleted memo))) 954 (if (not memo) (editor-error "No previous deleted message")) 955 (clear-attribute! memo 'DELETED) 956 (set-current-msg-memo! memo)))))) 957 958(define-command rmail-delete-forward 959 "Delete this message and move to next nondeleted one. 960Deleted messages stay in the file until the \\[rmail-expunge] command is given. 961With prefix argument, delete and move backward." 962 "P" 963 (lambda (backward?) 964 (set-attribute! (current-msg-memo) 'DELETED) 965 ((ref-command rmail-next-undeleted-message) (if backward? -1 1)))) 966 967(define-command rmail-delete-backward 968 "Delete this message and move to previous nondeleted one. 969Deleted messages stay in the file until the \\[rmail-expunge] command is given." 970 () 971 (lambda () ((ref-command rmail-delete-forward) true))) 972 973(define-command rmail-expunge 974 "Actually erase all deleted messages in the file." 975 () 976 (lambda () 977 (let ((buffer (current-buffer))) 978 (let ((memo (buffer-msg-memo buffer))) 979 (if (msg-memo? memo) 980 (show-message 981 buffer 982 (with-buffer-open buffer (lambda () (expunge buffer memo))))))))) 983 984(define (expunge buffer current-memo) 985 (let ((new-memo 986 (if (not (msg-memo/deleted? current-memo)) 987 current-memo 988 (or (msg-memo/next-undeleted current-memo) 989 (msg-memo/previous-undeleted current-memo))))) 990 (let loop ((memo (msg-memo/first current-memo)) (n 1)) 991 (let ((next (msg-memo/next memo))) 992 (cond ((not (msg-memo/deleted? memo)) 993 (set-msg-memo/number! memo n) 994 (if next (loop next (+ n 1)))) 995 (next 996 (let ((start (msg-memo/start memo))) 997 (delete-string start (msg-memo/start next)) 998 (mark-temporary! start)) 999 (let ((previous (msg-memo/previous memo))) 1000 (if previous (set-msg-memo/next! previous next)) 1001 (set-msg-memo/previous! next previous)) 1002 (loop next n)) 1003 (else 1004 (let ((start (msg-memo/start memo)) 1005 (end (buffer-last-msg-end buffer))) 1006 (set-buffer-last-msg-end! buffer start) 1007 (delete-string start end) 1008 (mark-temporary! end)) 1009 (let ((previous (msg-memo/previous memo))) 1010 (if previous (set-msg-memo/next! previous false))))))) 1011 (if new-memo 1012 (begin 1013 (set-buffer-msg-memo! buffer new-memo) 1014 (msg-memo/number new-memo)) 1015 (begin 1016 (set-buffer-msg-memo! buffer true) 1017 false)))) 1018 1019;;;; Mailing commands 1020 1021(define-command rmail-mail 1022 "Send mail in another window. 1023While composing the message, use \\[mail-yank-original] to yank the 1024original message into it." 1025 () 1026 (lambda () 1027 (make-mail-buffer '(("To" "") ("Subject" "")) 1028 (current-buffer) 1029 select-buffer-other-window))) 1030 1031(define-command rmail-continue 1032 "Continue composing outgoing message previously being composed." 1033 () 1034 (lambda () 1035 ((ref-command mail-other-window) true))) 1036 1037(define-command rmail-forward 1038 "Forward the current message to another user." 1039 () 1040 (lambda () 1041 (let ((buffer (current-buffer)) 1042 (memo (current-msg-memo))) 1043 (set-attribute! memo 'FORWARDED) 1044 (make-mail-buffer 1045 (without-clipping buffer 1046 (lambda () 1047 (with-values (lambda () (original-header-limits memo)) 1048 (lambda (start end) 1049 `(("To" "") 1050 ("Subject" 1051 ,(string-append 1052 "[" 1053 (let ((from (fetch-first-field "from" start end))) 1054 (if from 1055 (rfc822:canonicalize-address-string from) 1056 "")) 1057 ": " 1058 (or (fetch-first-field "subject" start end) "") 1059 "]"))))))) 1060 #f 1061 (if (window-has-no-neighbors? (current-window)) 1062 select-buffer 1063 select-buffer-other-window)) 1064 (insert-region (buffer-start buffer) 1065 (buffer-end buffer) 1066 (buffer-end (current-buffer)))))) 1067 1068(define-command rmail-reply 1069 "Reply to the current message. 1070Normally include CC: to all other recipients of original message; 1071prefix argument means ignore them. 1072While composing the reply, use \\[mail-yank-original] to yank the 1073original message into it." 1074 "P" 1075 (lambda (just-sender?) 1076 (let ((buffer (current-buffer)) 1077 (memo (current-msg-memo))) 1078 (set-attribute! memo 'ANSWERED) 1079 (make-mail-buffer (without-clipping buffer 1080 (lambda () 1081 (rfc822-region-reply-headers 1082 (call-with-values 1083 (lambda () (original-header-limits memo)) 1084 make-region) 1085 (not just-sender?)))) 1086 buffer 1087 select-buffer-other-window)))) 1088 1089(define (rfc822-region-reply-headers region cc?) 1090 (let ((start (region-start region)) 1091 (end (region-end region))) 1092 (let ((resent-reply-to (fetch-last-field "resent-reply-to" start end)) 1093 (from (fetch-first-field "from" start end))) 1094 `(("To" 1095 ,(rfc822:canonicalize-address-string 1096 (or resent-reply-to 1097 (fetch-all-fields "reply-to" start end) 1098 from))) 1099 ("CC" 1100 ,(and cc? 1101 (let ((to 1102 (if resent-reply-to 1103 (fetch-last-field "resent-to" start end) 1104 (fetch-all-fields "to" start end))) 1105 (cc 1106 (if resent-reply-to 1107 (fetch-last-field "resent-cc" start end) 1108 (fetch-all-fields "cc" start end)))) 1109 (let ((cc 1110 (if (and to cc) 1111 (string-append to ", " cc) 1112 (or to cc)))) 1113 (and cc 1114 (let ((addresses 1115 (dont-reply-to (rfc822:string->addresses cc)))) 1116 (and (pair? addresses) 1117 (rfc822:addresses->string addresses)))))))) 1118 ("In-reply-to" 1119 ,(if resent-reply-to 1120 (make-in-reply-to-field 1121 from 1122 (fetch-last-field "resent-date" start end) 1123 (fetch-last-field "resent-message-id" start end)) 1124 (make-in-reply-to-field 1125 from 1126 (fetch-first-field "date" start end) 1127 (fetch-first-field "message-id" start end)))) 1128 ("Subject" 1129 ,(let ((subject 1130 (or (and resent-reply-to 1131 (fetch-last-field "resent-subject" 1132 start end)) 1133 (fetch-first-field "subject" start end)))) 1134 (cond ((not subject) "") 1135 ((ref-variable rmail-reply-with-re) 1136 (if (string-prefix-ci? "re:" subject) 1137 subject 1138 (string-append "Re: " subject))) 1139 (else 1140 (do ((subject 1141 subject 1142 (string-trim-left (string-tail subject 3)))) 1143 ((not (string-prefix-ci? "re:" subject)) 1144 subject)))))))))) 1145 1146(define (original-header-limits memo) 1147 (let ((start (msg-memo/start memo)) 1148 (end (msg-memo/end memo))) 1149 (if (match-forward "\f\n0" start end false) 1150 (begin 1151 (if (not (re-search-forward babyl-eooh-regexp start end false)) 1152 (editor-error)) 1153 (let ((hstart (re-match-end 0))) 1154 (values hstart (header-end hstart end)))) 1155 (values 1156 (let ((start (line-start start 2 'ERROR))) 1157 (if (match-forward "Summary-line:" start end true) 1158 (line-start start 1 'ERROR) 1159 start)) 1160 (begin 1161 (if (not (re-search-forward babyl-eooh-regexp start end false)) 1162 (editor-error)) 1163 (re-match-start 0)))))) 1164 1165(define (fetch-first-field field start end) 1166 (let ((fs (re-search-forward (field-name->regexp field) start end true))) 1167 (and fs 1168 (extract-field fs end)))) 1169 1170(define (fetch-last-field field start end) 1171 (and (re-search-backward (field-name->regexp field) end start true) 1172 (extract-field (re-match-end 0) end))) 1173 1174(define (fetch-all-fields field start end) 1175 (let ((strings 1176 (let ((regexp (field-name->regexp field))) 1177 (let loop ((start start)) 1178 (let ((fs (re-search-forward regexp start end true))) 1179 (if fs 1180 (let ((string (extract-field fs end)) 1181 (strings (loop fs))) 1182 (if string 1183 (cons string 1184 (if (null? strings) 1185 '() 1186 (cons ", " strings))) 1187 strings)) 1188 '())))))) 1189 (and (not (null? strings)) 1190 (apply string-append strings)))) 1191 1192(define (extract-field fs end) 1193 (let ((fe 1194 (skip-chars-backward " \t\n" 1195 (if (re-search-forward "^[^ \t]" fs end false) 1196 (re-match-start 0) 1197 end) 1198 fs))) 1199 (and (mark< fs fe) 1200 (extract-string fs fe)))) 1201 1202(define (field-name->regexp field) 1203 (string-append "^" (re-quote-string field) "[ \t]*:[ \t]*")) 1204 1205(define (header-end start end) 1206 (or (search-forward "\n\n" start end false) end)) 1207 1208(define (dont-reply-to addresses) 1209 (let ((pattern 1210 (re-compile-pattern 1211 (string-append "\\(.*!\\|\\)\\(" 1212 (ref-variable rmail-dont-reply-to-names) 1213 "\\)") 1214 true))) 1215 (let loop ((addresses addresses)) 1216 (cond ((null? addresses) 1217 '()) 1218 ((re-string-match pattern (car addresses)) 1219 (loop (cdr addresses))) 1220 (else 1221 (cons (car addresses) (loop (cdr addresses)))))))) 1222 1223(define (separated-append tokens separator) 1224 (if (null? (cdr tokens)) 1225 (car tokens) 1226 (apply string-append 1227 (let loop ((tokens tokens)) 1228 (if (null? (cdr tokens)) 1229 (list (car tokens)) 1230 (cons* (car tokens) separator (loop (cdr tokens)))))))) 1231 1232(define (make-in-reply-to-field from date message-id) 1233 (cond ((not from) 1234 message-id) 1235 (message-id 1236 ;; Append from field to message-id if needed. 1237 (let ((from (rfc822:first-address from))) 1238 (if (re-string-search-forward 1239 (let ((r (re-string-search-forward "@[^@]*\\'" from #f))) 1240 (if r 1241 (string-head from (re-match-start-index 0 r)) 1242 from)) 1243 message-id #t) 1244 message-id 1245 (string-append message-id " (" from ")")))) 1246 (else 1247 (let ((field (write-to-string (rfc822:first-address from)))) 1248 (if date 1249 (string-append field "'s message of " date) 1250 field))))) 1251 1252;;;; Address Extraction 1253 1254(define (strip-quoted-names-1 tokens) 1255 (define (parse-addr-spec tokens) 1256 (let ((local-part (parse-list tokens parse-word #\.))) 1257 (and local-part 1258 (not (null? (cdr local-part))) 1259 (eqv? #\@ (cadr local-part)) 1260 (let ((domain (parse-domain (cddr local-part)))) 1261 (and domain 1262 (cons (string-append (separated-append (car local-part) ".") 1263 "@" 1264 (separated-append (car domain) ".")) 1265 (cdr domain))))))) 1266 (define (parse-domain tokens) 1267 (parse-list tokens 1268 (lambda (tokens) 1269 (and (not (null? tokens)) 1270 (string? (car tokens)) 1271 (not (eqv? #\" (string-ref (car tokens) 0))) 1272 tokens)) 1273 #\.)) 1274 (define (parse-list tokens parse-element separator) 1275 (let ((first (parse-element tokens))) 1276 (and first 1277 (let loop ((tokens (cdr first)) (words (list (car first)))) 1278 (let ((next 1279 (and (not (null? tokens)) 1280 (eqv? separator (car tokens)) 1281 (parse-element (cdr tokens))))) 1282 (if next 1283 (loop (cdr next) (cons (car next) words)) 1284 (cons (reverse! words) tokens))))))) 1285 (define (parse-word tokens) 1286 (and (not (null? tokens)) 1287 (string? (car tokens)) 1288 (not (eqv? #\[ (string-ref (car tokens) 0))) 1289 tokens)) 1290 (parse-list 1291 tokens 1292 (lambda (tokens) 1293 (or (parse-addr-spec tokens) 1294 (let ((word (parse-word tokens))) 1295 (and word 1296 (let ((tokens 1297 (let loop ((tokens (cdr word))) 1298 (let ((word (parse-word tokens))) 1299 (if word 1300 (loop (cdr word)) 1301 tokens))))) 1302 (and (not (null? tokens)) 1303 (eqv? #\< (car tokens)) 1304 (let ((addr-spec 1305 (parse-addr-spec 1306 (let ((domains 1307 (parse-list 1308 (cdr tokens) 1309 (lambda (tokens) 1310 (and (not (null? tokens)) 1311 (eqv? #\@ (car tokens)) 1312 (parse-domain (cdr tokens)))) 1313 #\,))) 1314 (if (and domains 1315 (not (null? (cdr domains))) 1316 (eqv? #\: (cadr domains))) 1317 (cddr domains) 1318 (cdr tokens)))))) 1319 (and addr-spec 1320 (not (null? (cdr addr-spec))) 1321 (eqv? #\> (cadr addr-spec)) 1322 (cons (car addr-spec) (cddr addr-spec)))))))))) 1323 #\,)) 1324 1325;;;; Mail output 1326 1327(define-command rmail-output-to-rmail-file 1328 "Append the current message to an Rmail file named FILE-NAME. 1329If the file does not exist, ask if it should be created. 1330If file is being visited, the message is appended to the 1331buffer visiting that file." 1332 (lambda () 1333 (list (prompt-for-rmail-output-filename 1334 "Output message to Rmail file" 1335 (ref-variable rmail-last-rmail-file)))) 1336 (lambda (pathname) 1337 (set-variable! rmail-last-rmail-file (->namestring pathname)) 1338 (let ((memo (current-msg-memo))) 1339 (rmail-output-to-rmail-file (make-region (msg-memo/start memo) 1340 (msg-memo/end memo)) 1341 pathname) 1342 (set-attribute! memo 'FILED) 1343 (if (ref-variable rmail-delete-after-output) 1344 ((ref-command rmail-delete-forward) #f))))) 1345 1346(define (rmail-output-to-rmail-file region pathname) 1347 ;; REGION is assumed to be in babyl format. 1348 (let ((buffer (pathname->buffer pathname))) 1349 (if buffer 1350 (begin 1351 (if (eq? buffer (mark-buffer (region-start region))) 1352 (editor-error 1353 "Can't output message to same file it's already in")) 1354 (with-buffer-open buffer 1355 (lambda () 1356 (let ((memo (buffer-msg-memo buffer)) 1357 (end (buffer-end buffer))) 1358 (let ((start (mark-right-inserting-copy end)) 1359 (end (mark-left-inserting-copy end))) 1360 (if memo 1361 (delete-string (skip-chars-backward " \t\n" end) 1362 end)) 1363 (insert-region (region-start region) 1364 (region-end region) 1365 end) 1366 (if memo 1367 (begin 1368 (memoize-messages buffer start end) 1369 (select-message buffer memo))) 1370 (mark-temporary! start) 1371 (mark-temporary! end)))))) 1372 (begin 1373 (if (not (file-exists? pathname)) 1374 (begin 1375 (if (not (prompt-for-yes-or-no? 1376 (string-append "\"" (->namestring pathname) 1377 "\" does not exist, create it"))) 1378 (editor-error "Output file does not exist.")) 1379 (call-with-temporary-buffer " rmail output" 1380 (lambda (buffer) 1381 (insert-string babyl-initial-header (buffer-start buffer)) 1382 (write-region (buffer-region buffer) pathname #f #f))))) 1383 (append-to-file region pathname #f #f))))) 1384 1385(define-command rmail-output 1386 "Append this message to Unix mail file named FILE-NAME." 1387 (lambda () 1388 (list (prompt-for-rmail-output-filename "Output message to Unix mail file" 1389 (ref-variable rmail-last-file)))) 1390 (lambda (filename) 1391 (set-variable! rmail-last-file (->namestring filename)) 1392 (let ((memo (current-msg-memo))) 1393 (rmail-output-to-unix-mail-file (buffer-region (current-buffer)) 1394 filename) 1395 (set-attribute! memo 'FILED) 1396 (if (ref-variable rmail-delete-after-output) 1397 ((ref-command rmail-delete-forward) #f))))) 1398 1399(define (rmail-output-to-unix-mail-file region pathname) 1400 ;; REGION is assumed to be in RFC-822 format. 1401 (let ((buffer (temporary-buffer " rmail output"))) 1402 (let ((end (mark-left-inserting-copy (buffer-end buffer)))) 1403 (insert-region (region-start region) (region-end region) end) 1404 (insert-newline end) 1405 (let loop ((start (buffer-start buffer))) 1406 (if (re-search-forward "^From " start end #t) 1407 (loop (replace-match ">\\&")))) 1408 (mark-temporary! end) 1409 (let ((start (buffer-start buffer))) 1410 (insert-string 1411 (string-append 1412 "From " 1413 (or (rfc822:first-address 1414 (fetch-first-field "from" start (header-end start end))) 1415 "unknown") 1416 " " 1417 (universal-time->local-ctime-string (get-universal-time)) 1418 "\n") 1419 start))) 1420 (define-variable-local-value! buffer 1421 (ref-variable-object translate-file-data-on-output) 1422 #f) 1423 (append-to-file (buffer-region buffer) pathname #f #f) 1424 (kill-buffer buffer))) 1425 1426(define (prompt-for-rmail-output-filename prompt default) 1427 (->namestring 1428 (let ((pathname 1429 (prompt-for-pathname 1430 (string-append prompt " (default " (file-namestring default) ")") 1431 (directory-pathname default)))) 1432 (if (file-directory? pathname) 1433 (merge-pathnames (file-pathname default) 1434 (pathname-as-directory pathname)) 1435 pathname)))) 1436 1437;;;; Editing 1438 1439(define-command rmail-edit-current-message 1440 "Edit the current RMAIL message." 1441 '() 1442 (lambda () 1443 (let ((buffer (current-buffer))) 1444 (set-buffer-major-mode! buffer (ref-mode-object rmail-edit)) 1445 (buffer-put! buffer 1446 'RMAIL-OLD-TEXT 1447 (extract-string (buffer-start buffer) 1448 (buffer-end buffer))) 1449 (set-buffer-writeable! buffer) 1450 (message 1451 (substitute-command-keys 1452 "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort." 1453 buffer))))) 1454 1455(define-command rmail-cease-edit 1456 "Finish editing message; switch back to Rmail proper." 1457 () 1458 (lambda () 1459 (let ((buffer (current-buffer))) 1460 (guarantee-newline (buffer-end buffer)) 1461 (set-buffer-major-mode! buffer (ref-mode-object rmail)) 1462 (with-buffer-open buffer 1463 (lambda () 1464 (memoize-buffer buffer) 1465 (let ((memo (buffer-msg-memo buffer))) 1466 (if (msg-memo? memo) 1467 (let ((first (msg-memo/first memo)) 1468 (point (current-point))) 1469 (if (mark<= (msg-memo/start first) point) 1470 (let loop ((memo first)) 1471 (if memo 1472 (if (mark< point (msg-memo/end memo)) 1473 (begin 1474 ; Need to force a recalc of the summary line 1475 ; after message edit 1476 (let ((rmail-summary-buffer 1477 (ref-variable rmail-summary-buffer))) 1478 (if rmail-summary-buffer 1479 (let ((rmail-summary-vector 1480 (ref-variable 1481 rmail-summary-vector 1482 rmail-summary-buffer))) 1483 (if rmail-summary-vector 1484 (vector-set! 1485 rmail-summary-vector 1486 (- (msg-memo/number memo) 1) 1487 false))))) 1488 (let ((point 1489 (line-start (msg-memo/start memo) 2))) 1490 (if (string-prefix? 1491 "Summary-line: " 1492 (extract-string point 1493 (line-end point 0))) 1494 (delete-string point 1495 (line-start point 1)))) 1496 (select-message buffer memo)) 1497 (loop (msg-memo/next memo)))))))))))))) 1498 1499(define-command rmail-abort-edit 1500 "Abort edit of current message; restore original contents." 1501 () 1502 (lambda () 1503 (let ((buffer (current-buffer))) 1504 (let ((text (buffer-get buffer 'RMAIL-OLD-TEXT))) 1505 (if text 1506 (begin 1507 (delete-string (buffer-start buffer) 1508 (buffer-end buffer)) 1509 (insert-string text (buffer-start buffer))) 1510 (message "Can't restore buffer contents.")))) 1511 ((ref-command rmail-cease-edit)))) 1512 1513;;;; Undigestifier 1514 1515(define-command undigestify-rmail-message 1516 "Break up a digest message into its constituent messages. 1517Leaves original message, deleted, before the undigestified messages." 1518 () 1519 (lambda () 1520 (let ((buffer (current-buffer)) 1521 (memo (current-msg-memo))) 1522 (let ((temp (temporary-buffer " rmail undigestify"))) 1523 (let ((start (buffer-start temp)) 1524 (end (mark-left-inserting-copy (buffer-end temp)))) 1525 (insert-string babyl-initial-message-start end) 1526 (insert-region (buffer-start buffer) (buffer-end buffer) end) 1527 (delete-string (skip-chars-backward " \t\n" end start) end) 1528 (insert-string "\n\037" end) 1529 (let ((digest-name 1530 (rfc822:first-address 1531 (let ((hend (header-end start end))) 1532 (or (fetch-first-field "Reply-To" start hend) 1533 (fetch-first-field "To" start hend) 1534 (fetch-first-field "Apparently-To" start hend) 1535 (fetch-first-field "From" start hend)))))) 1536 (if (not digest-name) 1537 (editor-error "Message is not a digest--bad header.")) 1538 (if (not (re-search-backward digest-end-regexp end start #t)) 1539 (editor-error "Message is not a digest--no end line.")) 1540 (let ((start 1541 (mark-left-inserting-copy (digest-summary-end start end)))) 1542 (if (not (fetch-first-field "To" start (header-end start end))) 1543 (begin 1544 (insert-string "To: " start) 1545 (insert-string digest-name start) 1546 (insert-newline start))) 1547 (let loop () 1548 (let ((m (digest-message-end start end))) 1549 (if m 1550 (begin 1551 (move-mark-to! start m) 1552 (if (or (match-forward "End " start end true) 1553 (not 1554 (fetch-first-field "To" 1555 start 1556 (header-end start end)))) 1557 (begin 1558 (insert-string "To: " start) 1559 (insert-string digest-name start) 1560 (insert-string "\n\n" start))) 1561 (loop))))) 1562 (mark-temporary! start))) 1563 (mark-temporary! end)) 1564 (message "Message successfully undigestified") 1565 (with-buffer-open buffer 1566 (lambda () 1567 (let* ((end (msg-memo/end memo)) 1568 (start (mark-right-inserting-copy end))) 1569 (insert-region (buffer-start temp) 1570 (buffer-end temp) 1571 end) 1572 (kill-buffer temp) 1573 (memoize-messages-insert buffer start end memo) 1574 (mark-temporary! start))))) 1575 (show-message buffer (msg-memo/number memo)) 1576 ((ref-command rmail-delete-forward) false)))) 1577 1578(define (digest-summary-end start end) 1579 (if (not (re-search-forward digest-summary-separator-regexp 1580 (header-end start end) end #f)) 1581 (editor-error "Missing summary separator")) 1582 (replace-match digest-separator-replacement)) 1583 1584(define (digest-message-end start end) 1585 (and (re-search-forward digest-message-separator-regexp start end false) 1586 (replace-match digest-separator-replacement))) 1587 1588;;;; Message memoization 1589 1590(define (memoize-buffer buffer) 1591 (let ((end (buffer-end buffer))) 1592 (let ((m 1593 (re-match-forward babyl-header-start-regexp 1594 (buffer-start buffer) 1595 end 1596 false))) 1597 (if m 1598 (let ((m (re-search-forward babyl-header-end-regexp m end false))) 1599 (if m 1600 (begin 1601 (set-buffer-msg-memo! buffer #f) 1602 (memoize-messages buffer m end)))))))) 1603 1604(define (memoize-messages buffer start end) 1605 (let ((memo (buffer-msg-memo buffer))) 1606 (with-values 1607 (lambda () 1608 (memoize-messages* start 1609 end 1610 (and (msg-memo? memo) (msg-memo/last memo)))) 1611 (lambda (start tail) 1612 (if (not (msg-memo? memo)) 1613 (set-buffer-msg-memo! buffer (or tail true))) 1614 (let ((old-end (buffer-last-msg-end buffer))) 1615 (if old-end 1616 (mark-temporary! old-end))) 1617 (set-buffer-last-msg-end! buffer start))))) 1618 1619(define (memoize-messages-insert buffer start end memo) 1620 (let ((next (msg-memo/next memo))) 1621 (if (not next) 1622 (memoize-messages buffer start end) 1623 (with-values (lambda () (memoize-messages* start end memo)) 1624 (lambda (start tail) 1625 (mark-temporary! start) 1626 (set-msg-memo/next! tail next) 1627 (set-msg-memo/previous! next tail) 1628 (let loop ((memo next) (n (+ (msg-memo/number tail) 1))) 1629 (set-msg-memo/number! memo n) 1630 (if (msg-memo/next memo) 1631 (loop (msg-memo/next memo) (+ n 1))))))))) 1632 1633(define (memoize-messages* start end tail) 1634 (message "Counting messages...") 1635 (let loop ((start (mark-left-inserting-copy start)) (tail tail) (n 1)) 1636 (let ((mend (search-forward babyl-message-end-regexp start end false))) 1637 (if mend 1638 (let ((mend (mark-left-inserting-copy mend))) 1639 (canonicalize-message-attributes start) 1640 (let ((memo 1641 (make-msg-memo tail 1642 false 1643 start 1644 (if tail (+ (msg-memo/number tail) 1) 1) 1645 (parse-attributes start)))) 1646 (if tail 1647 (set-msg-memo/next! tail memo)) 1648 (if (zero? (remainder n 20)) 1649 (message "Counting messages..." n)) 1650 (loop mend memo (+ n 1)))) 1651 (begin 1652 (message "Counting messages...done") 1653 (values start tail)))))) 1654 1655(define-integrable (buffer-msg-memo buffer) 1656 (buffer-get buffer 'RMAIL-MSG-MEMO)) 1657 1658(define-integrable (set-buffer-msg-memo! buffer memo) 1659 (buffer-put! buffer 'RMAIL-MSG-MEMO memo)) 1660 1661(define-integrable (buffer-last-msg-end buffer) 1662 (buffer-get buffer 'RMAIL-LAST-MSG-END)) 1663 1664(define-integrable (set-buffer-last-msg-end! buffer memo) 1665 (buffer-put! buffer 'RMAIL-LAST-MSG-END memo)) 1666 1667(define-structure (msg-memo (conc-name msg-memo/)) 1668 previous 1669 next 1670 (start false read-only true) 1671 number 1672 attributes) 1673 1674(define (msg-memo/end memo) 1675 (let ((next (msg-memo/next memo))) 1676 (if next 1677 (msg-memo/start next) 1678 (buffer-last-msg-end (mark-buffer (msg-memo/start memo)))))) 1679 1680(define (msg-memo/start-body memo) 1681 (let ((start (msg-memo/start memo))) 1682 (or (re-search-forward babyl-eooh-regexp start (msg-memo/end memo) false) 1683 start))) 1684 1685(define (msg-memo/end-body memo) 1686 (mark-1+ (msg-memo/end memo))) 1687 1688(define (msg-memo/first memo) 1689 (let loop ((memo memo)) 1690 (let ((previous (msg-memo/previous memo))) 1691 (if previous 1692 (loop previous) 1693 memo)))) 1694 1695(define (msg-memo/last memo) 1696 (let loop ((memo memo)) 1697 (let ((next (msg-memo/next memo))) 1698 (if next 1699 (loop next) 1700 memo)))) 1701 1702(define (msg-memo/nth memo n) 1703 (if (= n (msg-memo/number memo)) 1704 memo 1705 (let ((msg-memo/next 1706 (if (< n (msg-memo/number memo)) 1707 msg-memo/previous 1708 msg-memo/next))) 1709 (let loop ((memo memo)) 1710 (let ((next (msg-memo/next memo))) 1711 (cond ((not next) memo) 1712 ((= n (msg-memo/number next)) next) 1713 (else (loop next)))))))) 1714 1715(define-integrable (msg-memo/deleted? memo) 1716 (memq 'DELETED (msg-memo/attributes memo))) 1717 1718(define (msg-memo/next-undeleted memo) 1719 (let ((next (msg-memo/next memo))) 1720 (and next 1721 (if (msg-memo/deleted? next) 1722 (msg-memo/next-undeleted next) 1723 next)))) 1724 1725(define (msg-memo/previous-undeleted memo) 1726 (let ((previous (msg-memo/previous memo))) 1727 (and previous 1728 (if (msg-memo/deleted? previous) 1729 (msg-memo/previous-undeleted previous) 1730 previous)))) 1731 1732(define (msg-memo/previous-deleted memo) 1733 (let ((previous (msg-memo/previous memo))) 1734 (and previous 1735 (if (msg-memo/deleted? previous) 1736 previous 1737 (msg-memo/previous-deleted previous))))) 1738 1739;;;; Attributes and Labels 1740 1741(define-command rmail-add-label 1742 "Add LABEL to labels associated with current RMAIL message. 1743Completion is performed over known labels when reading." 1744 (lambda () (list (rmail-read-label "Add label" #f))) 1745 (lambda (label) 1746 (let ((memo (current-msg-memo)) 1747 (attribute (label->attribute label))) 1748 (if attribute 1749 (set-attribute! memo attribute) 1750 (set-keyword! memo label))))) 1751 1752(define-command rmail-kill-label 1753 "Remove LABEL from labels associated with current RMAIL message. 1754Completion is performed over known labels when reading." 1755 (lambda () (list (rmail-read-label "Remove label" #t))) 1756 (lambda (label) 1757 (let ((memo (current-msg-memo)) 1758 (attribute (label->attribute label))) 1759 (if attribute 1760 (clear-attribute! memo attribute) 1761 (clear-keyword! memo label))))) 1762 1763(define (rmail-read-label prompt require-match?) 1764 (let ((label 1765 (prompt-for-string-table-name 1766 prompt 1767 rmail-last-label 1768 (alist->string-table 1769 (map list 1770 (append! (map symbol-name attributes) 1771 (buffer-keywords (current-buffer))))) 1772 'REQUIRE-MATCH? require-match?))) 1773 (set! rmail-last-label label) 1774 label)) 1775 1776(define rmail-last-label #f) 1777 1778(define (canonicalize-message-attributes mstart) 1779 (let ((start (attributes-start-mark mstart))) 1780 (let ((end (line-end start 0))) 1781 (let loop ((m start) (in-labels? false)) 1782 (cond ((re-match-forward " [^ ,]+," m end false) 1783 (loop (re-match-end 0) in-labels?)) 1784 ((and (not in-labels?) (match-forward "," m end false)) 1785 => (lambda (m) (loop m true))) 1786 ((and in-labels? (mark= m end)) 1787 unspecific) 1788 ((re-match-forward " *\\([^ ,]+\\)," m end false) 1789 (loop (replace-match " \\1,") in-labels?)) 1790 ((and (not in-labels?) (re-match-forward " +," m end false)) 1791 (loop (replace-match ",") true)) 1792 ((and in-labels? (re-match-forward " +$" m end false)) 1793 (delete-match)) 1794 (else 1795 (editor-error "Malformed message attributes: " 1796 (extract-string start end)))))))) 1797 1798(define (set-attribute! memo attribute) 1799 (if (not (memq attribute (msg-memo/attributes memo))) 1800 (begin 1801 (set-msg-memo/attributes! memo 1802 (cons attribute 1803 (msg-memo/attributes memo))) 1804 (let ((start (msg-memo/start memo))) 1805 (with-group-open (mark-group start) 1806 (lambda () 1807 (insert-string (attribute->string attribute) 1808 (attributes-end-mark start)) 1809 (update-mode-line! (mark-buffer start)))))))) 1810 1811(define (clear-attribute! memo attribute) 1812 (if (memq attribute (msg-memo/attributes memo)) 1813 (begin 1814 (set-msg-memo/attributes! memo 1815 (delq! attribute 1816 (msg-memo/attributes memo))) 1817 (let ((start (msg-memo/start memo))) 1818 (with-group-open (mark-group start) 1819 (lambda () 1820 (if (search-forward (attribute->string attribute) 1821 (attributes-start-mark start) 1822 (attributes-end-mark start) 1823 true) 1824 (delete-match)) 1825 (update-mode-line! (mark-buffer start)))))))) 1826 1827(define (attribute->string attribute) 1828 (string-append " " (string-downcase (symbol-name attribute)) ",")) 1829 1830(define (label->attribute label) 1831 (let ((s (intern-soft label))) 1832 (and s 1833 (memq s attributes) 1834 s))) 1835 1836(define attributes 1837 '(DELETED ANSWERED FILED FORWARDED UNSEEN EDITED RESENT)) 1838 1839(define (set-keyword! memo keyword) 1840 (let ((mstart (msg-memo/start memo)) 1841 (ks (keyword->string keyword))) 1842 (with-group-open (mark-group mstart) 1843 (lambda () 1844 (if (not (search-forward ks 1845 (labels-start-mark mstart) 1846 (labels-end-mark mstart) 1847 #t)) 1848 (insert-string ks (labels-end-mark mstart))) 1849 (let ((buffer (mark-buffer mstart))) 1850 (if (not (member keyword (buffer-keywords buffer))) 1851 (begin 1852 (buffer-remove! buffer 'RMAIL-KEYWORDS) 1853 (insert-string 1854 (string-append "," keyword) 1855 (line-end (or (keywords-start-mark buffer) 1856 (let ((s (line-end (buffer-start buffer) 0))) 1857 (insert-string "\nLabels:" s) 1858 (mark1+ s))) 1859 0))))) 1860 (update-mode-line! (mark-buffer mstart)))))) 1861 1862(define (clear-keyword! memo keyword) 1863 (let ((mstart (msg-memo/start memo))) 1864 (with-group-open (mark-group mstart) 1865 (lambda () 1866 (if (search-forward (keyword->string keyword) 1867 (labels-start-mark mstart) 1868 (labels-end-mark mstart) 1869 #t) 1870 (delete-match)) 1871 (update-mode-line! (mark-buffer mstart)))))) 1872 1873(define (keyword->string keyword) 1874 (string-append " " (string-downcase keyword) ",")) 1875 1876(define (buffer-keywords buffer) 1877 (cdr (or (buffer-get buffer 'RMAIL-KEYWORDS #f) 1878 (let ((keywords (cons 'RMAIL-KEYWORDS (parse-keywords buffer)))) 1879 (buffer-put! buffer 'RMAIL-KEYWORDS keywords) 1880 keywords)))) 1881 1882(define (attributes-start-mark mstart) 1883 (let ((m 1884 (re-match-forward babyl-message-start-regexp 1885 mstart 1886 (group-end mstart) 1887 false))) 1888 (if (not m) 1889 (editor-error "Mark not at message start: " mstart)) 1890 m)) 1891 1892(define (attributes-end-mark mstart) 1893 (mark-1+ (labels-start-mark mstart))) 1894 1895(define (labels-start-mark mstart) 1896 (let ((m 1897 (let ((lstart (line-start mstart 1 'ERROR))) 1898 (search-forward ",," lstart (line-end lstart 0) false)))) 1899 (if (not m) 1900 (editor-error "Can't find attributes/labels separator")) 1901 m)) 1902 1903(define (labels-end-mark mstart) 1904 (line-end mstart 1 'ERROR)) 1905 1906(define (parse-attributes mstart) 1907 (map intern 1908 (parse-label-list (attributes-start-mark mstart) 1909 (attributes-end-mark mstart)))) 1910 1911(define (parse-labels mstart) 1912 (parse-label-list (labels-start-mark mstart) 1913 (labels-end-mark mstart))) 1914 1915(define (parse-keywords buffer) 1916 (with-buffer-open buffer 1917 (lambda () 1918 (let ((start (keywords-start-mark buffer))) 1919 (if start 1920 (parse-label-list start (line-end start 0)) 1921 '()))))) 1922 1923(define (keywords-start-mark buffer) 1924 (search-forward "\nLabels:" 1925 (buffer-start buffer) 1926 (msg-memo/start (msg-memo/first (buffer-msg-memo buffer))) 1927 #t)) 1928 1929(define (parse-label-list start end) 1930 (let loop ((m start)) 1931 (if (mark< m end) 1932 (let ((aend (char-search-forward #\, m end false))) 1933 (let ((label 1934 (string-downcase 1935 (string-trim 1936 (extract-string m (if aend (mark-1+ aend) end))))) 1937 (rest (if aend (loop aend) '()))) 1938 (if (string-null? label) 1939 rest 1940 (cons label rest)))) 1941 '()))) 1942 1943(define-command rmail-toggle-header 1944 "Show original message header if pruned header currently shown, or vice versa." 1945 () 1946 (lambda () 1947 (let ((buffer (current-buffer))) 1948 (let ((memo (current-msg-memo))) 1949 (with-buffer-open buffer 1950 (lambda () 1951 (let ((start (msg-memo/start memo)) 1952 (end (msg-memo/end memo))) 1953 (cond ((match-forward "\f\n0" start end false) 1954 (reformat-message start end)) 1955 ((match-forward "\f\n1" start end false) 1956 (unformat-message start end))))))) 1957 (set-current-point! (buffer-start buffer))))) 1958 1959(define (reformat-message start end) 1960 (let ((m (mark+ start 2))) 1961 (delete-right-char m) 1962 (insert-char #\1 m)) 1963 (if (not (re-search-forward babyl-eooh-regexp start end false)) 1964 (editor-error)) 1965 (let ((eooh (re-match-start 0))) 1966 (let ((hstart (mark-right-inserting-copy (line-start eooh 1 'ERROR)))) 1967 (let ((hend 1968 (let ((m (search-forward "\n\n" hstart end false))) 1969 (if m 1970 (mark-left-inserting-copy m) 1971 (let ((m (mark-left-inserting-copy end))) 1972 (if (char-match-backward #\newline m) 1973 (insert-newline m) 1974 (insert-newlines 2 m)) 1975 m))))) 1976 (insert-string (extract-string hstart hend) eooh) 1977 (let ((regexp (ref-variable rmail-ignored-headers))) 1978 (if regexp 1979 (do () 1980 ((not (re-search-forward regexp hstart hend true))) 1981 (let ((m (line-start (re-match-start 0) 0))) 1982 (delete-string 1983 m 1984 (mark-1+ (re-search-forward "\n[^ \t]" m hend false))))))) 1985 (let ((filter (ref-variable rmail-message-filter))) 1986 (if filter 1987 (filter hstart hend))) 1988 (mark-temporary! hend) 1989 (mark-temporary! hstart))))) 1990 1991(define (unformat-message start end) 1992 (let ((m (mark+ start 2))) 1993 (delete-right-char m) 1994 (insert-char #\0 m)) 1995 (let ((start 1996 (let ((start (line-start start 2 'ERROR))) 1997 (if (match-forward "Summary-line:" start end true) 1998 (line-start start 1 'ERROR) 1999 start)))) 2000 (if (not (re-search-forward babyl-eooh-regexp start end false)) 2001 (editor-error)) 2002 (let ((header (extract-and-delete-string start (re-match-start 0)))) 2003 (let ((hstart (line-start start 1))) 2004 (delete-string hstart (header-end hstart end)) 2005 (insert-string header hstart))))) 2006 2007;;;; Mail conversion 2008 2009(define (convert-region-to-babyl-format start end) 2010 (define (loop point count) 2011 (text-clip point end) 2012 (cond ((mark= point end) 2013 count) 2014 ((re-match-forward babyl-header-start-regexp point end false) 2015 (delete-string 2016 point 2017 (or (search-forward babyl-header-end-regexp point end false) end)) 2018 (loop point count)) 2019 ((re-match-forward babyl-message-start-regexp point end false) 2020 (let ((m 2021 (or (search-forward babyl-message-end-regexp point end false) 2022 (missing-end end "Babyl")))) 2023 (delete-string m (skip-chars-forward " \t\n" m end)) 2024 (loop m (+ count 1)))) 2025 ((re-match-forward umail-message-start-regexp point end false) 2026 (let ((point (mark-right-inserting-copy point)) 2027 (end (mark-left-inserting-copy end))) 2028 (nuke-pinhead-header point end) 2029 (mark-temporary! end) 2030 (mark-temporary! point) 2031 (process-rfc822 2032 point 2033 count 2034 (if (re-search-forward umail-message-end-regexp point end false) 2035 (re-match-start 0) 2036 end)))) 2037 ((re-match-forward mmdf-message-start-regexp point end true) 2038 (let ((start (delete-match))) 2039 (process-rfc822 2040 start 2041 count 2042 (if (re-search-forward mmdf-message-end-regexp start end true) 2043 (mark-1+ (replace-match "\037")) 2044 (missing-end end "MMDF"))))) 2045 (else 2046 (editor-error "error converting to Babyl format") 2047 true))) 2048 2049 (define (process-rfc822 point count mend) 2050 (let ((mend (mark-left-inserting-copy mend))) 2051 (rfc822-region->babyl (make-region point mend)) 2052 (mark-temporary! mend) 2053 (loop mend (+ count 1)))) 2054 2055 (define (missing-end end type) 2056 (message "Invalid " type " format in inbox!") 2057 (sit-for 1) 2058 end) 2059 2060 (with-text-clipped start end 2061 (lambda () 2062 (loop (skip-chars-forward "\n" start end) 0)))) 2063 2064(define (rfc822-region->babyl region) 2065 (let ((start (mark-left-inserting-copy (region-start region)))) 2066 (insert-string babyl-initial-message-start start) 2067 (mark-temporary! start) 2068 (let ((end (mark-left-inserting-copy (region-end region)))) 2069 ;; Eliminate babyl message-separation pair from message body. 2070 (do ((m start (replace-match "\n^_"))) 2071 ((not (search-forward "\n\037" m end #f)))) 2072 (guarantee-newline end) 2073 (if (not (eqv? (integer->char #o37) (extract-right-char end))) 2074 (insert-string "\037" end)) 2075 (mark-temporary! end)))) 2076 2077(define (convert-buffer-to-babyl-format buffer) 2078 (with-buffer-open buffer 2079 (lambda () 2080 (let ((start (buffer-start buffer)) 2081 (end (buffer-end buffer))) 2082 (if (not (re-match-forward babyl-header-start-regexp start end false)) 2083 (insert-string babyl-initial-header start)) 2084 (search-backward "\n\037" end start false) 2085 (let ((start (re-match-end 0))) 2086 (let ((m (skip-chars-forward "\n" start end))) 2087 (cond ((and (mark= m end) 2088 (mark< start m)) 2089 (delete-string start m)) 2090 ((re-match-forward umail-message-start-regexp m end false) 2091 (delete-string start m) 2092 (message "Converting to Babyl format...") 2093 (convert-region-to-babyl-format start end) 2094 (message "Converting to Babyl format...done"))))))))) 2095 2096(define (nuke-pinhead-header start end) 2097 (let ((hend 2098 (or (search-forward "\n\n" start end false) 2099 (begin 2100 (insert-string "\n\n" end) 2101 end)))) 2102 (let ((has-from (search-forward "\nFrom:" start hend true)) 2103 (has-date (search-forward "\nDate:" start hend true))) 2104 (if (and has-from has-date) 2105 (delete-string start (line-start start 1)) 2106 (begin 2107 (re-match-forward umail-message-start-regexp start hend false) 2108 (replace-match 2109 (let ((from "From: \\1") 2110 (date 2111 (if (mark< (re-match-start 7) (re-match-end 7)) 2112 "Date: \\3, \\5 \\4 \\8 \\6\\7" 2113 "Date: \\3, \\5 \\4 \\8 \\6 EST"))) 2114 (cond (has-from date) 2115 (has-date from) 2116 (else (string-append date "\n" from)))))))))) 2117 2118;;;; Utilities 2119 2120(define (without-clipping buffer thunk) 2121 (let ((group (buffer-group buffer))) 2122 (with-group-text-clipped! group 0 (group-length group) thunk))) 2123 2124(define-integrable (with-buffer-open buffer thunk) 2125 (with-group-open (buffer-group buffer) thunk)) 2126 2127(define-integrable (with-buffer-undo-disabled buffer thunk) 2128 (with-group-undo-disabled (buffer-group buffer) thunk)) 2129 2130(define (with-group-open group thunk) 2131 (let ((outside-writeable) 2132 (inside-writeable 'FULLY) 2133 (outside-start) 2134 (outside-end) 2135 (inside-start (mark-permanent! (group-absolute-start group))) 2136 (inside-end (mark-permanent! (group-absolute-end group)))) 2137 (dynamic-wind (lambda () 2138 (set! outside-writeable (group-writeable? group)) 2139 (set! outside-start (group-start-mark group)) 2140 (set! outside-end (group-end-mark group)) 2141 (set-group-writeable?! group inside-writeable) 2142 (set-group-start-mark! group inside-start) 2143 (set-group-end-mark! group inside-end)) 2144 thunk 2145 (lambda () 2146 (set! inside-writeable (group-writeable? group)) 2147 (set! inside-start (group-start-mark group)) 2148 (set! inside-end (group-end-mark group)) 2149 (set-group-writeable?! group outside-writeable) 2150 (set-group-start-mark! group outside-start) 2151 (set-group-end-mark! group outside-end))))) 2152 2153;;;; Constants 2154 2155(define umail-message-start-regexp 2156 "From \\([^ \n]*\\(\\|\".*\"[^ \n]*\\)\\) ?\\([^ \n]*\\) \\([^ \n]*\\) *\\([0-9]*\\) \\([0-9:]*\\)\\( ?[A-Z]?[A-Z][A-Z]T\\| ?[-+]?[0-9][0-9][0-9][0-9]\\|\\) \\([1-9][0-9][0-9][0-9]\\) *\\(remote from .*\\)?$") 2157 2158(define umail-message-end-regexp 2159 false) 2160 2161(define mmdf-message-start-regexp 2162 "^\001\001\001\001\n") 2163 2164(define mmdf-message-end-regexp 2165 "^\001\001\001\001\n") 2166 2167(define babyl-header-start-regexp 2168 "^BABYL OPTIONS:") 2169 2170(define babyl-header-end-regexp 2171 "\n\037") 2172 2173(define babyl-initial-header 2174 "BABYL OPTIONS: 2175Version: 5 2176Labels: 2177Note: This is the header of an rmail file. 2178Note: If you are seeing it in rmail, 2179Note: it means the file has no messages in it.\n\037") 2180 2181(define babyl-message-start-regexp 2182 "\f\n[01],") 2183 2184(define babyl-message-end-regexp 2185 "\n\037") 2186 2187(define babyl-eooh-string 2188 "*** EOOH ***\n") 2189 2190(define babyl-eooh-regexp 2191 (string-append "^" (re-quote-string babyl-eooh-string))) 2192 2193(define babyl-initial-message-start 2194 (string-append "\f\n0, unseen,,\n" babyl-eooh-string)) 2195 2196(define-integrable digest-end-regexp 2197 "^End of.*Digest.*\n\\*\\*\\*\\*\\*\\*\\*\\*\\**\\(\n------*\\)*") 2198 2199(define-integrable digest-summary-separator-regexp 2200 "\n*\n------------------------------*\n*") 2201 2202(define-integrable digest-message-separator-regexp 2203 "\n*\n\n----------------------------*\n*") 2204 2205(define digest-separator-replacement 2206 (string-append "\n\037" babyl-initial-message-start))