X-Git-Url: https://git.distorted.org.uk/~mdw/profile/blobdiff_plain/f4e43257fd5b724d48f6451ab6b88a00b379b606..9906310798d936a6cacd0ec5a2d3b607e911c423:/el/mdw-gnus-patch.el?ds=inline diff --git a/el/mdw-gnus-patch.el b/el/mdw-gnus-patch.el new file mode 100644 index 0000000..49e1072 --- /dev/null +++ b/el/mdw-gnus-patch.el @@ -0,0 +1,193 @@ +;;; very unpleasant hacking; may it not last long + +(require 'imap) +(require 'nnimap) +(require 'cl) + +(defsubst imap-parse-number () + (when (looking-at "-?[0-9]+") + (prog1 + (string-to-number (match-string 0)) + (goto-char (match-end 0))))) + +(defun imap-parse-body () + (let (body) + (when (eq (char-after) ?\() + (imap-forward) + (if (eq (char-after) ?\() + (let (subbody) + (while (and (eq (char-after) ?\() + (setq subbody + (imap-parse-body))) + ;; buggy stalker communigate pro + ;; 3.0 insert a SPC between + ;; parts in multiparts + (when (and (eq (char-after) ?\ + ) + (eq (char-after (1+ + (point))) ?\()) + (imap-forward)) + (push subbody body)) + (imap-forward) + (push (imap-parse-string) body) + ;; media-subtype + (when (eq (char-after) ?\ ) ;; body-ext-mpart: + (imap-forward) + (if (eq + (char-after) + ?\() ;; body-fld-param + (push + (imap-parse-string-list) body) + (push (and + (imap-parse-nil) nil) body)) + (setq body + (append + (imap-parse-body-ext) body))) ;; body-ext-... + (assert (eq (char-after) + ?\)) nil "In imap-parse-body") + (imap-forward) + (nreverse body)) + + (push (imap-parse-string) body) ;; media-type + (imap-forward) + (push (imap-parse-string) body) ;; media-subtype + (imap-forward) + ;; next line for Sun SIMS bug + (and (eq (char-after) ? ) (imap-forward)) + (if (eq (char-after) ?\() ;; body-fld-param + (push (imap-parse-string-list) body) + (push (and (imap-parse-nil) nil) body)) + (imap-forward) + (push (imap-parse-nstring) body) ;; body-fld-id + (imap-forward) + (push (imap-parse-nstring) body) ;; body-fld-desc + (imap-forward) + ;; next `or' for Sun SIMS bug, it regard + ;; body-fld-enc as a + ;; nstring and return nil instead of defaulting + ;; back to 7BIT + ;; as the standard says. + (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc + (imap-forward) + (push (imap-parse-number) body) ;; body-fld-octets + + ;; ok, we're done parsing the required parts, + ;; what comes now is one + ;; of three things: + ;; + ;; envelope (then we're parsing + ;; body-type-msg) + ;; body-fld-lines (then we're parsing + ;; body-type-text) + ;; body-ext-1part (then we're parsing + ;; body-type-basic) + ;; + ;; the problem is that the two first are in + ;; turn optionally followed + ;; by the third. So we parse the first two here + ;; (if there are any)... + + (when (eq (char-after) ?\ ) + (imap-forward) + (let (lines) + (cond ((eq (char-after) ?\() ;; body-type-msg: + (push (imap-parse-envelope) + body) ;; envelope + (imap-forward) + (push + (imap-parse-body) body) ;; body + ;; buggy stalker + ;; communigate pro + ;; 3.0 doesn't + ;; print + ;; number of lines + ;; in + ;; message/rfc822 + ;; attachment + (if (eq + (char-after) ?\)) + (push 0 + body) + (imap-forward) + (push + (imap-parse-number) body))) ;; body-fld-lines + ((setq lines + (imap-parse-number)) ;; body-type-text: + (push lines body)) ;; body-fld-lines + (t + (backward-char))))) ;; no match... + + ;; ...and then parse the third one here... + + (when (eq (char-after) ?\ ) ;; body-ext-1part: + (imap-forward) + (push (imap-parse-nstring) body) ;; body-fld-md5 + (setq body (append (imap-parse-body-ext) + body))) ;; body-ext-1part.. + + (assert (eq (char-after) ?\)) nil "In + imap-parse-body 2") + (imap-forward) + (nreverse body))))) + +(defvar imap-enable-exchange-bug-workaround nil + "Send FETCH UID commands as *:* instead of *. +Enabling this appears to be required for some servers (e.g., +Microsoft Exchange) which otherwise would trigger a response 'BAD +The specified message set is invalid.'. + +BACKPORT from No Gnus!") + +(defun nnimap-find-minmax-uid (group &optional examine) + "Find lowest and highest active article number in GROUP. +If EXAMINE is non-nil the group is selected read-only." + (with-current-buffer nnimap-server-buffer + (when (or (string= group (imap-current-mailbox)) + (imap-mailbox-select group examine)) + (let (minuid maxuid) + (when (> (imap-mailbox-get 'exists) 0) + (imap-fetch (if imap-enable-exchange-bug-workaround "1,*:*" "1,*") + "UID" nil 'nouidfetch) + (imap-message-map (lambda (uid Uid) + (setq minuid (if minuid (min minuid uid) uid) + maxuid (if maxuid (max maxuid uid) uid))) + 'UID)) + (list (imap-mailbox-get 'exists) minuid maxuid))))) + +(defun imap-message-copyuid-1 (mailbox) + (if (imap-capability 'UIDPLUS) + (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) + (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) + (let ((old-mailbox imap-current-mailbox) + (state imap-state) + (imap-message-data (make-vector 2 0))) + (when (imap-mailbox-examine-1 mailbox) + (prog1 + (and (imap-fetch + (if imap-enable-exchange-bug-workaround "*:*" "*") "UID") + (list (imap-mailbox-get-1 'uidvalidity mailbox) + (apply 'max (imap-message-map + (lambda (uid prop) uid) 'UID)))) + (if old-mailbox + (imap-mailbox-select old-mailbox (eq state 'examine)) + (imap-mailbox-unselect))))))) + +(defun imap-message-appenduid-1 (mailbox) + (if (imap-capability 'UIDPLUS) + (imap-mailbox-get-1 'appenduid mailbox) + (let ((old-mailbox imap-current-mailbox) + (state imap-state) + (imap-message-data (make-vector 2 0))) + (when (imap-mailbox-examine-1 mailbox) + (prog1 + (and (imap-fetch + (if imap-enable-exchange-bug-workaround "*:*" "*") "UID") + (list (imap-mailbox-get-1 'uidvalidity mailbox) + (apply 'max (imap-message-map + (lambda (uid prop) uid) 'UID)))) + (if old-mailbox + (imap-mailbox-select old-mailbox (eq state 'examine)) + (imap-mailbox-unselect))))))) + +;;(setq imap-log t) +(provide 'mdw-gnus-patch)