1;;; mail-source.el --- functions for fetching mail 2 3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Keywords: news, mail 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;;; Code: 29 30(eval-when-compile 31 (require 'cl) 32 (require 'imap) 33 (eval-when-compile (defvar display-time-mail-function))) 34(eval-and-compile 35 (autoload 'pop3-movemail "pop3") 36 (autoload 'pop3-get-message-count "pop3") 37 (autoload 'nnheader-cancel-timer "nnheader") 38 (autoload 'nnheader-run-at-time "nnheader")) 39(require 'format-spec) 40(require 'mm-util) 41(require 'message) ;; for `message-directory' 42 43(defgroup mail-source nil 44 "The mail-fetching library." 45 :version "21.1" 46 :group 'gnus) 47 48;; Define these at compile time to avoid dragging in imap always. 49(defconst mail-source-imap-authenticators 50 (eval-when-compile 51 (mapcar (lambda (a) 52 (list 'const (car a))) 53 imap-authenticator-alist))) 54(defconst mail-source-imap-streams 55 (eval-when-compile 56 (mapcar (lambda (a) 57 (list 'const (car a))) 58 imap-stream-alist))) 59 60(defcustom mail-sources nil 61 "*Where the mail backends will look for incoming mail. 62This variable is a list of mail source specifiers. 63See Info node `(gnus)Mail Source Specifiers'." 64 :group 'mail-source 65 :link '(custom-manual "(gnus)Mail Source Specifiers") 66 :type `(choice 67 (const nil) 68 (repeat 69 (choice :format "%[Value Menu%] %v" 70 :value (file) 71 (cons :tag "Spool file" 72 (const :format "" file) 73 (checklist :tag "Options" :greedy t 74 (group :inline t 75 (const :format "" :value :path) 76 file))) 77 (cons :tag "Several files in a directory" 78 (const :format "" directory) 79 (checklist :tag "Options" :greedy t 80 (group :inline t 81 (const :format "" :value :path) 82 (directory :tag "Path")) 83 (group :inline t 84 (const :format "" :value :suffix) 85 (string :tag "Suffix")) 86 (group :inline t 87 (const :format "" :value :predicate) 88 (function :tag "Predicate")) 89 (group :inline t 90 (const :format "" :value :prescript) 91 (choice :tag "Prescript" 92 :value nil 93 (string :format "%v") 94 (function :format "%v"))) 95 (group :inline t 96 (const :format "" :value :postscript) 97 (choice :tag "Postscript" 98 :value nil 99 (string :format "%v") 100 (function :format "%v"))) 101 (group :inline t 102 (const :format "" :value :plugged) 103 (boolean :tag "Plugged")))) 104 (cons :tag "POP3 server" 105 (const :format "" pop) 106 (checklist :tag "Options" :greedy t 107 (group :inline t 108 (const :format "" :value :server) 109 (string :tag "Server")) 110 (group :inline t 111 (const :format "" :value :port) 112 (choice :tag "Port" 113 :value "pop3" 114 (number :format "%v") 115 (string :format "%v"))) 116 (group :inline t 117 (const :format "" :value :user) 118 (string :tag "User")) 119 (group :inline t 120 (const :format "" :value :password) 121 (string :tag "Password")) 122 (group :inline t 123 (const :format "" :value :program) 124 (string :tag "Program")) 125 (group :inline t 126 (const :format "" :value :prescript) 127 (choice :tag "Prescript" 128 :value nil 129 (string :format "%v") 130 (function :format "%v"))) 131 (group :inline t 132 (const :format "" :value :postscript) 133 (choice :tag "Postscript" 134 :value nil 135 (string :format "%v") 136 (function :format "%v"))) 137 (group :inline t 138 (const :format "" :value :function) 139 (function :tag "Function")) 140 (group :inline t 141 (const :format "" 142 :value :authentication) 143 (choice :tag "Authentication" 144 :value apop 145 (const password) 146 (const apop))) 147 (group :inline t 148 (const :format "" :value :plugged) 149 (boolean :tag "Plugged")))) 150 (cons :tag "Maildir (qmail, postfix...)" 151 (const :format "" maildir) 152 (checklist :tag "Options" :greedy t 153 (group :inline t 154 (const :format "" :value :path) 155 (directory :tag "Path")) 156 (group :inline t 157 (const :format "" :value :plugged) 158 (boolean :tag "Plugged")))) 159 (cons :tag "IMAP server" 160 (const :format "" imap) 161 (checklist :tag "Options" :greedy t 162 (group :inline t 163 (const :format "" :value :server) 164 (string :tag "Server")) 165 (group :inline t 166 (const :format "" :value :port) 167 (choice :tag "Port" 168 :value 143 169 number string)) 170 (group :inline t 171 (const :format "" :value :user) 172 (string :tag "User")) 173 (group :inline t 174 (const :format "" :value :password) 175 (string :tag "Password")) 176 (group :inline t 177 (const :format "" :value :stream) 178 (choice :tag "Stream" 179 :value network 180 ,@mail-source-imap-streams)) 181 (group :inline t 182 (const :format "" :value :program) 183 (string :tag "Program")) 184 (group :inline t 185 (const :format "" 186 :value :authenticator) 187 (choice :tag "Authenticator" 188 :value login 189 ,@mail-source-imap-authenticators)) 190 (group :inline t 191 (const :format "" :value :mailbox) 192 (string :tag "Mailbox" 193 :value "INBOX")) 194 (group :inline t 195 (const :format "" :value :predicate) 196 (string :tag "Predicate" 197 :value "UNSEEN UNDELETED")) 198 (group :inline t 199 (const :format "" :value :fetchflag) 200 (string :tag "Fetchflag" 201 :value "\\Deleted")) 202 (group :inline t 203 (const :format "" 204 :value :dontexpunge) 205 (boolean :tag "Dontexpunge")) 206 (group :inline t 207 (const :format "" :value :plugged) 208 (boolean :tag "Plugged")))) 209 (cons :tag "Webmail server" 210 (const :format "" webmail) 211 (checklist :tag "Options" :greedy t 212 (group :inline t 213 (const :format "" :value :subtype) 214 ;; Should be generated from 215 ;; `webmail-type-definition', but we 216 ;; can't require webmail without W3. 217 (choice :tag "Subtype" 218 :value hotmail 219 (const hotmail) 220 (const yahoo) 221 (const netaddress) 222 (const netscape) 223 (const my-deja))) 224 (group :inline t 225 (const :format "" :value :user) 226 (string :tag "User")) 227 (group :inline t 228 (const :format "" :value :password) 229 (string :tag "Password")) 230 (group :inline t 231 (const :format "" 232 :value :dontexpunge) 233 (boolean :tag "Dontexpunge")) 234 (group :inline t 235 (const :format "" :value :plugged) 236 (boolean :tag "Plugged")))))))) 237 238(defcustom mail-source-ignore-errors nil 239 "*Ignore errors when querying mail sources. 240If nil, the user will be prompted when an error occurs. If non-nil, 241the error will be ignored." 242 :version "22.1" 243 :group 'mail-source 244 :type 'boolean) 245 246(defcustom mail-source-primary-source nil 247 "*Primary source for incoming mail. 248If non-nil, this maildrop will be checked periodically for new mail." 249 :group 'mail-source 250 :type 'sexp) 251 252(defcustom mail-source-flash t 253 "*If non-nil, flash periodically when mail is available." 254 :group 'mail-source 255 :type 'boolean) 256 257(defcustom mail-source-crash-box "~/.emacs-mail-crash-box" 258 "File where mail will be stored while processing it." 259 :group 'mail-source 260 :type 'file) 261 262(defcustom mail-source-directory message-directory 263 "Directory where incoming mail source files (if any) will be stored." 264 :group 'mail-source 265 :type 'directory) 266 267(defcustom mail-source-default-file-modes 384 268 "Set the mode bits of all new mail files to this integer." 269 :group 'mail-source 270 :type 'integer) 271 272(defcustom mail-source-delete-incoming t 273 "*If non-nil, delete incoming files after handling. 274If t, delete immediately, if nil, never delete. If a positive number, delete 275files older than number of days." 276 ;; Note: The removing happens in `mail-source-callback', i.e. no old 277 ;; incoming files will be deleted, unless you receive new mail. 278 ;; 279 ;; You may also set this to `nil' and call `mail-source-delete-old-incoming' 280 ;; from a hook or interactively. 281 :group 'mail-source 282 :type '(choice (const :tag "immediately" t) 283 (const :tag "never" nil) 284 (integer :tag "days"))) 285 286(defcustom mail-source-delete-old-incoming-confirm t 287 "*If non-nil, ask for for confirmation before deleting old incoming files. 288This variable only applies when `mail-source-delete-incoming' is a positive 289number." 290 :version "22.1" 291 :group 'mail-source 292 :type 'boolean) 293 294(defcustom mail-source-incoming-file-prefix "Incoming" 295 "Prefix for file name for storing incoming mail" 296 :group 'mail-source 297 :type 'string) 298 299(defcustom mail-source-report-new-mail-interval 5 300 "Interval in minutes between checks for new mail." 301 :group 'mail-source 302 :type 'number) 303 304(defcustom mail-source-idle-time-delay 5 305 "Number of idle seconds to wait before checking for new mail." 306 :group 'mail-source 307 :type 'number) 308 309(defcustom mail-source-movemail-program nil 310 "If non-nil, name of program for fetching new mail." 311 :version "22.1" 312 :group 'mail-source 313 :type '(choice (const nil) string)) 314 315;;; Internal variables. 316 317(defvar mail-source-string "" 318 "A dynamically bound string that says what the current mail source is.") 319 320(defvar mail-source-new-mail-available nil 321 "Flag indicating when new mail is available.") 322 323(eval-and-compile 324 (defvar mail-source-common-keyword-map 325 '((:plugged)) 326 "Mapping from keywords to default values. 327Common keywords should be listed here.") 328 329 (defvar mail-source-keyword-map 330 '((file 331 (:prescript) 332 (:prescript-delay) 333 (:postscript) 334 (:path (or (getenv "MAIL") 335 (expand-file-name (user-login-name) rmail-spool-directory)))) 336 (directory 337 (:prescript) 338 (:prescript-delay) 339 (:postscript) 340 (:path) 341 (:suffix ".spool") 342 (:predicate identity)) 343 (pop 344 (:prescript) 345 (:prescript-delay) 346 (:postscript) 347 (:server (getenv "MAILHOST")) 348 (:port 110) 349 (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) 350 (:program) 351 (:function) 352 (:password) 353 (:authentication password)) 354 (maildir 355 (:path (or (getenv "MAILDIR") "~/Maildir/")) 356 (:subdirs ("cur" "new")) 357 (:function)) 358 (imap 359 (:server (getenv "MAILHOST")) 360 (:port) 361 (:stream) 362 (:program) 363 (:authentication) 364 (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) 365 (:password) 366 (:mailbox "INBOX") 367 (:predicate "UNSEEN UNDELETED") 368 (:fetchflag "\\Deleted") 369 (:prescript) 370 (:prescript-delay) 371 (:postscript) 372 (:dontexpunge)) 373 (webmail 374 (:subtype hotmail) 375 (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) 376 (:password) 377 (:dontexpunge) 378 (:authentication password))) 379 "Mapping from keywords to default values. 380All keywords that can be used must be listed here.")) 381 382(defvar mail-source-fetcher-alist 383 '((file mail-source-fetch-file) 384 (directory mail-source-fetch-directory) 385 (pop mail-source-fetch-pop) 386 (maildir mail-source-fetch-maildir) 387 (imap mail-source-fetch-imap) 388 (webmail mail-source-fetch-webmail)) 389 "A mapping from source type to fetcher function.") 390 391(defvar mail-source-password-cache nil) 392 393(defvar mail-source-plugged t) 394 395;;; Functions 396 397(eval-and-compile 398 (defun mail-source-strip-keyword (keyword) 399 "Strip the leading colon off the KEYWORD." 400 (intern (substring (symbol-name keyword) 1)))) 401 402(eval-and-compile 403 (defun mail-source-bind-1 (type) 404 (let* ((defaults (cdr (assq type mail-source-keyword-map))) 405 default bind) 406 (while (setq default (pop defaults)) 407 (push (list (mail-source-strip-keyword (car default)) 408 nil) 409 bind)) 410 bind))) 411 412(defmacro mail-source-bind (type-source &rest body) 413 "Return a `let' form that binds all variables in source TYPE. 414TYPE-SOURCE is a list where the first element is the TYPE, and 415the second variable is the SOURCE. 416At run time, the mail source specifier SOURCE will be inspected, 417and the variables will be set according to it. Variables not 418specified will be given default values. 419 420After this is done, BODY will be executed in the scope 421of the `let' form. 422 423The variables bound and their default values are described by 424the `mail-source-keyword-map' variable." 425 `(let ,(mail-source-bind-1 (car type-source)) 426 (mail-source-set-1 ,(cadr type-source)) 427 ,@body)) 428 429(put 'mail-source-bind 'lisp-indent-function 1) 430(put 'mail-source-bind 'edebug-form-spec '(sexp body)) 431 432(defun mail-source-set-1 (source) 433 (let* ((type (pop source)) 434 (defaults (cdr (assq type mail-source-keyword-map))) 435 default value keyword) 436 (while (setq default (pop defaults)) 437 (set (mail-source-strip-keyword (setq keyword (car default))) 438 (if (setq value (plist-get source keyword)) 439 (mail-source-value value) 440 (mail-source-value (cadr default))))))) 441 442(eval-and-compile 443 (defun mail-source-bind-common-1 () 444 (let* ((defaults mail-source-common-keyword-map) 445 default bind) 446 (while (setq default (pop defaults)) 447 (push (list (mail-source-strip-keyword (car default)) 448 nil) 449 bind)) 450 bind))) 451 452(defun mail-source-set-common-1 (source) 453 (let* ((type (pop source)) 454 (defaults mail-source-common-keyword-map) 455 (defaults-1 (cdr (assq type mail-source-keyword-map))) 456 default value keyword) 457 (while (setq default (pop defaults)) 458 (set (mail-source-strip-keyword (setq keyword (car default))) 459 (if (setq value (plist-get source keyword)) 460 (mail-source-value value) 461 (if (setq value (assq keyword defaults-1)) 462 (mail-source-value (cadr value)) 463 (mail-source-value (cadr default)))))))) 464 465(defmacro mail-source-bind-common (source &rest body) 466 "Return a `let' form that binds all common variables. 467See `mail-source-bind'." 468 `(let ,(mail-source-bind-common-1) 469 (mail-source-set-common-1 source) 470 ,@body)) 471 472(put 'mail-source-bind-common 'lisp-indent-function 1) 473(put 'mail-source-bind-common 'edebug-form-spec '(sexp body)) 474 475(defun mail-source-value (value) 476 "Return the value of VALUE." 477 (cond 478 ;; String 479 ((stringp value) 480 value) 481 ;; Function 482 ((and (listp value) 483 (functionp (car value))) 484 (eval value)) 485 ;; Just return the value. 486 (t 487 value))) 488 489(defun mail-source-fetch (source callback) 490 "Fetch mail from SOURCE and call CALLBACK zero or more times. 491CALLBACK will be called with the name of the file where (some of) 492the mail from SOURCE is put. 493Return the number of files that were found." 494 (mail-source-bind-common source 495 (if (or mail-source-plugged plugged) 496 (save-excursion 497 (let ((function (cadr (assq (car source) mail-source-fetcher-alist))) 498 (found 0)) 499 (unless function 500 (error "%S is an invalid mail source specification" source)) 501 ;; If there's anything in the crash box, we do it first. 502 (when (file-exists-p mail-source-crash-box) 503 (message "Processing mail from %s..." mail-source-crash-box) 504 (setq found (mail-source-callback 505 callback mail-source-crash-box))) 506 (+ found 507 (if (or debug-on-quit debug-on-error) 508 (funcall function source callback) 509 (condition-case err 510 (funcall function source callback) 511 (error 512 (if (and (not mail-source-ignore-errors) 513 (not 514 (yes-or-no-p 515 (format "Mail source %s error (%s). Continue? " 516 (if (memq ':password source) 517 (let ((s (copy-sequence source))) 518 (setcar (cdr (memq ':password s)) 519 "********") 520 s) 521 source) 522 (cadr err))))) 523 (error "Cannot get new mail")) 524 0))))))))) 525 526(defun mail-source-delete-old-incoming (&optional age confirm) 527 "Remove incoming files older than AGE days. 528If CONFIRM is non-nil, ask for confirmation before removing a file." 529 (interactive "P") 530 (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days 531 (low2days (/ 1.0 65536.0)) ;; convert low bits to days 532 (diff (if (natnump age) age 30));; fallback, if no valid AGE given 533 currday files) 534 (setq files (directory-files 535 mail-source-directory t 536 (concat mail-source-incoming-file-prefix "*")) 537 currday (* (car (current-time)) high2days) 538 currday (+ currday (* low2days (nth 1 (current-time))))) 539 (while files 540 (let* ((ffile (car files)) 541 (bfile (gnus-replace-in-string 542 ffile "\\`.*/\\([^/]+\\)\\'" "\\1")) 543 (filetime (nth 5 (file-attributes ffile))) 544 (fileday (* (car filetime) high2days)) 545 (fileday (+ fileday (* low2days (nth 1 filetime))))) 546 (setq files (cdr files)) 547 (when (and (> (- currday fileday) diff) 548 (gnus-message 8 "File `%s' is older than %s day(s)" 549 bfile diff) 550 (or (not confirm) 551 (y-or-n-p (concat "Remove file `" bfile "'? ")))) 552 (delete-file ffile)))))) 553 554(defun mail-source-callback (callback info) 555 "Call CALLBACK on the mail file, and then remove the mail file. 556Pass INFO on to CALLBACK." 557 (if (or (not (file-exists-p mail-source-crash-box)) 558 (zerop (nth 7 (file-attributes mail-source-crash-box)))) 559 (progn 560 (when (file-exists-p mail-source-crash-box) 561 (delete-file mail-source-crash-box)) 562 0) 563 (prog1 564 (funcall callback mail-source-crash-box info) 565 (when (file-exists-p mail-source-crash-box) 566 ;; Delete or move the incoming mail out of the way. 567 (if (eq mail-source-delete-incoming t) 568 (delete-file mail-source-crash-box) 569 (let ((incoming 570 (mm-make-temp-file 571 (expand-file-name 572 mail-source-incoming-file-prefix 573 mail-source-directory)))) 574 (unless (file-exists-p (file-name-directory incoming)) 575 (make-directory (file-name-directory incoming) t)) 576 (rename-file mail-source-crash-box incoming t) 577 ;; remove old incoming files? 578 (when (natnump mail-source-delete-incoming) 579 (mail-source-delete-old-incoming 580 mail-source-delete-incoming 581 mail-source-delete-old-incoming-confirm)))))))) 582 583(defun mail-source-movemail (from to) 584 "Move FROM to TO using movemail." 585 (if (not (file-writable-p to)) 586 (error "Can't write to crash box %s. Not moving mail" to) 587 (let ((to (file-truename (expand-file-name to))) 588 errors result) 589 (setq to (file-truename to) 590 from (file-truename from)) 591 ;; Set TO if have not already done so, and rename or copy 592 ;; the file FROM to TO if and as appropriate. 593 (cond 594 ((file-exists-p to) 595 ;; The crash box exists already. 596 t) 597 ((not (file-exists-p from)) 598 ;; There is no inbox. 599 (setq to nil)) 600 ((zerop (nth 7 (file-attributes from))) 601 ;; Empty file. 602 (setq to nil)) 603 (t 604 ;; If getting from mail spool directory, use movemail to move 605 ;; rather than just renaming, so as to interlock with the 606 ;; mailer. 607 (unwind-protect 608 (save-excursion 609 (setq errors (generate-new-buffer " *mail source loss*")) 610 (let ((default-directory "/")) 611 (setq result 612 (apply 613 'call-process 614 (append 615 (list 616 (or mail-source-movemail-program 617 (expand-file-name "movemail" exec-directory)) 618 nil errors nil from to))))) 619 (when (file-exists-p to) 620 (set-file-modes to mail-source-default-file-modes)) 621 (if (and (or (not (buffer-modified-p errors)) 622 (zerop (buffer-size errors))) 623 (and (numberp result) 624 (zerop result))) 625 ;; No output => movemail won. 626 t 627 (set-buffer errors) 628 ;; There may be a warning about older revisions. We 629 ;; ignore that. 630 (goto-char (point-min)) 631 (if (search-forward "older revision" nil t) 632 t 633 ;; Probably a real error. 634 (subst-char-in-region (point-min) (point-max) ?\n ?\ ) 635 (goto-char (point-max)) 636 (skip-chars-backward " \t") 637 (delete-region (point) (point-max)) 638 (goto-char (point-min)) 639 (when (looking-at "movemail: ") 640 (delete-region (point-min) (match-end 0))) 641 ;; Result may be a signal description string. 642 (unless (yes-or-no-p 643 (format "movemail: %s (%s return). Continue? " 644 (buffer-string) result)) 645 (error "%s" (buffer-string))) 646 (setq to nil))))))) 647 (when (and errors 648 (buffer-name errors)) 649 (kill-buffer errors)) 650 ;; Return whether we moved successfully or not. 651 to))) 652 653(defun mail-source-movemail-and-remove (from to) 654 "Move FROM to TO using movemail, then remove FROM if empty." 655 (or (not (mail-source-movemail from to)) 656 (not (zerop (nth 7 (file-attributes from)))) 657 (delete-file from))) 658 659(defun mail-source-fetch-with-program (program) 660 (eq 0 (call-process shell-file-name nil nil nil 661 shell-command-switch program))) 662 663(defun mail-source-run-script (script spec &optional delay) 664 (when script 665 (if (functionp script) 666 (funcall script) 667 (mail-source-call-script 668 (format-spec script spec)))) 669 (when delay 670 (sleep-for delay))) 671 672(defun mail-source-call-script (script) 673 (let ((background nil)) 674 (when (string-match "& *$" script) 675 (setq script (substring script 0 (match-beginning 0)) 676 background 0)) 677 (call-process shell-file-name nil background nil 678 shell-command-switch script))) 679 680;;; 681;;; Different fetchers 682;;; 683 684(defun mail-source-fetch-file (source callback) 685 "Fetcher for single-file sources." 686 (mail-source-bind (file source) 687 (mail-source-run-script 688 prescript (format-spec-make ?t mail-source-crash-box) 689 prescript-delay) 690 (let ((mail-source-string (format "file:%s" path))) 691 (if (mail-source-movemail path mail-source-crash-box) 692 (prog1 693 (mail-source-callback callback path) 694 (mail-source-run-script 695 postscript (format-spec-make ?t mail-source-crash-box))) 696 0)))) 697 698(defun mail-source-fetch-directory (source callback) 699 "Fetcher for directory sources." 700 (mail-source-bind (directory source) 701 (mail-source-run-script 702 prescript (format-spec-make ?t path) prescript-delay) 703 (let ((found 0) 704 (mail-source-string (format "directory:%s" path))) 705 (dolist (file (directory-files 706 path t (concat (regexp-quote suffix) "$"))) 707 (when (and (file-regular-p file) 708 (funcall predicate file) 709 (mail-source-movemail file mail-source-crash-box)) 710 (incf found (mail-source-callback callback file)))) 711 (mail-source-run-script postscript (format-spec-make ?t path)) 712 found))) 713 714(defun mail-source-fetch-pop (source callback) 715 "Fetcher for single-file sources." 716 (mail-source-bind (pop source) 717 (mail-source-run-script 718 prescript 719 (format-spec-make ?p password ?t mail-source-crash-box 720 ?s server ?P port ?u user) 721 prescript-delay) 722 (let ((from (format "%s:%s:%s" server user port)) 723 (mail-source-string (format "pop:%s@%s" user server)) 724 result) 725 (when (eq authentication 'password) 726 (setq password 727 (or password 728 (cdr (assoc from mail-source-password-cache)) 729 (read-passwd 730 (format "Password for %s at %s: " user server))))) 731 (when server 732 (setenv "MAILHOST" server)) 733 (setq result 734 (cond 735 (program 736 (mail-source-fetch-with-program 737 (format-spec 738 program 739 (format-spec-make ?p password ?t mail-source-crash-box 740 ?s server ?P port ?u user)))) 741 (function 742 (funcall function mail-source-crash-box)) 743 ;; The default is to use pop3.el. 744 (t 745 (require 'pop3) 746 (let ((pop3-password password) 747 (pop3-maildrop user) 748 (pop3-mailhost server) 749 (pop3-port port) 750 (pop3-authentication-scheme 751 (if (eq authentication 'apop) 'apop 'pass))) 752 (if (or debug-on-quit debug-on-error) 753 (save-excursion (pop3-movemail mail-source-crash-box)) 754 (condition-case err 755 (save-excursion (pop3-movemail mail-source-crash-box)) 756 (error 757 ;; We nix out the password in case the error 758 ;; was because of a wrong password being given. 759 (setq mail-source-password-cache 760 (delq (assoc from mail-source-password-cache) 761 mail-source-password-cache)) 762 (signal (car err) (cdr err))))))))) 763 (if result 764 (progn 765 (when (eq authentication 'password) 766 (unless (assoc from mail-source-password-cache) 767 (push (cons from password) mail-source-password-cache))) 768 (prog1 769 (mail-source-callback callback server) 770 ;; Update display-time's mail flag, if relevant. 771 (if (equal source mail-source-primary-source) 772 (setq mail-source-new-mail-available nil)) 773 (mail-source-run-script 774 postscript 775 (format-spec-make ?p password ?t mail-source-crash-box 776 ?s server ?P port ?u user)))) 777 ;; We nix out the password in case the error 778 ;; was because of a wrong password being given. 779 (setq mail-source-password-cache 780 (delq (assoc from mail-source-password-cache) 781 mail-source-password-cache)) 782 0)))) 783 784(defun mail-source-check-pop (source) 785 "Check whether there is new mail." 786 (mail-source-bind (pop source) 787 (let ((from (format "%s:%s:%s" server user port)) 788 (mail-source-string (format "pop:%s@%s" user server)) 789 result) 790 (when (eq authentication 'password) 791 (setq password 792 (or password 793 (cdr (assoc from mail-source-password-cache)) 794 (read-passwd 795 (format "Password for %s at %s: " user server)))) 796 (unless (assoc from mail-source-password-cache) 797 (push (cons from password) mail-source-password-cache))) 798 (when server 799 (setenv "MAILHOST" server)) 800 (setq result 801 (cond 802 ;; No easy way to check whether mail is waiting for these. 803 (program) 804 (function) 805 ;; The default is to use pop3.el. 806 (t 807 (require 'pop3) 808 (let ((pop3-password password) 809 (pop3-maildrop user) 810 (pop3-mailhost server) 811 (pop3-port port) 812 (pop3-authentication-scheme 813 (if (eq authentication 'apop) 'apop 'pass))) 814 (if (or debug-on-quit debug-on-error) 815 (save-excursion (pop3-get-message-count)) 816 (condition-case err 817 (save-excursion (pop3-get-message-count)) 818 (error 819 ;; We nix out the password in case the error 820 ;; was because of a wrong password being given. 821 (setq mail-source-password-cache 822 (delq (assoc from mail-source-password-cache) 823 mail-source-password-cache)) 824 (signal (car err) (cdr err))))))))) 825 (if result 826 ;; Inform display-time that we have new mail. 827 (setq mail-source-new-mail-available (> result 0)) 828 ;; We nix out the password in case the error 829 ;; was because of a wrong password being given. 830 (setq mail-source-password-cache 831 (delq (assoc from mail-source-password-cache) 832 mail-source-password-cache))) 833 result))) 834 835(defun mail-source-touch-pop () 836 "Open and close a POP connection shortly. 837POP server should be defined in `mail-source-primary-source' (which is 838preferred) or `mail-sources'. You may use it for the POP-before-SMTP 839authentication. To do that, you need to set the 840`message-send-mail-function' variable as `message-smtpmail-send-it' 841and put the following line in your ~/.gnus.el file: 842 843\(add-hook 'message-send-mail-hook 'mail-source-touch-pop) 844 845See the Gnus manual for details." 846 (let ((sources (if mail-source-primary-source 847 (list mail-source-primary-source) 848 mail-sources))) 849 (while sources 850 (if (eq 'pop (car (car sources))) 851 (mail-source-check-pop (car sources))) 852 (setq sources (cdr sources))))) 853 854(defun mail-source-new-mail-p () 855 "Handler for `display-time' to indicate when new mail is available." 856 ;; Flash (ie. ring the visible bell) if mail is available. 857 (if (and mail-source-flash mail-source-new-mail-available) 858 (let ((visible-bell t)) 859 (ding))) 860 ;; Only report flag setting; flag is updated on a different schedule. 861 mail-source-new-mail-available) 862 863 864(defvar mail-source-report-new-mail nil) 865(defvar mail-source-report-new-mail-timer nil) 866(defvar mail-source-report-new-mail-idle-timer nil) 867 868(eval-when-compile 869 (if (featurep 'xemacs) 870 (require 'timer-funcs) 871 (require 'timer))) 872 873(defun mail-source-start-idle-timer () 874 ;; Start our idle timer if necessary, so we delay the check until the 875 ;; user isn't typing. 876 (unless mail-source-report-new-mail-idle-timer 877 (setq mail-source-report-new-mail-idle-timer 878 (run-with-idle-timer 879 mail-source-idle-time-delay 880 nil 881 (lambda () 882 (unwind-protect 883 (mail-source-check-pop mail-source-primary-source) 884 (setq mail-source-report-new-mail-idle-timer nil))))) 885 ;; Since idle timers created when Emacs is already in the idle 886 ;; state don't get activated until Emacs _next_ becomes idle, we 887 ;; need to force our timer to be considered active now. We do 888 ;; this by being naughty and poking the timer internals directly 889 ;; (element 0 of the vector is nil if the timer is active). 890 (aset mail-source-report-new-mail-idle-timer 0 nil))) 891 892(defun mail-source-report-new-mail (arg) 893 "Toggle whether to report when new mail is available. 894This only works when `display-time' is enabled." 895 (interactive "P") 896 (if (not mail-source-primary-source) 897 (error "Need to set `mail-source-primary-source' to check for new mail")) 898 (let ((on (if (null arg) 899 (not mail-source-report-new-mail) 900 (> (prefix-numeric-value arg) 0)))) 901 (setq mail-source-report-new-mail on) 902 (and mail-source-report-new-mail-timer 903 (nnheader-cancel-timer mail-source-report-new-mail-timer)) 904 (and mail-source-report-new-mail-idle-timer 905 (nnheader-cancel-timer mail-source-report-new-mail-idle-timer)) 906 (setq mail-source-report-new-mail-timer nil) 907 (setq mail-source-report-new-mail-idle-timer nil) 908 (if on 909 (progn 910 (require 'time) 911 ;; display-time-mail-function is an Emacs 21 feature. 912 (setq display-time-mail-function #'mail-source-new-mail-p) 913 ;; Set up the main timer. 914 (setq mail-source-report-new-mail-timer 915 (nnheader-run-at-time 916 (* 60 mail-source-report-new-mail-interval) 917 (* 60 mail-source-report-new-mail-interval) 918 #'mail-source-start-idle-timer)) 919 ;; When you get new mail, clear "Mail" from the mode line. 920 (add-hook 'nnmail-post-get-new-mail-hook 921 'display-time-event-handler) 922 (message "Mail check enabled")) 923 (setq display-time-mail-function nil) 924 (remove-hook 'nnmail-post-get-new-mail-hook 925 'display-time-event-handler) 926 (message "Mail check disabled")))) 927 928(defun mail-source-fetch-maildir (source callback) 929 "Fetcher for maildir sources." 930 (mail-source-bind (maildir source) 931 (let ((found 0) 932 mail-source-string) 933 (unless (string-match "/$" path) 934 (setq path (concat path "/"))) 935 (dolist (subdir subdirs) 936 (when (file-directory-p (concat path subdir)) 937 (setq mail-source-string (format "maildir:%s%s" path subdir)) 938 (dolist (file (directory-files (concat path subdir) t)) 939 (when (and (not (file-directory-p file)) 940 (not (if function 941 (funcall function file mail-source-crash-box) 942 (let ((coding-system-for-write 943 mm-text-coding-system) 944 (coding-system-for-read 945 mm-text-coding-system)) 946 (with-temp-file mail-source-crash-box 947 (insert-file-contents file) 948 (goto-char (point-min)) 949;;; ;; Unix mail format 950;;; (unless (looking-at "\n*From ") 951;;; (insert "From maildir " 952;;; (current-time-string) "\n")) 953;;; (while (re-search-forward "^From " nil t) 954;;; (replace-match ">From ")) 955;;; (goto-char (point-max)) 956;;; (insert "\n\n") 957 ;; MMDF mail format 958 (insert "\001\001\001\001\n")) 959 (delete-file file))))) 960 (incf found (mail-source-callback callback file)))))) 961 found))) 962 963(eval-and-compile 964 (autoload 'imap-open "imap") 965 (autoload 'imap-authenticate "imap") 966 (autoload 'imap-mailbox-select "imap") 967 (autoload 'imap-mailbox-unselect "imap") 968 (autoload 'imap-mailbox-close "imap") 969 (autoload 'imap-search "imap") 970 (autoload 'imap-fetch "imap") 971 (autoload 'imap-close "imap") 972 (autoload 'imap-error-text "imap") 973 (autoload 'imap-message-flags-add "imap") 974 (autoload 'imap-list-to-message-set "imap") 975 (autoload 'imap-range-to-message-set "imap") 976 (autoload 'nnheader-ms-strip-cr "nnheader")) 977 978(defvar mail-source-imap-file-coding-system 'binary 979 "Coding system for the crashbox made by `mail-source-fetch-imap'.") 980 981(defun mail-source-fetch-imap (source callback) 982 "Fetcher for imap sources." 983 (mail-source-bind (imap source) 984 (mail-source-run-script 985 prescript (format-spec-make ?p password ?t mail-source-crash-box 986 ?s server ?P port ?u user) 987 prescript-delay) 988 (let ((from (format "%s:%s:%s" server user port)) 989 (found 0) 990 (buf (generate-new-buffer " *imap source*")) 991 (mail-source-string (format "imap:%s:%s" server mailbox)) 992 (imap-shell-program (or (list program) imap-shell-program)) 993 remove) 994 (if (and (imap-open server port stream authentication buf) 995 (imap-authenticate 996 user (or (cdr (assoc from mail-source-password-cache)) 997 password) buf) 998 (imap-mailbox-select mailbox nil buf)) 999 (let ((coding-system-for-write mail-source-imap-file-coding-system) 1000 str) 1001 (with-temp-file mail-source-crash-box 1002 ;; Avoid converting 8-bit chars from inserted strings to 1003 ;; multibyte. 1004 (mm-disable-multibyte) 1005 ;; remember password 1006 (with-current-buffer buf 1007 (when (and imap-password 1008 (not (assoc from mail-source-password-cache))) 1009 (push (cons from imap-password) mail-source-password-cache))) 1010 ;; if predicate is nil, use all uids 1011 (dolist (uid (imap-search (or predicate "1:*") buf)) 1012 (when (setq str 1013 (if (imap-capability 'IMAP4rev1 buf) 1014 (caddar (imap-fetch uid "BODY.PEEK[]" 1015 'BODYDETAIL nil buf)) 1016 (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))) 1017 (push uid remove) 1018 (insert "From imap " (current-time-string) "\n") 1019 (save-excursion 1020 (insert str "\n\n")) 1021 (while (re-search-forward "^From " nil t) 1022 (replace-match ">From ")) 1023 (goto-char (point-max)))) 1024 (nnheader-ms-strip-cr)) 1025 (incf found (mail-source-callback callback server)) 1026 (when (and remove fetchflag) 1027 (setq remove (nreverse remove)) 1028 (imap-message-flags-add 1029 (imap-range-to-message-set (gnus-compress-sequence remove)) 1030 fetchflag nil buf)) 1031 (if dontexpunge 1032 (imap-mailbox-unselect buf) 1033 (imap-mailbox-close nil buf)) 1034 (imap-close buf)) 1035 (imap-close buf) 1036 ;; We nix out the password in case the error 1037 ;; was because of a wrong password being given. 1038 (setq mail-source-password-cache 1039 (delq (assoc from mail-source-password-cache) 1040 mail-source-password-cache)) 1041 (error "IMAP error: %s" (imap-error-text buf))) 1042 (kill-buffer buf) 1043 (mail-source-run-script 1044 postscript 1045 (format-spec-make ?p password ?t mail-source-crash-box 1046 ?s server ?P port ?u user)) 1047 found))) 1048 1049(eval-and-compile 1050 (autoload 'webmail-fetch "webmail")) 1051 1052(defun mail-source-fetch-webmail (source callback) 1053 "Fetch for webmail source." 1054 (mail-source-bind (webmail source) 1055 (let ((mail-source-string (format "webmail:%s:%s" subtype user)) 1056 (webmail-newmail-only dontexpunge) 1057 (webmail-move-to-trash-can (not dontexpunge))) 1058 (when (eq authentication 'password) 1059 (setq password 1060 (or password 1061 (cdr (assoc (format "webmail:%s:%s" subtype user) 1062 mail-source-password-cache)) 1063 (read-passwd 1064 (format "Password for %s at %s: " user subtype)))) 1065 (when (and password 1066 (not (assoc (format "webmail:%s:%s" subtype user) 1067 mail-source-password-cache))) 1068 (push (cons (format "webmail:%s:%s" subtype user) password) 1069 mail-source-password-cache))) 1070 (webmail-fetch mail-source-crash-box subtype user password) 1071 (mail-source-callback callback (symbol-name subtype))))) 1072 1073(provide 'mail-source) 1074 1075;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd 1076;;; mail-source.el ends here 1077