/[emacs]/emacs/lisp/gnus/mail-source.el
ViewVC logotype

Diff of /emacs/lisp/gnus/mail-source.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12.2.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.12.2.3 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; mail-source.el --- functions for fetching mail  ;;; mail-source.el --- functions for fetching mail
2  ;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc.  ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004
3    ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6  ;; Keywords: news, mail  ;; Keywords: news, mail
# Line 32  Line 33 
33  (eval-and-compile  (eval-and-compile
34    (autoload 'pop3-movemail "pop3")    (autoload 'pop3-movemail "pop3")
35    (autoload 'pop3-get-message-count "pop3")    (autoload 'pop3-get-message-count "pop3")
36    (autoload 'nnheader-cancel-timer "nnheader"))    (autoload 'nnheader-cancel-timer "nnheader")
37      (autoload 'nnheader-run-at-time "nnheader"))
38  (require 'format-spec)  (require 'format-spec)
39  (require 'mm-util)  (require 'mm-util)
40    (require 'message) ;; for `message-directory'
41    
42  (defgroup mail-source nil  (defgroup mail-source nil
43    "The mail-fetching library."    "The mail-fetching library."
# Line 58  Line 61 
61  This variable is a list of mail source specifiers.  This variable is a list of mail source specifiers.
62  See Info node `(gnus)Mail Source Specifiers'."  See Info node `(gnus)Mail Source Specifiers'."
63    :group 'mail-source    :group 'mail-source
64      :link '(custom-manual "(gnus)Mail Source Specifiers")
65    :type `(repeat    :type `(repeat
66            (choice :format "%[Value Menu%] %v"            (choice :format "%[Value Menu%] %v"
67                    :value (file)                    :value (file)
# Line 81  See Info node `(gnus)Mail Source Specifi Line 85  See Info node `(gnus)Mail Source Specifi
85                                            (function :tag "Predicate"))                                            (function :tag "Predicate"))
86                                     (group :inline t                                     (group :inline t
87                                            (const :format "" :value :prescript)                                            (const :format "" :value :prescript)
88                                            (string :tag "Prescript"))                                            (choice :tag "Prescript"
89                                                      :value nil
90                                                      (string :format "%v")
91                                                      (function :format "%v")))
92                                     (group :inline t                                     (group :inline t
93                                            (const :format "" :value :postscript)                                            (const :format "" :value :postscript)
94                                            (string :tag "Postscript"))                                            (choice :tag "Postscript"
95                                                      :value nil
96                                                      (string :format "%v")
97                                                      (function :format "%v")))
98                                     (group :inline t                                     (group :inline t
99                                            (const :format "" :value :plugged)                                            (const :format "" :value :plugged)
100                                            (boolean :tag "Plugged"))))                                            (boolean :tag "Plugged"))))
# Line 111  See Info node `(gnus)Mail Source Specifi Line 121  See Info node `(gnus)Mail Source Specifi
121                                            (string :tag "Program"))                                            (string :tag "Program"))
122                                     (group :inline t                                     (group :inline t
123                                            (const :format "" :value :prescript)                                            (const :format "" :value :prescript)
124                                            (string :tag "Prescript"))                                            (choice :tag "Prescript"
125                                                      :value nil
126                                                      (string :format "%v")
127                                                      (function :format "%v")))
128                                     (group :inline t                                     (group :inline t
129                                            (const :format "" :value :postscript)                                            (const :format "" :value :postscript)
130                                            (string :tag "Postscript"))                                            (choice :tag "Postscript"
131                                                      :value nil
132                                                      (string :format "%v")
133                                                      (function :format "%v")))
134                                     (group :inline t                                     (group :inline t
135                                            (const :format "" :value :function)                                            (const :format "" :value :function)
136                                            (function :tag "Function"))                                            (function :tag "Function"))
# Line 160  See Info node `(gnus)Mail Source Specifi Line 176  See Info node `(gnus)Mail Source Specifi
176                                                    :value network                                                    :value network
177                                                    ,@mail-source-imap-streams))                                                    ,@mail-source-imap-streams))
178                                     (group :inline t                                     (group :inline t
179                                              (const :format "" :value :program)
180                                              (string :tag "Program"))
181                                       (group :inline t
182                                            (const :format ""                                            (const :format ""
183                                                   :value :authenticator)                                                   :value :authenticator)
184                                            (choice :tag "Authenticator"                                            (choice :tag "Authenticator"
# Line 213  See Info node `(gnus)Mail Source Specifi Line 232  See Info node `(gnus)Mail Source Specifi
232                                            (const :format "" :value :plugged)                                            (const :format "" :value :plugged)
233                                            (boolean :tag "Plugged")))))))                                            (boolean :tag "Plugged")))))))
234    
235    (defcustom mail-source-ignore-errors nil
236      "*Ignore errors when querying mail sources.
237    If nil, the user will be prompted when an error occurs.  If non-nil,
238    the error will be ignored.")
239    
240  (defcustom mail-source-primary-source nil  (defcustom mail-source-primary-source nil
241    "*Primary source for incoming mail.    "*Primary source for incoming mail.
242  If non-nil, this maildrop will be checked periodically for new mail."  If non-nil, this maildrop will be checked periodically for new mail."
243    :group 'mail-source    :group 'mail-source
244    :type 'sexp)    :type 'sexp)
245    
246    (defcustom mail-source-flash t
247      "*If non-nil, flash periodically when mail is available."
248      :group 'mail-source
249      :type 'boolean)
250    
251  (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"  (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
252    "File where mail will be stored while processing it."    "File where mail will be stored while processing it."
253    :group 'mail-source    :group 'mail-source
254    :type 'file)    :type 'file)
255    
256  (defcustom mail-source-directory "~/Mail/"  (defcustom mail-source-directory message-directory
257    "Directory where files (if any) will be stored."    "Directory where files (if any) will be stored."
258    :group 'mail-source    :group 'mail-source
259    :type 'directory)    :type 'directory)
# Line 235  If non-nil, this maildrop will be checke Line 264  If non-nil, this maildrop will be checke
264    :type 'integer)    :type 'integer)
265    
266  (defcustom mail-source-delete-incoming t  (defcustom mail-source-delete-incoming t
267    "*If non-nil, delete incoming files after handling."    "*If non-nil, delete incoming files after handling.
268    If t, delete immediately, if nil, never delete.  If a positive number, delete
269    files older than number of days."
270      ;; Note: The removing happens in `mail-source-callback', i.e. no old
271      ;; incoming files will be deleted, unless you receive new mail.
272      ;;
273      ;; You may also set this to `nil' and call `mail-source-delete-old-incoming'
274      ;; from a hook or interactively.
275      :group 'mail-source
276      :type '(choice (const :tag "immediately" t)
277                     (const :tag "never" nil)
278                     (integer :tag "days")))
279    
280    (defcustom mail-source-delete-old-incoming-confirm t
281      "*If non-nil, ask for for confirmation before deleting old incoming files.
282    This variable only applies when `mail-source-delete-incoming' is a positive
283    number."
284    :group 'mail-source    :group 'mail-source
285    :type 'boolean)    :type 'boolean)
286    
# Line 254  If non-nil, this maildrop will be checke Line 299  If non-nil, this maildrop will be checke
299    :group 'mail-source    :group 'mail-source
300    :type 'number)    :type 'number)
301    
302    (defcustom mail-source-movemail-program nil
303      "If non-nil, name of program for fetching new mail."
304      :group 'mail-source
305      :type '(choice (const nil) string))
306    
307  ;;; Internal variables.  ;;; Internal variables.
308    
309  (defvar mail-source-string ""  (defvar mail-source-string ""
# Line 295  Common keywords should be listed here.") Line 345  Common keywords should be listed here.")
345         (:authentication password))         (:authentication password))
346        (maildir        (maildir
347         (:path (or (getenv "MAILDIR") "~/Maildir/"))         (:path (or (getenv "MAILDIR") "~/Maildir/"))
348         (:subdirs ("new" "cur"))         (:subdirs ("cur" "new"))
349         (:function))         (:function))
350        (imap        (imap
351         (:server (getenv "MAILHOST"))         (:server (getenv "MAILHOST"))
352         (:port)         (:port)
353         (:stream)         (:stream)
354           (:program)
355         (:authentication)         (:authentication)
356         (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))         (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
357         (:password)         (:password)
358         (:mailbox "INBOX")         (:mailbox "INBOX")
359         (:predicate "UNSEEN UNDELETED")         (:predicate "UNSEEN UNDELETED")
360         (:fetchflag "\\Deleted")         (:fetchflag "\\Deleted")
361           (:prescript)
362           (:prescript-delay)
363           (:postscript)
364         (:dontexpunge))         (:dontexpunge))
365        (webmail        (webmail
366         (:subtype hotmail)         (:subtype hotmail)
# Line 365  the `mail-source-keyword-map' variable." Line 419  the `mail-source-keyword-map' variable."
419       ,@body))       ,@body))
420    
421  (put 'mail-source-bind 'lisp-indent-function 1)  (put 'mail-source-bind 'lisp-indent-function 1)
422  (put 'mail-source-bind 'edebug-form-spec '(form body))  (put 'mail-source-bind 'edebug-form-spec '(sexp body))
423    
424  (defun mail-source-set-1 (source)  (defun mail-source-set-1 (source)
425    (let* ((type (pop source))    (let* ((type (pop source))
# Line 408  See `mail-source-bind'." Line 462  See `mail-source-bind'."
462       ,@body))       ,@body))
463    
464  (put 'mail-source-bind-common 'lisp-indent-function 1)  (put 'mail-source-bind-common 'lisp-indent-function 1)
465  (put 'mail-source-bind-common 'edebug-form-spec '(form body))  (put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
466    
467  (defun mail-source-value (value)  (defun mail-source-value (value)
468    "Return the value of VALUE."    "Return the value of VALUE."
# Line 442  Return the number of files that were fou Line 496  Return the number of files that were fou
496                (setq found (mail-source-callback                (setq found (mail-source-callback
497                             callback mail-source-crash-box)))                             callback mail-source-crash-box)))
498              (+ found              (+ found
499                 (condition-case err                 (if (or debug-on-quit debug-on-error)
500                     (funcall function source callback)                     (funcall function source callback)
501                   (error                   (condition-case err
502                    (unless (yes-or-no-p                       (funcall function source callback)
503                             (format "Mail source error (%s).  Continue? " err))                     (error
504                      (error "Cannot get new mail"))                      (if (and (not mail-source-ignore-errors)
505                    0))))))))                               (not
506                                  (yes-or-no-p
507  (eval-and-compile                                 (format "Mail source %s error (%s).  Continue? "
508    (if (fboundp 'make-temp-file)                                         (if (memq ':password source)
509        (defalias 'mail-source-make-complex-temp-name 'make-temp-file)                                             (let ((s (copy-sequence source)))
510      (defun mail-source-make-complex-temp-name (prefix)                                               (setcar (cdr (memq ':password s))
511        (let ((newname (make-temp-name prefix))                                                       "********")
512              (newprefix prefix))                                               s)
513          (while (file-exists-p newname)                                           source)
514            (setq newprefix (concat newprefix "x"))                                         (cadr err)))))
515            (setq newname (make-temp-name newprefix)))                        (error "Cannot get new mail"))
516          newname))))                      0)))))))))
517    
518    (defun mail-source-delete-old-incoming (&optional age confirm)
519      "Remove incoming files older than AGE days.
520    If CONFIRM is non-nil, ask for confirmation before removing a file."
521      (interactive "P")
522      (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
523             (low2days  (/ 1.0 65536.0))     ;; convert low bits to days
524             (diff (if (natnump age) age 30));; fallback, if no valid AGE given
525             currday files)
526        (setq files (directory-files
527                     mail-source-directory t
528                     (concat mail-source-incoming-file-prefix "*"))
529              currday (* (car (current-time)) high2days)
530              currday (+ currday (* low2days (nth 1 (current-time)))))
531        (while files
532          (let* ((ffile (car files))
533                 (bfile (gnus-replace-in-string
534                         ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
535                 (filetime (nth 5 (file-attributes ffile)))
536                 (fileday (* (car filetime) high2days))
537                 (fileday (+ fileday (* low2days (nth 1 filetime)))))
538            (setq files (cdr files))
539            (when (and (> (- currday fileday) diff)
540                       (gnus-message 8 "File `%s' is older than %s day(s)"
541                                     bfile diff)
542                       (or (not confirm)
543                           (y-or-n-p (concat "Remove file `" bfile "'? "))))
544              (delete-file ffile))))))
545    
546  (defun mail-source-callback (callback info)  (defun mail-source-callback (callback info)
547    "Call CALLBACK on the mail file, and then remove the mail file.    "Call CALLBACK on the mail file, and then remove the mail file.
# Line 474  Pass INFO on to CALLBACK." Line 556  Pass INFO on to CALLBACK."
556          (funcall callback mail-source-crash-box info)          (funcall callback mail-source-crash-box info)
557        (when (file-exists-p mail-source-crash-box)        (when (file-exists-p mail-source-crash-box)
558          ;; Delete or move the incoming mail out of the way.          ;; Delete or move the incoming mail out of the way.
559          (if mail-source-delete-incoming          (if (eq mail-source-delete-incoming t)
560              (delete-file mail-source-crash-box)              (delete-file mail-source-crash-box)
561            (let ((incoming            (let ((incoming
562                   (mail-source-make-complex-temp-name                   (mm-make-temp-file
563                    (expand-file-name                    (expand-file-name
564                     mail-source-incoming-file-prefix                     mail-source-incoming-file-prefix
565                     mail-source-directory))))                     mail-source-directory))))
566              (unless (file-exists-p (file-name-directory incoming))              (unless (file-exists-p (file-name-directory incoming))
567                (make-directory (file-name-directory incoming) t))                (make-directory (file-name-directory incoming) t))
568              (rename-file mail-source-crash-box incoming t)))))))              (rename-file mail-source-crash-box incoming t)
569                ;; remove old incoming files?
570                (when (natnump mail-source-delete-incoming)
571                  (mail-source-delete-old-incoming
572                   mail-source-delete-incoming
573                   mail-source-delete-old-incoming-confirm))))))))
574    
575  (defun mail-source-movemail (from to)  (defun mail-source-movemail (from to)
576    "Move FROM to TO using movemail."    "Move FROM to TO using movemail."
# Line 518  Pass INFO on to CALLBACK." Line 605  Pass INFO on to CALLBACK."
605                         'call-process                         'call-process
606                         (append                         (append
607                          (list                          (list
608                           (expand-file-name "movemail" exec-directory)                           (or mail-source-movemail-program
609                                 (expand-file-name "movemail" exec-directory))
610                           nil errors nil from to)))))                           nil errors nil from to)))))
611                (when (file-exists-p to)                (when (file-exists-p to)
612                  (set-file-modes to mail-source-default-file-modes))                  (set-file-modes to mail-source-default-file-modes))
613                (if (and (not (buffer-modified-p errors))                (if (and (or (not (buffer-modified-p errors))
614                         (zerop result))                             (zerop (buffer-size errors)))
615                           (and (numberp result)
616                                (zerop result)))
617                    ;; No output => movemail won.                    ;; No output => movemail won.
618                    t                    t
619                  (set-buffer errors)                  (set-buffer errors)
# Line 540  Pass INFO on to CALLBACK." Line 630  Pass INFO on to CALLBACK."
630                    (goto-char (point-min))                    (goto-char (point-min))
631                    (when (looking-at "movemail: ")                    (when (looking-at "movemail: ")
632                      (delete-region (point-min) (match-end 0)))                      (delete-region (point-min) (match-end 0)))
633                      ;; Result may be a signal description string.
634                    (unless (yes-or-no-p                    (unless (yes-or-no-p
635                             (format "movemail: %s (%d return).  Continue? "                             (format "movemail: %s (%s return).  Continue? "
636                                     (buffer-string) result))                                     (buffer-string) result))
637                      (error "%s" (buffer-string)))                      (error "%s" (buffer-string)))
638                    (setq to nil)))))))                    (setq to nil)))))))
# Line 557  Pass INFO on to CALLBACK." Line 648  Pass INFO on to CALLBACK."
648        (not (zerop (nth 7 (file-attributes from))))        (not (zerop (nth 7 (file-attributes from))))
649        (delete-file from)))        (delete-file from)))
650    
 (defvar mail-source-read-passwd nil)  
 (defun mail-source-read-passwd (prompt &rest args)  
   "Read a password using PROMPT.  
 If ARGS, PROMPT is used as an argument to `format'."  
   (let ((prompt  
          (if args  
              (apply 'format prompt args)  
            prompt)))  
     (unless mail-source-read-passwd  
       (if (or (fboundp 'read-passwd) (load "passwd" t))  
           (setq mail-source-read-passwd 'read-passwd)  
         (unless (fboundp 'ange-ftp-read-passwd)  
           (autoload 'ange-ftp-read-passwd "ange-ftp"))  
         (setq mail-source-read-passwd 'ange-ftp-read-passwd)))  
     (funcall mail-source-read-passwd prompt)))  
   
651  (defun mail-source-fetch-with-program (program)  (defun mail-source-fetch-with-program (program)
652    (zerop (call-process shell-file-name nil nil nil    (eq 0 (call-process shell-file-name nil nil nil
653                         shell-command-switch program)))                        shell-command-switch program)))
654    
655  (defun mail-source-run-script (script spec &optional delay)  (defun mail-source-run-script (script spec &optional delay)
656    (when script    (when script
657      (if (and (symbolp script) (fboundp script))      (if (functionp script)
658          (funcall script)          (funcall script)
659        (mail-source-call-script        (mail-source-call-script
660         (format-spec script spec))))         (format-spec script spec))))
# Line 616  If ARGS, PROMPT is used as an argument t Line 691  If ARGS, PROMPT is used as an argument t
691    "Fetcher for directory sources."    "Fetcher for directory sources."
692    (mail-source-bind (directory source)    (mail-source-bind (directory source)
693      (mail-source-run-script      (mail-source-run-script
694       prescript (format-spec-make ?t path)       prescript (format-spec-make ?t path) prescript-delay)
      prescript-delay)  
695      (let ((found 0)      (let ((found 0)
696            (mail-source-string (format "directory:%s" path)))            (mail-source-string (format "directory:%s" path)))
697        (dolist (file (directory-files        (dolist (file (directory-files
# Line 626  If ARGS, PROMPT is used as an argument t Line 700  If ARGS, PROMPT is used as an argument t
700                     (funcall predicate file)                     (funcall predicate file)
701                     (mail-source-movemail file mail-source-crash-box))                     (mail-source-movemail file mail-source-crash-box))
702            (incf found (mail-source-callback callback file))))            (incf found (mail-source-callback callback file))))
703        (mail-source-run-script        (mail-source-run-script postscript (format-spec-make ?t path))
        postscript (format-spec-make ?t path))  
704        found)))        found)))
705    
706  (defun mail-source-fetch-pop (source callback)  (defun mail-source-fetch-pop (source callback)
# Line 645  If ARGS, PROMPT is used as an argument t Line 718  If ARGS, PROMPT is used as an argument t
718          (setq password          (setq password
719                (or password                (or password
720                    (cdr (assoc from mail-source-password-cache))                    (cdr (assoc from mail-source-password-cache))
721                    (mail-source-read-passwd                    (read-passwd
722                     (format "Password for %s at %s: " user server)))))                     (format "Password for %s at %s: " user server)))))
723        (when server        (when server
724          (setenv "MAILHOST" server))          (setenv "MAILHOST" server))
# Line 667  If ARGS, PROMPT is used as an argument t Line 740  If ARGS, PROMPT is used as an argument t
740                      (pop3-port port)                      (pop3-port port)
741                      (pop3-authentication-scheme                      (pop3-authentication-scheme
742                       (if (eq authentication 'apop) 'apop 'pass)))                       (if (eq authentication 'apop) 'apop 'pass)))
743                  (save-excursion (pop3-movemail mail-source-crash-box))))))                  (if (or debug-on-quit debug-on-error)
744                        (save-excursion (pop3-movemail mail-source-crash-box))
745                      (condition-case err
746                          (save-excursion (pop3-movemail mail-source-crash-box))
747                        (error
748                         ;; We nix out the password in case the error
749                         ;; was because of a wrong password being given.
750                         (setq mail-source-password-cache
751                               (delq (assoc from mail-source-password-cache)
752                                     mail-source-password-cache))
753                         (signal (car err) (cdr err)))))))))
754        (if result        (if result
755            (progn            (progn
756              (when (eq authentication 'password)              (when (eq authentication 'password)
# Line 699  If ARGS, PROMPT is used as an argument t Line 782  If ARGS, PROMPT is used as an argument t
782          (setq password          (setq password
783                (or password                (or password
784                    (cdr (assoc from mail-source-password-cache))                    (cdr (assoc from mail-source-password-cache))
785                    (mail-source-read-passwd                    (read-passwd
786                     (format "Password for %s at %s: " user server))))                     (format "Password for %s at %s: " user server))))
787          (unless (assoc from mail-source-password-cache)          (unless (assoc from mail-source-password-cache)
788            (push (cons from password) mail-source-password-cache)))            (push (cons from password) mail-source-password-cache)))
# Line 718  If ARGS, PROMPT is used as an argument t Line 801  If ARGS, PROMPT is used as an argument t
801                      (pop3-port port)                      (pop3-port port)
802                      (pop3-authentication-scheme                      (pop3-authentication-scheme
803                       (if (eq authentication 'apop) 'apop 'pass)))                       (if (eq authentication 'apop) 'apop 'pass)))
804                  (save-excursion (pop3-get-message-count))))))                  (if (or debug-on-quit debug-on-error)
805                        (save-excursion (pop3-get-message-count))
806                      (condition-case err
807                          (save-excursion (pop3-get-message-count))
808                        (error
809                         ;; We nix out the password in case the error
810                         ;; was because of a wrong password being given.
811                         (setq mail-source-password-cache
812                               (delq (assoc from mail-source-password-cache)
813                                     mail-source-password-cache))
814                         (signal (car err) (cdr err)))))))))
815        (if result        (if result
816            ;; Inform display-time that we have new mail.            ;; Inform display-time that we have new mail.
817            (setq mail-source-new-mail-available (> result 0))            (setq mail-source-new-mail-available (> result 0))
# Line 729  If ARGS, PROMPT is used as an argument t Line 822  If ARGS, PROMPT is used as an argument t
822                      mail-source-password-cache)))                      mail-source-password-cache)))
823        result)))        result)))
824    
825    (defun mail-source-touch-pop ()
826      "Open and close a POP connection shortly.
827    POP server should be defined in `mail-source-primary-source' (which is
828    preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
829    authentication.  To do that, you need to set the
830    `message-send-mail-function' variable as `message-smtpmail-send-it'
831    and put the following line in your ~/.gnus.el file:
832    
833    \(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
834    
835    See the Gnus manual for details."
836      (let ((sources (if mail-source-primary-source
837                         (list mail-source-primary-source)
838                       mail-sources)))
839        (while sources
840          (if (eq 'pop (car (car sources)))
841              (mail-source-check-pop (car sources)))
842          (setq sources (cdr sources)))))
843    
844  (defun mail-source-new-mail-p ()  (defun mail-source-new-mail-p ()
845    "Handler for `display-time' to indicate when new mail is available."    "Handler for `display-time' to indicate when new mail is available."
846      ;; Flash (ie. ring the visible bell) if mail is available.
847      (if (and mail-source-flash mail-source-new-mail-available)
848          (let ((visible-bell t))
849            (ding)))
850    ;; Only report flag setting; flag is updated on a different schedule.    ;; Only report flag setting; flag is updated on a different schedule.
851    mail-source-new-mail-available)    mail-source-new-mail-available)
852    
# Line 753  If ARGS, PROMPT is used as an argument t Line 869  If ARGS, PROMPT is used as an argument t
869             mail-source-idle-time-delay             mail-source-idle-time-delay
870             nil             nil
871             (lambda ()             (lambda ()
872               (setq mail-source-report-new-mail-idle-timer nil)               (unwind-protect
873               (mail-source-check-pop mail-source-primary-source))))                   (mail-source-check-pop mail-source-primary-source)
874                   (setq mail-source-report-new-mail-idle-timer nil)))))
875      ;; Since idle timers created when Emacs is already in the idle      ;; Since idle timers created when Emacs is already in the idle
876      ;; state don't get activated until Emacs _next_ becomes idle, we      ;; state don't get activated until Emacs _next_ becomes idle, we
877      ;; need to force our timer to be considered active now.  We do      ;; need to force our timer to be considered active now.  We do
# Line 785  This only works when `display-time' is e Line 902  This only works when `display-time' is e
902            (setq display-time-mail-function #'mail-source-new-mail-p)            (setq display-time-mail-function #'mail-source-new-mail-p)
903            ;; Set up the main timer.            ;; Set up the main timer.
904            (setq mail-source-report-new-mail-timer            (setq mail-source-report-new-mail-timer
905                  (run-at-time t (* 60 mail-source-report-new-mail-interval)                  (nnheader-run-at-time
906                               #'mail-source-start-idle-timer))                   (* 60 mail-source-report-new-mail-interval)
907                     (* 60 mail-source-report-new-mail-interval)
908                     #'mail-source-start-idle-timer))
909            ;; When you get new mail, clear "Mail" from the mode line.            ;; When you get new mail, clear "Mail" from the mode line.
910            (add-hook 'nnmail-post-get-new-mail-hook            (add-hook 'nnmail-post-get-new-mail-hook
911                      'display-time-event-handler)                      'display-time-event-handler)
# Line 817  This only works when `display-time' is e Line 936  This only works when `display-time' is e
936                                  (with-temp-file mail-source-crash-box                                  (with-temp-file mail-source-crash-box
937                                    (insert-file-contents file)                                    (insert-file-contents file)
938                                    (goto-char (point-min))                                    (goto-char (point-min))
939  ;;;                               ;; Unix mail format  ;;;                               ;; Unix mail format
940  ;;;                               (unless (looking-at "\n*From ")  ;;;                               (unless (looking-at "\n*From ")
941  ;;;                                 (insert "From maildir "  ;;;                                 (insert "From maildir "
942  ;;;                                         (current-time-string) "\n"))  ;;;                                         (current-time-string) "\n"))
943  ;;;                               (while (re-search-forward "^From " nil t)  ;;;                               (while (re-search-forward "^From " nil t)
944  ;;;                                 (replace-match ">From "))  ;;;                                 (replace-match ">From "))
945  ;;;                               (goto-char (point-max))  ;;;                               (goto-char (point-max))
946  ;;;                               (insert "\n\n")  ;;;                               (insert "\n\n")
947                                    ;; MMDF mail format                                    ;; MMDF mail format
948                                    (insert "\001\001\001\001\n"))                                    (insert "\001\001\001\001\n"))
# Line 852  This only works when `display-time' is e Line 971  This only works when `display-time' is e
971  (defun mail-source-fetch-imap (source callback)  (defun mail-source-fetch-imap (source callback)
972    "Fetcher for imap sources."    "Fetcher for imap sources."
973    (mail-source-bind (imap source)    (mail-source-bind (imap source)
974        (mail-source-run-script
975         prescript (format-spec-make ?p password ?t mail-source-crash-box
976                                     ?s server ?P port ?u user)
977         prescript-delay)
978      (let ((from (format "%s:%s:%s" server user port))      (let ((from (format "%s:%s:%s" server user port))
979            (found 0)            (found 0)
980            (buf (get-buffer-create (generate-new-buffer-name " *imap source*")))            (buf (generate-new-buffer " *imap source*"))
981            (mail-source-string (format "imap:%s:%s" server mailbox))            (mail-source-string (format "imap:%s:%s" server mailbox))
982              (imap-shell-program (or (list program) imap-shell-program))
983            remove)            remove)
984        (if (and (imap-open server port stream authentication buf)        (if (and (imap-open server port stream authentication buf)
985                 (imap-authenticate                 (imap-authenticate
# Line 870  This only works when `display-time' is e Line 994  This only works when `display-time' is e
994                (mm-disable-multibyte)                (mm-disable-multibyte)
995                ;; remember password                ;; remember password
996                (with-current-buffer buf                (with-current-buffer buf
997                  (when (or imap-password                  (when (and imap-password
998                            (assoc from mail-source-password-cache))                             (not (assoc from mail-source-password-cache)))
999                    (push (cons from imap-password) mail-source-password-cache)))                    (push (cons from imap-password) mail-source-password-cache)))
1000                ;; if predicate is nil, use all uids                ;; if predicate is nil, use all uids
1001                (dolist (uid (imap-search (or predicate "1:*") buf))                (dolist (uid (imap-search (or predicate "1:*") buf))
1002                  (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))                  (when (setq str
1003                                (if (imap-capability 'IMAP4rev1 buf)
1004                                    (caddar (imap-fetch uid "BODY.PEEK[]"
1005                                                        'BODYDETAIL nil buf))
1006                                  (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
1007                    (push uid remove)                    (push uid remove)
1008                    (insert "From imap " (current-time-string) "\n")                    (insert "From imap " (current-time-string) "\n")
1009                    (save-excursion                    (save-excursion
# Line 886  This only works when `display-time' is e Line 1014  This only works when `display-time' is e
1014                (nnheader-ms-strip-cr))                (nnheader-ms-strip-cr))
1015              (incf found (mail-source-callback callback server))              (incf found (mail-source-callback callback server))
1016              (when (and remove fetchflag)              (when (and remove fetchflag)
1017                  (setq remove (nreverse remove))
1018                (imap-message-flags-add                (imap-message-flags-add
1019                 (imap-range-to-message-set (gnus-compress-sequence remove))                 (imap-range-to-message-set (gnus-compress-sequence remove))
1020                 fetchflag nil buf))                 fetchflag nil buf))
1021              (if dontexpunge              (if dontexpunge
1022                  (imap-mailbox-unselect buf)                  (imap-mailbox-unselect buf)
1023                (imap-mailbox-close buf))                (imap-mailbox-close nil buf))
1024              (imap-close buf))              (imap-close buf))
1025          (imap-close buf)          (imap-close buf)
1026          ;; We nix out the password in case the error          ;; We nix out the password in case the error
# Line 899  This only works when `display-time' is e Line 1028  This only works when `display-time' is e
1028          (setq mail-source-password-cache          (setq mail-source-password-cache
1029                (delq (assoc from mail-source-password-cache)                (delq (assoc from mail-source-password-cache)
1030                      mail-source-password-cache))                      mail-source-password-cache))
1031          (error (imap-error-text buf)))          (error "IMAP error: %s" (imap-error-text buf)))
1032        (kill-buffer buf)        (kill-buffer buf)
1033          (mail-source-run-script
1034           postscript
1035           (format-spec-make ?p password ?t mail-source-crash-box
1036                             ?s server ?P port ?u user))
1037        found)))        found)))
1038    
1039  (eval-and-compile  (eval-and-compile
# Line 917  This only works when `display-time' is e Line 1050  This only works when `display-time' is e
1050                (or password                (or password
1051                    (cdr (assoc (format "webmail:%s:%s" subtype user)                    (cdr (assoc (format "webmail:%s:%s" subtype user)
1052                                mail-source-password-cache))                                mail-source-password-cache))
1053                    (mail-source-read-passwd                    (read-passwd
1054                     (format "Password for %s at %s: " user subtype))))                     (format "Password for %s at %s: " user subtype))))
1055          (when (and password          (when (and password
1056                     (not (assoc (format "webmail:%s:%s" subtype user)                     (not (assoc (format "webmail:%s:%s" subtype user)

Legend:
Removed from v.1.12.2.2  
changed lines
  Added in v.1.12.2.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26