chiark - git - mdw - profile/blob - el/mdw-gnus-patch.el

   1 ;;; very unpleasant hacking; may it not last long
   2
   3 (require 'imap)
   4 (require 'nnimap)
   5 (require 'cl)
   6
   7 (defsubst imap-parse-number ()
   8   (when (looking-at "-?[0-9]+")
   9     (prog1
  10         (string-to-number (match-string 0))
  11       (goto-char (match-end 0)))))
  12
  13 (defun imap-parse-body ()
  14   (let (body)
  15     (when (eq (char-after) ?\()
  16       (imap-forward)
  17       (if (eq (char-after) ?\()
  18           (let (subbody)
  19             (while (and (eq (char-after) ?\()
  20                         (setq subbody (imap-parse-body)))
  21               ;; buggy stalker communigate pro 3.0 insert a SPC between parts
  22               ;; in multiparts
  23               (when (and (eq (char-after) ?\ )
  24                          (eq (char-after (1+ (point))) ?\())
  25                 (imap-forward))
  26               (push subbody body))
  27             (imap-forward)
  28             (push (imap-parse-string) body) ;; media-subtype
  29             (when (eq (char-after) ?\ )     ;; body-ext-mpart:
  30               (imap-forward)
  31               (if (eq (char-after) ?\() ;; body-fld-param
  32                   (push (imap-parse-string-list) body)
  33                 (push (and (imap-parse-nil) nil) body))
  34               (setq body
  35                       (append (imap-parse-body-ext) body))) ;; body-ext-...
  36             (assert (eq (char-after) ?\)) nil "In imap-parse-body")
  37             (imap-forward)
  38             (nreverse body))
  39
  40         (push (imap-parse-string) body) ;; media-type
  41         (imap-forward)
  42         (push (imap-parse-string) body) ;; media-subtype
  43         (imap-forward)
  44         ;; next line for Sun SIMS bug
  45         (and (eq (char-after) ? ) (imap-forward))
  46         (if (eq (char-after) ?\() ;; body-fld-param
  47             (push (imap-parse-string-list) body)
  48           (push (and (imap-parse-nil) nil) body))
  49         (imap-forward)
  50         (push (imap-parse-nstring) body) ;; body-fld-id
  51         (imap-forward)
  52         (push (imap-parse-nstring) body) ;; body-fld-desc
  53         (imap-forward)
  54         ;; next `or' for Sun SIMS bug, it regards body-fld-enc as a nstring
  55         ;; and return nil instead of defaulting back to 7BIT as the standard
  56         ;; says.
  57         (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
  58         (imap-forward)
  59         (push (imap-parse-number) body) ;; body-fld-octets
  60
  61         ;; ok, we're done parsing the required parts, what comes now is one
  62         ;; of three things:
  63         ;;
  64         ;; envelope       (then we're parsing body-type-msg)
  65         ;; body-fld-lines (then we're parsing body-type-text)
  66         ;; body-ext-1part (then we're parsing body-type-basic)
  67         ;;
  68         ;; the problem is that the two first are in turn optionally followed
  69         ;; by the third.  So we parse the first two here (if there are
  70         ;; any)...
  71
  72         (when (eq (char-after) ?\ )
  73           (imap-forward)
  74           (let (lines)
  75             (cond ((eq (char-after) ?\() ;; body-type-msg:
  76                    (push (imap-parse-envelope) body) ;; envelope
  77                    (imap-forward)
  78                    (push (imap-parse-body) body) ;; body
  79                    ;; buggy stalker communigate pro 3.0 doesn't print number
  80                    ;; of lines in message/rfc822 attachment
  81                    (if (eq (char-after) ?\))
  82                        (push 0 body)
  83                      (imap-forward)
  84                      (push (imap-parse-number) body))) ;; body-fld-lines
  85                   ((setq lines (imap-parse-number)) ;; body-type-text:
  86                    (push lines body))           ;; body-fld-lines
  87                   (t
  88                    (backward-char))))) ;; no match...
  89
  90         ;; ...and then parse the third one here...
  91
  92         (when (eq (char-after) ?\ ) ;; body-ext-1part:
  93           (imap-forward)
  94           (push (imap-parse-nstring) body) ;; body-fld-md5
  95           (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
  96
  97         (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
  98         (imap-forward)
  99         (nreverse body)))))
 100
 101 (defvar imap-enable-exchange-bug-workaround nil
 102   "Send FETCH UID commands as *:* instead of *.
 103 Enabling this appears to be required for some servers (e.g.,
 104 Microsoft Exchange) which otherwise would trigger a response 'BAD
 105 The specified message set is invalid.'.
 106
 107 BACKPORT from No Gnus!")
 108
 109 (defun nnimap-find-minmax-uid (group &optional examine)
 110   "Find lowest and highest active article number in GROUP.
 111 If EXAMINE is non-nil the group is selected read-only."
 112   (with-current-buffer nnimap-server-buffer
 113     (when (or (string= group (imap-current-mailbox))
 114               (imap-mailbox-select group examine))
 115       (let (minuid maxuid)
 116         (when (> (imap-mailbox-get 'exists) 0)
 117           (imap-fetch (if imap-enable-exchange-bug-workaround "1,*:*" "1,*")
 118                       "UID" nil 'nouidfetch)
 119           (imap-message-map (lambda (uid Uid)
 120                               (setq minuid (if minuid (min minuid uid) uid)
 121                                     maxuid (if maxuid (max maxuid uid) uid)))
 122                             'UID))
 123         (list (imap-mailbox-get 'exists) minuid maxuid)))))
 124
 125 (defun imap-message-copyuid-1 (mailbox)
 126   (if (imap-capability 'UIDPLUS)
 127       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
 128             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
 129     (let ((old-mailbox imap-current-mailbox)
 130           (state imap-state)
 131           (imap-message-data (make-vector 2 0)))
 132       (when (imap-mailbox-examine-1 mailbox)
 133         (prog1
 134             (and (imap-fetch
 135                   (if imap-enable-exchange-bug-workaround "*:*" "*") "UID")
 136                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
 137                        (apply 'max (imap-message-map
 138                                     (lambda (uid prop) uid) 'UID))))
 139           (if old-mailbox
 140               (imap-mailbox-select old-mailbox (eq state 'examine))
 141             (imap-mailbox-unselect)))))))
 142
 143 (defun imap-message-appenduid-1 (mailbox)
 144   (if (imap-capability 'UIDPLUS)
 145       (imap-mailbox-get-1 'appenduid mailbox)
 146     (let ((old-mailbox imap-current-mailbox)
 147           (state imap-state)
 148           (imap-message-data (make-vector 2 0)))
 149       (when (imap-mailbox-examine-1 mailbox)
 150         (prog1
 151             (and (imap-fetch
 152                   (if imap-enable-exchange-bug-workaround "*:*" "*") "UID")
 153                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
 154                        (apply 'max (imap-message-map
 155                                     (lambda (uid prop) uid) 'UID))))
 156           (if old-mailbox
 157               (imap-mailbox-select old-mailbox (eq state 'examine))
 158             (imap-mailbox-unselect)))))))
 159
 160 ;;(setq imap-log t)
 161 (provide 'mdw-gnus-patch)