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