From: yamaoka Date: Thu, 6 Jan 2000 04:34:20 +0000 (+0000) Subject: Sync up with Gnus v5.8.3. X-Git-Tag: t-gnus-6_14_1-00~3 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=cd13ede00e34997d48de2589ea45c0d6a62cf7c4;p=elisp%2Fgnus.git- Sync up with Gnus v5.8.3. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 16f290a..4d81184 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,705 @@ +2000-01-05 17:31:52 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-select-article): Return whether we + selected something new. + (gnus-summary-search-article): Start searching at the window + point. + + * gnus-group.el (gnus-fetch-group): Complete over + gnus-active-hashtb. + +Wed Jan 5 17:06:41 2000 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v5.8.3 is released. + +2000-01-05 15:56:02 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-preserve-marks): New variable. + (gnus-summary-move-article): Use it. + (gnus-group-charset-alist): Added more entries. + +2000-01-03 01:18:36 Lars Magne Ingebrigtsen + + * mm-decode.el (mm-inline-override-types): Removed duplicate. + + * gnus-uu.el (gnus-uu-mark-over): Use gnus-summary-default-score + as the default score. + + * gnus-score.el (gnus-score-delta-default): Changed name. + +2000-01-04 Simon Josefsson + + * imap.el (imap-parse-literal): + (imap-parse-flag-list): Don't care about props. + (imap-parse-string): Handle quoted characters. + +2000-01-02 08:37:03 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-goto-unread): Doc fix. + (gnus-summary-mark-article): Doc fix. + (gnus-summary-mark-forward): Doc fix. + (t): Changed keystroke for gnus-summary-customize-parameters. + + * gnus-art.el (gnus-article-mode-map): Use gnus-article-edit for + "e". + (gnus-article-mode-map): No, don't. + + * gnus-sum.el (gnus-summary-next-subject): Don't show the thread + of the final article. + + * mm-decode.el (mm-interactively-view-part): Error on no method. + +2000-01-02 06:10:32 Stefan Monnier + + * gnus-score.el (gnus-score-insert-help): Something. + + * gnus-art.el (gnus-button-alist): Exclude < from + + * nnwarchive.el: Changed file perms. + +1999-12-19 21:42:15 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-delete-groups): New command. + (gnus-group-delete-group): Extra no-prompt parameters. + +1999-12-14 10:18:30 Lars Magne Ingebrigtsen + + * nnslashdot.el (nnslashdot-request-article): Translate
into +

. + +1999-12-28 12:20:18 Shenghuo ZHU + + * webmail.el (webmail-hotmail-article): Don't insert message id. + +1999-12-28 Kai.Grossjohann@CS.Uni-Dortmund.DE (Kai Großjohann) + + * nnimap.el (nnimap-split-fancy): New variable. + (nnimap-split-fancy): New function. + +1999-12-28 Simon Josefsson + + (nnimap-split-rule): Document symbol value. + +1999-12-28 Simon Josefsson + + * nnimap.el (nnimap-retrieve-headers-progress): Let + `nnheader-parse-head' parse article. + (nnimap-retrieve-headers-from-server): Don't request ENVELOPE, + request headers needed by `nnheader-parse-head'. + +1999-12-23 Florian Weimer + + * gnus-msg.el (gnus-group-posting-charset-alist): Correct default + value (crosspostings are handled), improve documentation. + + * smiley.el: Declare file coding system as iso-8859-1. + + * nnultimate.el: Dito. + + * message.el: Dito. + + * gnus-cite.el: Dito. + + * gnus-spec.el: Dito. + +1999-12-21 Florian Weimer + + * gnus-msg.el (gnus-group-posting-charset-alist): New layout. + (gnus-setup-message): No longer make `message-posting-charset' + buffer-local. + (gnus-setup-posting-charset): Reflect the new layout of + `gnus-group-posting-charset-alist' and `message-posting-charset'. + + * message.el (message-send-mail): Bind `message-this-is-mail' and + `message-posting-charset'. + (message-send-news): Dito, and honour new layout of + `message-posting-charset'. + (message-encode-message-body): Ignore `message-posting-charset'. + + * mm-bodies.el (mm-body-encoding): Consider + `message-posting-charset' when deciding whether to use 8bit. + + * rfc2047.el (rfc2047-encode-message-header): Back out change. + (rfc2047-encodable-p): Now solely for headers; use + `message-posting-charset'. + +1999-12-20 14:10:39 Shenghuo ZHU + + * nnwarchive.el (nnwarchive-type-definition): Set default value. + +1999-12-19 22:49:13 Shenghuo ZHU + + * nnagent.el (nnagent-server-opened): Optional. + (nnagent-status-message): Optional. + +1999-12-19 Simon Josefsson + + * gnus-cite.el (gnus-article-toggle-cited-text): Restore beg and + end (referenced by instructions in + `gnus-cited-opened-text-button-line-format-alist'). + +1999-12-18 Simon Josefsson + + * imap.el (imap-starttls-open): Typo. + +1999-12-18 16:43:37 Shenghuo ZHU + + * mm-util.el (mm-charset-after): Non-MULE case. + * mail-prsvr.el (mail-parse-mule-charset): New variable. + * rfc2047.el (rfc2047-dissect-region): Bind it. + +1999-12-18 Florian Weimer + + * mml.el (mml-generate-multipart-alist): Correct default value. + + * mm-encode.el (mm-use-ultra-safe-encoding): New variable. + (mm-safer-encoding): New function. + (mm-content-transfer-encoding): Use both. + + * mm-bodies.el (mm-body-encoding): Use mm-use-ultra-safe-encoding. + * qp.el (quoted-printable-encode-region): Dito. + +1999-12-18 14:08:48 Shenghuo ZHU + + * webmail.el (webmail-hotmail-article): Snarf the raw file. + +1999-12-18 14:08:12 Victor S. Miller + + * webmail.el (webmail-hotmail-list): raw=0. + +1999-12-18 11:14:51 Shenghuo ZHU + + * gnus-agent.el (gnus-agent-enter-history): Back-compatible in + group name. + +1999-12-18 11:02:00 Shenghuo ZHU + + * gnus-agent.el (gnus-agent-expire): Convert to symbol if stringp. + +1999-12-18 Simon Josefsson + + * imap.el: Don't autoload digest-md5. + (imap-starttls-open): Bind coding-system-for-{read,write}. + (imap-starttls-p): Check if we can find starttls.el. + (imap-digest-md5-p): Check if we can find digest-md5.el. + +1999-12-17 Daiki Ueno + + * base64.el (base64-encode-string): Accept 2nd argument + `no-line-break'. + + * imap.el: Require `digest-md5' when compiling; add autoload + settings for `digest-md5-parse-digest-challenge', + `digest-md5-digest-response', `starttls-open-stream' and + `starttls-negotiate'. + (imap-authenticators): Add `digest-md5'. + (imap-authenticator-alist): Setup for `digest-md5'. + (imap-digest-md5-p): New function. + (imap-digest-md5-auth): New function. + (imap-stream-alist): Add STARTTLS entry. + (imap-starttls-p): New function. + (imap-starttls-open): New function. + +1999-12-18 01:08:10 Shenghuo ZHU + + * gnus-agent.el (gnus-agent-enter-history): Bad group name. + +1999-12-17 19:36:47 Shenghuo ZHU + + * rfc2047.el (rfc2047-dissect-region): Use mapcar instead of + string-to-x function. + +1999-12-17 13:08:54 Shenghuo ZHU + + * rfc2047.el (rfc2047-fold-region): Fold a line more than once. + +1999-12-17 11:54:41 Shenghuo ZHU + + * webmail.el: Enhance hotmail-snarf. + +1999-12-17 10:38:10 Shenghuo ZHU + + * rfc2047.el (rfc2047-dissect-region): Rewrite. + +1999-12-16 22:59:22 Shenghuo ZHU + + * webmail.el (webmail-hotmail-list): Search no-error. + +1999-12-15 22:07:15 Shenghuo ZHU + + * nnwarchive.el: Support nov-is-evil. + * gnus-bcklg.el (gnus-backlog-request-article): Buffer is optional. + Set it if non-nil. + * gnus-agent.el (gnus-agent-fetch-articles): Use it. + +1999-12-15 08:55:19 Shenghuo ZHU + + * nnagent.el (nnagent-server-opened): Redefine. + (nnagent-status-message): Ditto. + +1999-12-14 23:37:44 Shenghuo ZHU + + * rfc1843.el (rfc1843-decode-region): Use + buffer-substring-no-properties. + * gnus-art.el (article-decode-HZ): New function. + +1999-12-14 22:07:26 Shenghuo ZHU + + * nnheader.el (nnheader-translate-file-chars): Only in full path. + +1999-12-14 16:21:45 Shenghuo ZHU + + * mm-util.el (mm-find-charset-region): mail-parse-charset is a + MIME charset not a MULE charset. + +1999-12-14 15:08:03 Shenghuo ZHU + + * gnus-ems.el: Translate more ugly characters. + * nnheader.el (nnheader-translate-file-chars): Don't translate + the second ':'. + +1999-12-14 10:40:33 Shenghuo ZHU + + * gnus-art.el (gnus-request-article-this-buffer): Use all refer + method if cannot find the article. + +1999-12-14 01:13:50 Shenghuo ZHU + + * gnus-art.el (gnus-request-article-this-buffer): Don't use refer + method if overrided. + +1999-12-13 23:38:53 Shenghuo ZHU + + * mail-source.el (mail-source-fetch-webmail): Parameter + dontexpunge. + +1999-12-13 23:31:17 Shenghuo ZHU + + * webmail.el: Support my-deja. Better error report. + +1999-12-13 18:59:33 Shenghuo ZHU + + * nnslashdot.el (nnslashdot-date-to-date): Error proof when input + is bad. + * gnus-sum.el (gnus-list-of-unread-articles): When (car read) + is not 1. + +1999-12-13 18:22:08 Shenghuo ZHU + + * nnslashdot.el (nnslashdot-request-article): A space. + +1999-12-13 17:20:25 Shenghuo ZHU + + * nnagent.el: Support different backend with same name. + +1999-12-13 13:14:42 Shenghuo ZHU + + * nnslashdot.el (nnslashdot-threaded-retrieve-headers): Support + archived group. + (nnslashdot-sane-retrieve-headers): Ditto. + (nnslashdot-request-article): Ditto. + +1999-12-13 11:41:32 Shenghuo ZHU + + * nnweb.el (nnweb-insert): Narrow to point. + +1999-12-13 10:59:42 Shenghuo ZHU + + * nnweb.el (nnweb-insert): Follow refresh url. + * nnslashdot.el: Use it. + +1999-12-13 10:39:53 Shenghuo ZHU + + * nnweb.el (nnweb-decode-entities): Decode numerical entities. + (nnweb-decode-entities-string): New function. + + * nnwarchive.el (nnwarchive-decode-entities-string): Rename to + nnweb-* and move to nnweb.el. + * nnwarchive.el: Use nnweb-decode-entities, etc. + * webmail.el: Ditto. + + * nnslashdot.el: Use nnweb-decode-entities-string. + (nnslashdot-decode-entities): Remove. + +1999-12-13 10:40:56 Eric Marsden + + * nnslashdot.el: Decode entities. + +1999-12-12 Dave Love + + * gnus-agent.el (gnus-category-edit-groups) + (gnus-category-edit-score, gnus-category-edit-predicate): Replace + expansion of setf, fixed. + +1999-12-12 12:50:30 Shenghuo ZHU + + * gnus-agent.el: Revoke last Dave Love's patch, because of + incompatibility of XEmacs. + +1999-12-12 12:27:03 Shenghuo ZHU + + * mm-uu.el: Change headers. + * rfc1843.el: Ditto. + * uudecode.el: Ditto. + +1999-12-07 Dave Love + + * gnus-agent.el (gnus-category-edit-predicate) + (gnus-category-edit-score, gnus-category-edit-score): Expand setf + inside backquote to avoid it at runtime. + +1999-12-07 Dave Love + + * binhex.el: Require cl when compiling. + +1999-12-04 Dave Love + + * gnus-cus.el (gnus-group-parameters): Allow nil for banner. + +1999-12-04 Dave Love + + * mm-util.el (mm-delete-duplicates): New function. + (mm-write-region): Use it. + + * mml.el (mml-minibuffer-read-type): Use mm-delete-duplicates. + + * mailcap.el (mailcap-mime-types): Require mm-util. Use + mm-delete-duplicates. + + * imap.el (imap-open, imap-debug): Avoid mapc. + + * nnvirtual.el (nnvirtual-create-mapping): Likewise. + + * gnus-sum.el (gnus-summary-exit-no-update): Avoid copy-list. + (gnus-multi-decode-encoded-word-string): Avoid mapc. + + * gnus-start.el (gnus-site-init-file): Avoid ignore-errors at + runtime. + + * gnus.el (gnus-select-method): Likewise. + + * nnheader.el (nnheader-nov-read-integer): Likewise. + + * mm-view.el (mm-inline-message): Require cl when compiling. + Avoid ignore-errors at runtime. + (mm-inline-text): Avoid mapc. + +1999-12-12 10:36:51 Shenghuo ZHU + + * gnus-art.el (article-decode-charset): Widen is bad. + +1999-12-12 10:17:42 Shenghuo ZHU + + * mm-util.el (mm-charset-after): `charset-after' may not be defined. + +1999-12-12 Florian Weimer + + * rfc2047.el (rfc2047-encodable-p): New parameter header used to + indicate that only US-ASCII is permitted. + (rfc2047-encode-message-header): Use it. Now, Gnus should never + use unencoded 8-bit characters in message headers. + +1999-12-12 03:08:15 Shenghuo ZHU + + * ietf-drums.el (ietf-drums-narrow-to-header): Make it work with + CRLF. + +1999-12-11 14:42:26 Shenghuo ZHU + + * webmail.el: Require url-cookie. + +1999-12-11 14:21:23 Shenghuo ZHU + + * nnwarchive.el (nnwarchive-make-caesar-translation-table): A + new function to make modified caesar table. + (nnwarchive-from-r13): Use it. + (nnwarchive-mail-archive-article): Improved. + +1999-12-11 12:30:20 Shenghuo ZHU + + * webmail.el (webmail-url): Use mm-with-unibyte-current-buffer. + +1999-12-10 16:22:24 Shenghuo ZHU + + * nnweb.el (nnweb-request-article): Return cons. + +1999-12-10 16:06:04 Shenghuo ZHU + + * gnus-sum.el (gnus-summary-setup-default-charset): Typo. + +1999-12-10 12:14:04 Shenghuo ZHU + + * mm-util.el (mm-with-unibyte): New macro. + * nnweb.el (nnweb-init): Use it. + +1999-12-09 20:39:49 Shenghuo ZHU + + * mm-util.el (mm-charset-after): New function. + (mm-find-mime-charset-region): Set charsets after + delete-duplicates and use find-coding-systems-region. + (mm-find-charset-region): Remove composition. + + * mm-bodies.el (mm-encode-body): Use mm-charset-after. + + * mml.el (mml-parse-singlepart-with-multiple-charsets): Ditto. + +1999-12-09 17:47:56 Shenghuo ZHU + + * mm-util.el (mm-find-mime-charset-region): Revoke last change. + * mml.el (mml-confirmation-set): New variable. + (mml-parse-1): Ask user to confirm. + +1999-12-09 Simon Josefsson + + * gnus-start.el (gnus-get-unread-articles): Make sure all methods + are scanned when we have directory mail-sources (the mail source + is modified in that case, so we must scan it for all + groups/methods). + +1999-12-09 12:05:28 Shenghuo ZHU + + * nnml.el (nnml-request-move-article): Save nnml-current-directory + and nnml-article-file-alist. + +1999-12-09 10:20:07 Shenghuo ZHU + + * gnus-group.el (gnus-group-get-new-news-this-group): Binding + nnmail-fetched-sources. + +1999-12-09 10:19:01 Shenghuo ZHU + + * mm-util.el (mm-find-charset-region): Use the last charset. + +1999-12-08 Per Abrahamsen + + * gnus.el (gnus-select-method): Made the option list prettier. + +1999-12-08 Florian Weimer + + * gnus-msg.el (gnus-group-posting-charset-alist): Use iso-8859-1 + for the `de' newsgroups hierarchy, as it is common practice there. + + +1999-12-07 16:17:12 Shenghuo ZHU + + * nnwarchive.el (nnwarchive-mail-archive-article): Fix + buffer-string arguments. Fix references. + +1999-12-07 15:04:18 Shenghuo ZHU + + * gnus-agent.el (gnus-agent-confirmation-function): New variable. + (gnus-agent-batch-fetch): Use it. + (gnus-agent-fetch-session): Use it. + +1999-12-07 12:32:43 Shenghuo ZHU + + * mm-util.el (mm-find-mime-charset-region): Delete nil. + +1999-12-07 11:45:10 Shenghuo ZHU + + * mm-util.el (mm-find-charset-region): Don't capitalize. Delete + nil. + +1999-12-07 Per Abrahamsen + + * nnslashdot.el (nnslashdot-request-list): There were two + top-level body-forms. Put a `progn' around them. + + * gnus.el (gnus-select-method): Use `condition-case' + instead of `ignore-errors', since cl may not be loaded when the + form is evaluated. + +1999-12-06 23:57:47 Shenghuo ZHU + + * nnwarchive.el: Support www.mail-archive.com. + +1999-12-06 23:55:55 Shenghuo ZHU + + * nnmail.el (nnmail-get-new-mail): Remove fetched sources before + do anything. + +1999-12-06 Simon Josefsson + + * utf7.el: New file, written by Jon K Hellan. + + * imap.el (imap-use-utf7): Renamed from `imap-utf7-p', change + default to t. + +1999-12-06 04:40:24 Lars Magne Ingebrigtsen + + * nnslashdot.el (nnslashdot-request-delete-group): New function. + + * gnus-sum.el (gnus-summary-refer-article): Work for lists with + current. + (gnus-refer-article-methods): New function. + (gnus-summary-refer-article): Use it. + +1999-11-13 Simon Josefsson + + * nnimap.el (nnimap-retrieve-groups): Return active format. + + * nnimap.el (nnimap-replace-in-string): Removed. + (nnimap-request-list): + (nnimap-retrieve-groups): + (nnimap-request-newgroups): Quote group instead of escaping SPC. + +1999-12-05 Simon Josefsson + + * imap.el: Use format-spec for ssl program. + * imap.el (imap-ssl-arguments): Removed. + (imap-ssl-open-{1,2}): Removed. + +1999-12-04 Per Abrahamsen + + * gnus-start.el (gnus-site-init-file): Use `condition-case' + instead of `ignore-errors', since cl may not be loaded when the + form is evaluated. + +1999-12-04 11:34:22 Shenghuo ZHU + + * mm-bodies.el (mm-8bit-char-regexps): Removed. + (mm-7bit-chars): New variable. + (mm-body-7-or-8): Use it in both cases. + +1999-12-04 Simon Josefsson + + * mm-decode.el (mm-display-part): Let mm-display-external return + inline or external. + (mm-display-external): For copiousoutput methods, insert output in + buffer. + +1999-12-04 03:29:13 Shenghuo ZHU + + * nntp.el (nntp-retrieve-headers-with-xover): Goto the end of + buffer. + +1999-12-04 08:31:10 Lars Magne Ingebrigtsen + + * gnus-audio.el: An M too far. + + * gnus-msg.el (gnus-setup-message): One backtick too many. + + * gnus-art.el (gnus-mime-view-part-as-type): mailcap-mime-types is + a function, not a variable. + +1999-12-04 08:14:08 Max Froumentin + + * gnus-score.el (gnus-score-body): Widen before requesting. + +1999-12-04 08:06:13 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-prepare-flat): Comment fix. + +1999-12-04 03:01:55 Shenghuo ZHU + + * mail-source.el (mail-source-fetch-webmail): Bind + mail-source-string. + +1999-12-04 07:18:23 Matt Swift + + * gnus-uu.el (gnus-uu-mark-by-regexp): Doc fix. + (gnus-uu-unmark-by-regexp): Ditto. + + * gnus-group.el (gnus-group-catchup-current): Would bug out on + dead groups. + +1999-12-04 01:34:31 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-setup-message): Allow the charset setting to + do their real thing. + + * nnmh.el (nnmh-be-safe): Doc fix. + + * gnus-sum.el (gnus-summary-exit): Write cache active file. + + * nntp.el (nntp-retrieve-headers-with-xover): Make sure the entire + status line has arrived before we count it. + + * mailcap.el (mailcap-mime-data): Removed save-file from audio/*. + + * gnus-sum.el (gnus-thread-header): Fixed after indent. + Whitespace problems. + + * gnus-win.el (gnus-configure-windows): Error fix. + + * gnus-demon.el (gnus-demon-add-nntp-close-connection): Add the + right function. + + * gnus.el: Fixed all the doc strings to match the FSF convetions. + Indent all functions. Fix all comments to match the comment + conventions. Double-space after full stop. + +1999-12-04 01:14:55 YAMAMOTO Kouji + + * nnmail.el (nnmail-split-it): I redefined nnmail-split-fancy's + value to divide received mails into my favorite groups and I met + an error. It takes place if the length of a element "VALUE" in + nnmail-split-fancy is less than two. + +1999-10-10 Robert Bihlmeyer + + * mml.el (mml-insert-part): New function. + +1999-09-29 04:48:14 Katsumi Yamaoka + + * lpath.el: Add `sc-cite-regexp'. + +1999-12-02 Dave Love + + * mm-decode.el: Customize. + +1999-12-03 Dave Love + + * nnslashdot.el, nnultimate.el: Don't lose at compile time when + the W3 stuff isn't available. + +1999-12-03 Dave Love + + * imap.el, mailcap.el, nnvirtual.el, rfc2104.el: Don't require cl + at runtime. + +1999-12-04 00:47:35 Dan Christensen + + * gnus-score.el (gnus-score-headers): Fix orphan scoring. + +1999-12-01 Andrew Innes + + * nnmbox.el (nnmbox-read-mbox): Count messages correctly, and + don't be fooled by "From nobody" lines added by respooling. + + * pop3.el (pop3-movemail): Write crashbox in binary. + (pop3-get-message-count): New function. + + * mail-source.el (mail-source-primary-source): New variable. + (mail-source-report-new-mail-interval): New variable. + (mail-source-idle-time-delay): New variable. + (mail-source-new-mail-available): New internal variable. + (mail-source-fetch-pop): Clear new mail flag, when mail from + primary source has been fetched. + (mail-source-check-pop): New function. + (mail-source-new-mail-p): New function. + (mail-source-start-idle-timer): New function. + (mail-source-report-new-mail): New function. + (mail-source-report-new-mail): New internal variable. + (mail-source-report-new-mail-timer): New internal variable. + (mail-source-report-new-mail-idle-timer): New internal variables. + +1999-12-04 00:39:34 Andreas Schwab + + * gnus-cus.el (gnus-group-customize): Customize fix. + +1999-12-04 00:38:24 Andrea Arcangeli + + * message.el (message-send-mail-with-sendmail): Use + message-make-address. + Fri Dec 3 20:34:11 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v5.8.2 is released. @@ -1138,11 +1840,16 @@ Mon Sep 27 15:18:05 1999 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-predicate): Work for (not 5). -1999-08-27 Peter von der Ah-Ai +1999-08-27 Peter von der Ahe * message.el (message-send): More helpful error message if sending fails +1999-09-06 Robert Bihlmeyer + + * gnus-score.el (gnus-summary-increase-score): "Lars" was broken + in newer emacsen, where ?r isn't equal 114. + Fri Aug 27 13:17:48 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.96 is released. @@ -1287,6 +1994,7 @@ Fri Aug 27 13:17:48 1999 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-fetch-group-1): Recreate agent overview buffer if it is killed. + 1999-08-27 14:26:03 Eric Marsden * gnus-art.el (article-babel): New version. @@ -1340,7 +2048,7 @@ Fri Aug 27 13:17:48 1999 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-get-undownloaded-list): Don't mark cached articles as `undownloaded'. -Tue Jul 20 02:39:56 1999 Peter von der Ah-Ai +Tue Jul 20 02:39:56 1999 Peter von der Ahe * gnus-sum.el (gnus-summary-exit): Allow gnus-use-adaptive-scoring to have buffer local values. @@ -3892,7 +4600,7 @@ Mon Nov 30 23:38:02 1998 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Use mm-make-handle. -1998-12-01 01:53:49 Fran-Agois Pinard +1998-12-01 01:53:49 Francois Pinard * nndoc.el (nndoc-mime-parts-type-p): Do related. @@ -5638,7 +6346,7 @@ Mon Sep 14 18:55:38 1998 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-q-encode-region): Would bug out. -1998-09-13 Fran-Agois Pinard +1998-09-13 Francois Pinard * nndoc.el: Make nndoc-dissection-alist simpler for MIME, adjust all related functions. Handle message/rfc822 parts. Display subject on diff --git a/lisp/base64.el b/lisp/base64.el index 42750dd..ff4146c 100644 --- a/lisp/base64.el +++ b/lisp/base64.el @@ -74,7 +74,7 @@ base64-encoder-program.") ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53) ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59) ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63) - )) + )) (defvar base64-alphabet-decoding-vector (let ((v (make-vector 123 nil)) @@ -137,9 +137,9 @@ base64-encoder-program.") (if base64-decoder-program (let* ((binary-process-output t) ; any text already has CRLFs (status (apply 'base64-run-command-on-region - start end work-buffer - base64-decoder-program - base64-decoder-switches))) + start end work-buffer + base64-decoder-program + base64-decoder-switches))) (if (not (eq status t)) (error "%s" (cdr status)))) (goto-char start) @@ -158,7 +158,7 @@ base64-encoder-program.") (cond ((= counter 4) (base64-insert-char (lsh bits -16) 1 nil work-buffer) (base64-insert-char (logand (lsh bits -8) 255) 1 nil - work-buffer) + work-buffer) (base64-insert-char (logand bits 255) 1 nil work-buffer) (setq bits 0 counter 0)) @@ -256,12 +256,12 @@ base64-encoder-program.") (and work-buffer (kill-buffer work-buffer)))) (message "Encoding base64... done")) -(defun base64-encode (string) +(defun base64-encode (string &optional no-line-break) (save-excursion (set-buffer (get-buffer-create " *base64-encode*")) (erase-buffer) (insert string) - (base64-encode-region (point-min) (point-max)) + (base64-encode-region (point-min) (point-max) no-line-break) (skip-chars-backward " \t\r\n") (delete-region (point-max) (point)) (prog1 diff --git a/lisp/binhex.el b/lisp/binhex.el index b562051..200d571 100644 --- a/lisp/binhex.el +++ b/lisp/binhex.el @@ -1,14 +1,11 @@ ;;; binhex.el -- elisp native binhex decode -;; Copyright (c) 1998 by Shenghuo Zhu +;; Copyright (c) 1998 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Create Date: Oct 1, 1998 -;; $Revision: 1.1.2.7.6.1 $ -;; Time-stamp: -;; Keywords: binhex +;; Keywords: binhex news -;; This file is not part of GNU Emacs, but the same permissions -;; apply. +;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -29,6 +26,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (if (not (fboundp 'char-int)) (fset 'char-int 'identity)) @@ -251,21 +250,21 @@ If HEADER-ONLY is non-nil only decode header and return filename." ((= counter 2) (binhex-push-char (logand (lsh bits -10) 255) 1 nil work-buffer)))) - (if header-only nil - (binhex-verify-crc work-buffer - data-fork-start - (+ data-fork-start (aref header 6) 2)) - (or (markerp end) (setq end (set-marker (make-marker) end))) - (goto-char start) - (insert-buffer-substring work-buffer - data-fork-start (+ data-fork-start - (aref header 6))) - (delete-region (point) end))) + (if header-only nil + (binhex-verify-crc work-buffer + data-fork-start + (+ data-fork-start (aref header 6) 2)) + (or (markerp end) (setq end (set-marker (make-marker) end))) + (goto-char start) + (insert-buffer-substring work-buffer + data-fork-start (+ data-fork-start + (aref header 6))) + (delete-region (point) end))) (and work-buffer (kill-buffer work-buffer))) (if header (aref header 1)))) (defun binhex-decode-region-external (start end) - "Binhex decode region between START and END using external decoder" + "Binhex decode region between START and END using external decoder." (interactive "r") (let ((cbuf (current-buffer)) firstline work-buffer status (file-name (concat binhex-temporary-file-directory diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 2acd989..f0851c6 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -25,6 +25,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-cache) (require 'nnvirtual) @@ -77,6 +78,11 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'hook) +(defcustom gnus-agent-confirmation-function 'y-or-n-p + "Function to confirm when error happens." + :group 'gnus-agent + :type 'function) + (defcustom gnus-agent-large-newsgroup nil "*The number of articles which indicates a large newsgroup. If the number of unread articles exceeds it, The number of articles to be @@ -704,11 +710,15 @@ the actual number of articles toggled is returned." (save-excursion (set-buffer gnus-agent-current-history) (goto-char (point-max)) - (insert id "\t" (number-to-string date) "\t") - (while group-arts - (insert (caar group-arts) " " (number-to-string (cdr (pop group-arts))) - " ")) - (insert "\n"))) + (let ((p (point))) + (insert id "\t" (number-to-string date) "\t") + (while group-arts + (insert (format "%S" (intern (caar group-arts))) + " " (number-to-string (cdr (pop group-arts))) + " ")) + (insert "\n") + (while (search-backward "\\." p t) + (delete-char 1))))) (defun gnus-agent-article-in-history-p (id) (save-excursion @@ -737,7 +747,7 @@ the actual number of articles toggled is returned." ;; Prune off articles that we have already fetched. (while (and articles (cdr (assq (car articles) gnus-agent-article-alist))) - (pop articles)) + (pop articles)) (let ((arts articles)) (while (cdr arts) (if (cdr (assq (cadr arts) gnus-agent-article-alist)) @@ -758,7 +768,10 @@ the actual number of articles toggled is returned." (with-temp-buffer (let (article) (while (setq article (pop articles)) - (when (gnus-request-article article group) + (when (or + (gnus-backlog-request-article group article + nntp-server-buffer) + (gnus-request-article article group)) (goto-char (point-max)) (push (cons article (point)) pos) (insert-buffer-substring nntp-server-buffer))) @@ -816,7 +829,7 @@ the actual number of articles toggled is returned." (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" - group))) + group))) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors @@ -968,7 +981,8 @@ the actual number of articles toggled is returned." "Start Gnus and fetch session." (interactive) (gnus) - (gnus-agent-fetch-session) + (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) + (gnus-agent-fetch-session)) (gnus-group-exit)) (defun gnus-agent-fetch-session () @@ -982,14 +996,20 @@ the actual number of articles toggled is returned." groups group gnus-command-method) (save-excursion (while methods - (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) - (setq groups (gnus-groups-from-server (car methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (when (<= (gnus-group-level group) gnus-agent-handle-level) - (gnus-agent-fetch-group-1 group gnus-command-method))))) + (condition-case err + (progn + (setq gnus-command-method (car methods)) + (when (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (setq groups (gnus-groups-from-server (car methods))) + (gnus-agent-with-fetch + (while (setq group (pop groups)) + (when (<= (gnus-group-level group) gnus-agent-handle-level) + (gnus-agent-fetch-group-1 group gnus-command-method)))))) + (error + (unless (funcall gnus-agent-confirmation-function + (format "Error (%s). Continue? " err)) + (error "Cannot fetch articles into the Gnus agent.")))) (pop methods)) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) @@ -1018,7 +1038,7 @@ the actual number of articles toggled is returned." (gnus-get-newsgroup-headers-xover articles nil nil group))) ;; `gnus-agent-overview-buffer' may be killed for - ;; timeout reason. If so, recreate it. + ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer))) (setq category (gnus-group-category group)) (setq predicate @@ -1450,8 +1470,9 @@ The following commands are available: (forward-line 1) ;; Old article. Schedule it for possible nuking. (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb)) - (read (current-buffer)))) + (setq sym (let ((obarray expiry-hashtb) s) + (setq s (read (current-buffer))) + (if (stringp s) (intern s) s))) (if (boundp sym) (set sym (cons (cons (read (current-buffer)) (point)) (symbol-value sym))) diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index a44f97d..f7b5fff 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -194,7 +194,7 @@ the end of the buffer." :group 'gnus-article-signature) (defcustom gnus-signature-limit nil - "Provide a limit to what is considered a signature. + "Provide a limit to what is considered a signature. If it is a number, no signature may not be longer (in characters) than that number. If it is a floating point number, no signature may be longer (in lines) than that number. If it is a function, the function @@ -650,9 +650,9 @@ be added below it (otherwise)." "Function called with a MIME handle as the argument. This is meant for people who want to view first matched part. For `undisplayed-alternative' (default), the first undisplayed -part or alternative part is used. For `undisplayed', the first -undisplayed part is used. For a function, the first part which -the function return `t' is used. For `nil', the first part is +part or alternative part is used. For `undisplayed', the first +undisplayed part is used. For a function, the first part which +the function return `t' is used. For `nil', the first part is used." :group 'gnus-article-mime :type '(choice @@ -1570,39 +1570,39 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." "Decode charset-encoded text in the article. If PROMPT (the prefix), prompt for a coding system to use." (interactive "P") + (let ((inhibit-point-motion-hooks t) (case-fold-search t) + buffer-read-only + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case nil + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets)) + ct cte ctl charset) (save-excursion (save-restriction (article-narrow-to-head) - (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) - (ct (message-fetch-field "Content-Type" t)) - (cte (message-fetch-field "Content-Transfer-Encoding" t)) - (ctl (and ct (ignore-errors - (mail-header-parse-content-type ct)))) - (charset (cond - (prompt - (mm-read-coding-system "Charset to decode: ")) - (ctl - (mail-content-type-get ctl 'charset)))) - (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets - (save-excursion (condition-case nil - (set-buffer gnus-summary-buffer) - (error)) - gnus-newsgroup-ignored-charsets)) - buffer-read-only) - (if (and ctl (not (string-match "/" (car ctl)))) - (setq ctl nil)) - (goto-char (point-max)) - (widen) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (when (and (or (not ctl) - (equal (car ctl) "text/plain"))) - (mm-decode-body - charset (and cte (intern (downcase - (gnus-strip-whitespace cte)))) - (car ctl))))))) + (setq ct (message-fetch-field "Content-Type" t) + cte (message-fetch-field "Content-Transfer-Encoding" t) + ctl (and ct (ignore-errors + (mail-header-parse-content-type ct))) + charset (cond + (prompt + (mm-read-coding-system "Charset to decode: ")) + (ctl + (mail-content-type-get ctl 'charset)))) + (if (and ctl (not (string-match "/" (car ctl)))) + (setq ctl nil)) + (goto-char (point-max))) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (when (and (or (not ctl) + (equal (car ctl) "text/plain"))) + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ctl))))))) (defun article-decode-encoded-words () "Remove encoded-word encoding from headers." @@ -1631,9 +1631,20 @@ or not." (when charset (mm-decode-body charset))))))) +(eval-when-compile + (require 'rfc1843)) + +(defun article-decode-HZ () + "Translate a HZ-encoded article." + (interactive) + (require 'rfc1843) + (save-excursion + (let ((buffer-read-only nil)) + (rfc1843-decode-region (point-min) (point-max))))) + (defun article-hide-list-identifiers () - "Remove any list identifiers in `gnus-list-identifiers' from Subject -header in the current article." + "Remove list identifies from the Subject header. +The `gnus-list-identifiers' variable specifies what to do." (interactive) (save-excursion (save-restriction @@ -1987,7 +1998,7 @@ If HIDE, hide the text instead." (defun article-date-ut (&optional type highlight header) "Convert DATE date to universal time in the current article. If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE. For `lapsed', the value of +how much time has lapsed since DATE. For `lapsed', the value of `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header should replace the \"Date:\" one, or should be added below it." (interactive (list 'ut t)) @@ -2082,9 +2093,9 @@ should replace the \"Date:\" one, or should be added below it." (concat "Date: " (current-time-string (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) (cond ((< ls 0) (list (1- ms) (+ ls 65536))) ((> ls 65535) (list (1+ ms) (- ls 65536))) (t (list ms ls))))) @@ -2607,6 +2618,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-remove-cr article-display-x-face article-de-quoted-unreadable + article-decode-HZ article-hide-list-identifiers article-hide-pgp article-strip-banner @@ -2707,7 +2719,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] - ["Remove carriage return" gnus-article-remove-cr t])) + ["Remove carriage return" gnus-article-remove-cr t] + ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency @@ -2917,7 +2930,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-summary-mark-article article gnus-canceled-mark) (unless (memq article gnus-newsgroup-sparse) (gnus-error 1 - "No such article (may have expired or been canceled)"))))) + "No such article (may have expired or been canceled)"))))) (if (or (eq result 'pseudo) (eq result 'nneething)) (progn @@ -3210,7 +3223,8 @@ value of the variable `gnus-show-mime' is non-nil." (defun gnus-mime-view-part-as-type () "Choose a MIME media type, and view the part as such." (interactive - (list (completing-read "View as MIME type: " mailcap-mime-types))) + (list (completing-read "View as MIME type: " + (mapcar 'list (mailcap-mime-types))))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) (gnus-mm-display-part handle))) @@ -3333,7 +3347,7 @@ In no internal viewer is available, use an external viewer." ((eq condition 'undisplayed) (not (or (mm-handle-undisplayer (cdr ihandle)) (equal (mm-handle-media-type (cdr ihandle)) - "multipart/alternative")))) + "multipart/alternative")))) ((eq condition 'undisplayed-alternative) (not (mm-handle-undisplayer (cdr ihandle)))) (t t)) @@ -3484,7 +3498,7 @@ In no internal viewer is available, use an external viewer." ;; Top-level call; we clean up. (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) - (setq gnus-article-mime-handle-alist nil)) ;; A trick. + (setq gnus-article-mime-handle-alist nil));; A trick. (setq gnus-article-mime-handles handles) ;; We allow users to glean info from the handles. (when gnus-article-mime-part-function @@ -3505,13 +3519,13 @@ In no internal viewer is available, use an external viewer." (narrow-to-region (point) (point-max)) (gnus-treat-article nil 1 1) (widen))) - (if (not ihandles) - ;; Highlight the headers. - (save-excursion - (save-restriction - (article-goto-body) - (narrow-to-region (point-min) (point)) - (gnus-treat-article 'head)))))))) + (unless ihandles + ;; Highlight the headers. + (save-excursion + (save-restriction + (article-goto-body) + (narrow-to-region (point-min) (point)) + (gnus-treat-article 'head)))))))) (defvar gnus-mime-display-multipart-as-mixed nil) @@ -3575,11 +3589,11 @@ In no internal viewer is available, use an external viewer." (push (cons id handle) gnus-article-mime-handle-alist) (when (or (not display) (not (gnus-unbuttonized-mime-type-p type))) - (gnus-article-insert-newline) + ;(gnus-article-insert-newline) (gnus-insert-mime-button handle id (list (or display (and not-attachment text)))) (gnus-article-insert-newline) - (gnus-article-insert-newline) + ;(gnus-article-insert-newline) (setq move t))) (let ((beg (point))) (cond @@ -4034,8 +4048,7 @@ If given a prefix, show the hidden text instead." ;; We only request an article by message-id when we do not have the ;; headers for it, so we'll have to get those. (when (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) + (gnus-read-header article)) ;; If the article number is negative, that means that this article ;; doesn't belong in this newsgroup (possibly), so we find its @@ -4053,8 +4066,7 @@ If given a prefix, show the hidden text instead." ;; This is a sparse gap article. (setq do-update-line article) (setq article (mail-header-id header)) - (let ((gnus-override-method gnus-refer-article-method)) - (setq sparse-header (gnus-read-header article))) + (setq sparse-header (gnus-read-header article)) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -4106,20 +4118,35 @@ If given a prefix, show the hidden text instead." 'article) ;; Get the article and put into the article buffer. ((or (stringp article) (numberp article)) - (let ((gnus-override-method - (and (stringp article) gnus-refer-article-method)) + (let ((gnus-override-method gnus-override-method) + (methods (and (stringp article) + gnus-refer-article-method)) + result (buffer-read-only nil)) - (erase-buffer) - (gnus-kill-all-overlays) - (let ((gnus-newsgroup-name group)) - (gnus-check-group-server)) - (when (gnus-request-article article group (current-buffer)) - (when (numberp article) - (gnus-async-prefetch-next group article gnus-summary-buffer) - (when gnus-keep-backlog - (gnus-backlog-enter-article - group article (current-buffer)))) - 'article))) + (setq methods + (if (listp methods) + (delq 'current methods) + (list methods))) + (if (and (null gnus-override-method) methods) + (setq gnus-override-method (pop methods))) + (while (not result) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((gnus-newsgroup-name group)) + (gnus-check-group-server)) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article + gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + (setq result 'article)) + (if (not result) + (if methods + (setq gnus-override-method (pop methods)) + (setq result 'done)))) + (and (eq result 'article) 'article))) ;; It was a pseudo. (t article))) @@ -4426,7 +4453,7 @@ after replacing with the original article." ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... - ("]*\\)>" 0 t gnus-button-embedded-url 1) + ("]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. (,gnus-button-url-regexp 0 t browse-url 0)) "*Alist of regexps matching buttons in article bodies. @@ -5000,8 +5027,8 @@ forbidden in URL encoding." '(mail-decode-encoded-word-region) "List of methods used to decode headers. -This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is -FUNCTION, FUNCTION will be apply to all newsgroups. If item is a +This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item +is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups whose names match REGEXP. @@ -5019,13 +5046,13 @@ For example: (eq gnus-newsgroup-name (car gnus-decode-header-methods-cache))) (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) - (mapc '(lambda (x) - (if (symbolp x) - (nconc gnus-decode-header-methods-cache (list x)) - (if (and gnus-newsgroup-name - (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-header-methods-cache - (list (cdr x)))))) + (mapcar (lambda (x) + (if (symbolp x) + (nconc gnus-decode-header-methods-cache (list x)) + (if (and gnus-newsgroup-name + (string-match (car x) gnus-newsgroup-name)) + (nconc gnus-decode-header-methods-cache + (list (cdr x)))))) gnus-decode-header-methods)) (let ((xlist gnus-decode-header-methods-cache)) (pop xlist) diff --git a/lisp/gnus-async.el b/lisp/gnus-async.el index 0009e85..79063ed 100644 --- a/lisp/gnus-async.el +++ b/lisp/gnus-async.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) (require 'nntp) @@ -158,42 +159,42 @@ It should return non-nil if the article is to be prefetched." "Possibly prefetch several articles starting with ARTICLE." (if (not (gnus-buffer-live-p summary)) (gnus-async-with-semaphore - (setq gnus-async-fetch-list nil)) + (setq gnus-async-fetch-list nil)) (when (and gnus-asynchronous (gnus-alive-p)) (when next (gnus-async-with-semaphore - (pop gnus-async-fetch-list))) + (pop gnus-async-fetch-list))) (let ((do-fetch next) - (do-message t)) ;(eq major-mode 'gnus-summary-mode))) + (do-message t)) ;(eq major-mode 'gnus-summary-mode))) (when (and (gnus-group-asynchronous-p group) (gnus-buffer-live-p summary) (or (not next) gnus-async-fetch-list)) (gnus-async-with-semaphore - (unless next - (setq do-fetch (not gnus-async-fetch-list)) - ;; Nix out any outstanding requests. - (setq gnus-async-fetch-list nil) - ;; Fill in the new list. - (let ((n gnus-use-article-prefetch) - (data (gnus-data-find-list article)) - d) - (while (and (setq d (pop data)) - (if (numberp n) - (natnump (decf n)) - n)) - (unless (or (gnus-async-prefetched-article-entry - group (setq article (gnus-data-number d))) - (not (natnump article)) - (not (funcall gnus-async-prefetch-article-p d))) - ;; Not already fetched -- so we add it to the list. - (push article gnus-async-fetch-list))) - (setq gnus-async-fetch-list - (nreverse gnus-async-fetch-list)))) - - (when do-fetch - (setq article (car gnus-async-fetch-list)))) + (unless next + (setq do-fetch (not gnus-async-fetch-list)) + ;; Nix out any outstanding requests. + (setq gnus-async-fetch-list nil) + ;; Fill in the new list. + (let ((n gnus-use-article-prefetch) + (data (gnus-data-find-list article)) + d) + (while (and (setq d (pop data)) + (if (numberp n) + (natnump (decf n)) + n)) + (unless (or (gnus-async-prefetched-article-entry + group (setq article (gnus-data-number d))) + (not (natnump article)) + (not (funcall gnus-async-prefetch-article-p d))) + ;; Not already fetched -- so we add it to the list. + (push article gnus-async-fetch-list))) + (setq gnus-async-fetch-list + (nreverse gnus-async-fetch-list)))) + + (when do-fetch + (setq article (car gnus-async-fetch-list)))) (when (and do-fetch article) ;; We want to fetch some more articles. @@ -227,16 +228,16 @@ It should return non-nil if the article is to be prefetched." (when arg (gnus-async-set-buffer) (gnus-async-with-semaphore - (setq - gnus-async-article-alist - (cons (list (intern (format "%s-%d" group article) - gnus-async-hashtb) - mark (set-marker (make-marker) (point-max)) - group article) - gnus-async-article-alist)))) + (setq + gnus-async-article-alist + (cons (list (intern (format "%s-%d" group article) + gnus-async-hashtb) + mark (set-marker (make-marker) (point-max)) + group article) + gnus-async-article-alist)))) (if (not (gnus-buffer-live-p summary)) (gnus-async-with-semaphore - (setq gnus-async-fetch-list nil)) + (setq gnus-async-fetch-list nil)) (gnus-async-prefetch-article group next summary t)))) (defun gnus-async-unread-p (data) @@ -296,8 +297,8 @@ It should return non-nil if the article is to be prefetched." (set-marker (cadr entry) nil) (set-marker (caddr entry) nil)) (gnus-async-with-semaphore - (setq gnus-async-article-alist - (delq entry gnus-async-article-alist)))) + (setq gnus-async-article-alist + (delq entry gnus-async-article-alist)))) (defun gnus-async-prefetch-remove-group (group) "Remove all articles belonging to GROUP from the prefetch buffer." diff --git a/lisp/gnus-audio.el b/lisp/gnus-audio.el index f3bb686..e84c1df 100644 --- a/lisp/gnus-audio.el +++ b/lisp/gnus-audio.el @@ -47,37 +47,37 @@ "Executable program for playing WAV files.") ;;; The following isn't implemented yet. Wait for Millennium Gnus. -;(defvar gnus-audio-effects-enabled t -; "When t, Gnus will use sound effects.") -;(defvar gnus-audio-enable-hooks nil -; "Functions run when enabling sound effects.") -;(defvar gnus-audio-disable-hooks nil -; "Functions run when disabling sound effects.") -;(defvar gnus-audio-theme-song nil -; "Theme song for Gnus.") -;(defvar gnus-audio-enter-group nil -; "Sound effect played when selecting a group.") -;(defvar gnus-audio-exit-group nil -; "Sound effect played when exiting a group.") -;(defvar gnus-audio-score-group nil -; "Sound effect played when scoring a group.") -;(defvar gnus-audio-busy-sound nil -; "Sound effect played when going into a ... sequence.") +;;(defvar gnus-audio-effects-enabled t +;; "When t, Gnus will use sound effects.") +;;(defvar gnus-audio-enable-hooks nil +;; "Functions run when enabling sound effects.") +;;(defvar gnus-audio-disable-hooks nil +;; "Functions run when disabling sound effects.") +;;(defvar gnus-audio-theme-song nil +;; "Theme song for Gnus.") +;;(defvar gnus-audio-enter-group nil +;; "Sound effect played when selecting a group.") +;;(defvar gnus-audio-exit-group nil +;; "Sound effect played when exiting a group.") +;;(defvar gnus-audio-score-group nil +;; "Sound effect played when scoring a group.") +;;(defvar gnus-audio-busy-sound nil +;; "Sound effect played when going into a ... sequence.") ;;;###autoload - ;(defun gnus-audio-enable-sound () -; "Enable Sound Effects for Gnus." -; (interactive) -; (setq gnus-audio-effects-enabled t) -; (gnus-run-hooks gnus-audio-enable-hooks)) +;;(defun gnus-audio-enable-sound () +;; "Enable Sound Effects for Gnus." +;; (interactive) +;; (setq gnus-audio-effects-enabled t) +;; (gnus-run-hooks gnus-audio-enable-hooks)) ;;;###autoload ;(defun gnus-audio-disable-sound () -; "Disable Sound Effects for Gnus." -; (interactive) -; (setq gnus-audio-effects-enabled nil) -; (gnus-run-hooks gnus-audio-disable-hooks)) +;; "Disable Sound Effects for Gnus." +;; (interactive) +;; (setq gnus-audio-effects-enabled nil) +;; (gnus-run-hooks gnus-audio-disable-hooks)) ;;;###autoload (defun gnus-audio-play (file) @@ -104,16 +104,16 @@ ;;; The following isn't implemented yet, wait for Red Gnus - ;(defun gnus-audio-startrek-sounds () -; "Enable sounds from Star Trek the original series." -; (interactive) -; (setq gnus-audio-busy-sound "working.au") -; (setq gnus-audio-enter-group "bulkhead_door.au") -; (setq gnus-audio-exit-group "bulkhead_door.au") -; (setq gnus-audio-score-group "ST_laser.au") -; (setq gnus-audio-theme-song "startrek.au") -; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group) -; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group)) +;;(defun gnus-audio-startrek-sounds () +;; "Enable sounds from Star Trek the original series." +;; (interactive) +;; (setq gnus-audio-busy-sound "working.au") +;; (setq gnus-audio-enter-group "bulkhead_door.au") +;; (setq gnus-audio-exit-group "bulkhead_door.au") +;; (setq gnus-audio-score-group "ST_laser.au") +;; (setq gnus-audio-theme-song "startrek.au") +;; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group) +;; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group)) ;;;*** (defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au" diff --git a/lisp/gnus-bcklg.el b/lisp/gnus-bcklg.el index a47a199..701cf38 100644 --- a/lisp/gnus-bcklg.el +++ b/lisp/gnus-bcklg.el @@ -126,7 +126,7 @@ t)) (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) -(defun gnus-backlog-request-article (group number buffer) +(defun gnus-backlog-request-article (group number &optional buffer) (when (numberp number) (gnus-backlog-setup) (let ((ident (intern (concat group ":" (int-to-string number)) @@ -146,10 +146,12 @@ (setq end (next-single-property-change (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-buffer-substring gnus-backlog-buffer beg end) - t))))) + (save-excursion + (and buffer (set-buffer buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-buffer-substring gnus-backlog-buffer beg end))) + t)))) (provide 'gnus-bcklg) diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index 2f715a8..3c6ae42 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -62,7 +62,7 @@ If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups it's not cached." :group 'gnus-cache :type '(choice (const :tag "off" nil) - regexp)) + regexp)) (defcustom gnus-uncacheable-groups nil "*Groups that match this regexp will not be cached. diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el index 33ff4fd..93cb0c3 100644 --- a/lisp/gnus-cite.el +++ b/lisp/gnus-cite.el @@ -21,6 +21,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'gnus-range) @@ -43,10 +44,10 @@ article has citations." :type 'string) (defcustom gnus-cite-always-check nil - "Check article always for citations. Set it t to check all articles." + "Check article always for citations. Set it t to check all articles." :group 'gnus-cite :type '(choice (const :tag "no" nil) - (const :tag "yes" t))) + (const :tag "yes" t))) (defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n" "Format of opened cited text buttons." @@ -239,8 +240,8 @@ It is merged with the face for the cited text belonging to the attribution." (defcustom gnus-cite-face-list '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4 - gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 - gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11) + gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 + gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11) "*List of faces used for highlighting citations. When there are citations from multiple articles in the same message, @@ -526,17 +527,19 @@ always hide." (defun gnus-article-toggle-cited-text (args) "Toggle hiding the text in REGION." (let* ((region (car args)) + (beg (car region)) + (end (cdr region)) (start (cadr args)) (hidden (text-property-any - (car region) (1- (cdr region)) + beg (1- end) (car gnus-hidden-properties) (cadr gnus-hidden-properties))) (inhibit-point-motion-hooks t) buffer-read-only) (funcall (if hidden 'remove-text-properties 'gnus-add-text-properties) - (car region) (cdr region) gnus-hidden-properties) + beg end gnus-hidden-properties) (save-excursion (goto-char start) (gnus-delete-line) @@ -970,4 +973,8 @@ See also the documentation for `gnus-article-highlight-citation'." (provide 'gnus-cite) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; gnus-cite.el ends here diff --git a/lisp/gnus-cus.el b/lisp/gnus-cus.el index 995d6b4..92baaca 100644 --- a/lisp/gnus-cus.el +++ b/lisp/gnus-cus.el @@ -147,7 +147,7 @@ All posts will be send to the specified group.") Specify default value for GCC header. If this symbol is present in the group parameter list and set to `t', -new composed messages will be `Gcc''d to the current group. If it is +new composed messages will be `Gcc''d to the current group. If it is present and set to `none', no `Gcc:' header will be generated, if it is present and a string, this string will be inserted literally as a `gcc' header (this symbol takes precedence over any default `Gcc' @@ -155,7 +155,8 @@ rules as described later).") (banner (choice :tag "Banner" (const signature) - string ) "\ + string + (const :tag "None" nil)) "\ Banner to be removed from articles.") (auto-expire (const :tag "Automatic Expire" t) "\ @@ -176,7 +177,7 @@ Use with caution.") When to expire. Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function' -when expiring expirable messages. The value can either be a number of +when expiring expirable messages. The value can either be a number of days (not necessarily an integer) or the symbols `never' or `immediate'.") @@ -236,7 +237,7 @@ default charset will be used instead.") (number :tag "Group for displayed part" 0) (symbol :tag "Face" gnus-emphasis-highlight-words)))) - "highlight regexps. + "highlight regexps. See gnus-emphasis-alist.")) "Alist of valid group or topic parameters. @@ -342,10 +343,10 @@ like. If you want to hear a beep when you enter a group, you could put something like `(dummy-variable (ding))' in the parameters of that group. `dummy-variable' will be set to the result of the `(ding)' form, but who cares?" - (cons :format "%v" :value (nil . nil) - (symbol :tag "Variable") - (sexp :tag - "Value"))) + (list :format "%v" :value (nil nil) + (symbol :tag "Variable") + (sexp :tag + "Value"))) '(repeat :inline t :tag "Unknown entries" @@ -490,9 +491,9 @@ documentation string for the parameter.") (item `(const :format "" :value ,(downcase tag))) (match '(string :tag "Match")) (score '(choice :tag "Score" - (const :tag "default" nil) - (integer :format "%v" - :hide-front-space t))) + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) (expire '(choice :tag "Expire" (const :tag "off" nil) (integer :format "%v" @@ -563,9 +564,9 @@ each score entry has four elements: (item `(const :format "" :value ,(downcase tag))) (match '(integer :tag "Match")) (score '(choice :tag "Score" - (const :tag "default" nil) - (integer :format "%v" - :hide-front-space t))) + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) (expire '(choice :tag "Expire" (const :tag "off" nil) (integer :format "%v" @@ -600,9 +601,9 @@ each score entry has four elements: (item `(const :format "" :value ,(downcase tag))) (match '(string :tag "Match")) (score '(choice :tag "Score" - (const :tag "default" nil) - (integer :format "%v" - :hide-front-space t))) + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) (expire '(choice :tag "Expire" (const :tag "off" nil) (integer :format "%v" @@ -652,11 +653,11 @@ eh?"))) (interactive (list gnus-current-score-file)) (let ((scores (gnus-score-load file)) (types (mapcar (lambda (entry) - `(group :format "%v%h\n" - :doc ,(nth 2 entry) - (const :format "" ,(nth 0 entry)) - ,(nth 1 entry))) - gnus-score-parameters))) + `(group :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,(nth 1 entry))) + gnus-score-parameters))) ;; Ready. (kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) diff --git a/lisp/gnus-demon.el b/lisp/gnus-demon.el index 7c1fa49..e3704d0 100644 --- a/lisp/gnus-demon.el +++ b/lisp/gnus-demon.el @@ -159,7 +159,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." thenMin thenHour ;; If THEN is earlier than NOW, make it - ;; same time tomorrow. Doc for encode-time + ;; same time tomorrow. Doc for encode-time ;; says that this is OK. (+ (elt nowParts 3) (if (or (< thenHour (elt nowParts 2)) @@ -258,7 +258,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." "Add daemonic nntp server disconnection to Gnus. If no commands have gone out via nntp during the last five minutes, the connection is closed." - (gnus-demon-add-handler 'gnus-demon-close-connections 5 nil)) + (gnus-demon-add-handler 'gnus-demon-nntp-close-connections 5 nil)) (defun gnus-demon-nntp-close-connection () (save-window-excursion diff --git a/lisp/gnus-draft.el b/lisp/gnus-draft.el index b0df871..3e6def0 100644 --- a/lisp/gnus-draft.el +++ b/lisp/gnus-draft.el @@ -69,8 +69,8 @@ (interactive "P") (when (eq major-mode 'gnus-summary-mode) (when (set (make-local-variable 'gnus-draft-mode) - (if (null arg) (not gnus-draft-mode) - (> (prefix-numeric-value arg) 0))) + (if (null arg) (not gnus-draft-mode) + (> (prefix-numeric-value arg) 0))) ;; Set up the menu. (when (gnus-visual-p 'draft-menu 'menu) (gnus-draft-make-menu-bar)) diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el index 84dff68..acbac35 100644 --- a/lisp/gnus-ems.el +++ b/lisp/gnus-ems.el @@ -99,8 +99,9 @@ (symbol-name system-type)) (setq nnheader-file-name-translation-alist (append nnheader-file-name-translation-alist - '((?: . ?_) - (?+ . ?-)))))))) + (mapcar (lambda (c) (cons c ?_)) + '(?: ?* ?\" ?< ?> ??)) + '((?+ . ?-)))))))) (defvar gnus-tmp-unread) (defvar gnus-tmp-replied) @@ -122,7 +123,7 @@ ;; [Note] Now there are three kinds of mule implementations, ;; original MULE, XEmacs/mule and beta version of Emacs including - ;; some mule features. Unfortunately these API are different. In + ;; some mule features. Unfortunately these API are different. In ;; particular, Emacs (including original MULE) and XEmacs are ;; quite different. ;; Predicates to check are following: @@ -131,9 +132,9 @@ ;; (featurep 'mule) is t when every mule variants are running. ;; These implementations may be able to share between original - ;; MULE and beta version of new Emacs. In addition, it is able to + ;; MULE and beta version of new Emacs. In addition, it is able to ;; detect XEmacs/mule by (featurep 'mule) and to check variable - ;; `emacs-version'. In this case, implementation for XEmacs/mule + ;; `emacs-version'. In this case, implementation for XEmacs/mule ;; may be able to share between XEmacs and XEmacs/mule. (defvar gnus-summary-display-table nil diff --git a/lisp/gnus-gl.el b/lisp/gnus-gl.el index 3263e60..68e18c7 100644 --- a/lisp/gnus-gl.el +++ b/lisp/gnus-gl.el @@ -137,10 +137,10 @@ This pseudonym is obtained during the registration process") (defvar grouplens-bbb-host "grouplens.cs.umn.edu" - "Host where the bbbd is running" ) + "Host where the bbbd is running.") (defvar grouplens-bbb-port 9000 - "Port where the bbbd is listening" ) + "Port where the bbbd is listening.") (defvar grouplens-newsgroups '("comp.groupware" "comp.human-factors" "comp.lang.c++" @@ -194,19 +194,19 @@ GroupLens scores can be combined with gnus scores in one of three ways. ;;;; Program global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar grouplens-bbb-token nil - "Current session token number") + "Current session token number.") (defvar grouplens-bbb-process nil - "Process Id of current bbbd network stream process") + "Process Id of current bbbd network stream process.") (defvar grouplens-bbb-buffer nil - "Buffer associated with the BBBD process") + "Buffer associated with the BBBD process.") (defvar grouplens-rating-alist nil - "Current set of message-id rating pairs") + "Current set of message-id rating pairs.") (defvar grouplens-current-hashtable nil - "A hashtable to hold predictions from the BBB") + "A hashtable to hold predictions from the BBB.") (defvar grouplens-current-group nil) @@ -313,7 +313,7 @@ If this times out we give up and assume that something has died..." ) (concat "login " grouplens-pseudonym)) (if (bbb-read-response bbb-process) (setq grouplens-bbb-token (bbb-extract-token-number)) - (gnus-message 3 "Error: GroupLens login failed"))))) + (gnus-message 3 "Error: GroupLens login failed"))))) (gnus-message 3 "Error: you must set a pseudonym")) grouplens-bbb-token) @@ -407,7 +407,7 @@ recommend using both scores and grouplens predictions together." pred (bbb-get-pred)) (push `(,mid ,pred nil s) resp) (gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh)) - grouplens-current-hashtable) + grouplens-current-hashtable) (forward-line 1) t) ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)") @@ -780,12 +780,12 @@ If prefix argument ALL is non-nil, all articles are marked as read." (unless gnus-grouplens-mode-map (setq gnus-grouplens-mode-map (make-keymap)) (gnus-define-keys - gnus-grouplens-mode-map - "n" grouplens-next-unread-article - "r" bbb-summary-rate-article - "k" grouplens-score-thread - "c" grouplens-summary-catchup-and-exit - "," grouplens-best-unread-article)) + gnus-grouplens-mode-map + "n" grouplens-next-unread-article + "r" bbb-summary-rate-article + "k" grouplens-score-thread + "c" grouplens-summary-catchup-and-exit + "," grouplens-best-unread-article)) (defun gnus-grouplens-make-menu-bar () (unless (boundp 'gnus-grouplens-menu) diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 17b58fe..9d7f92d 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-start) (require 'nnmail) @@ -331,7 +332,7 @@ variable." ((= unread 0) . gnus-group-mail-low-empty-face) (t . - gnus-group-mail-low-face)) + gnus-group-mail-low-face)) "*Controls the highlighting of group buffer lines. Below is a list of `Form'/`Face' pairs. When deciding how a a @@ -932,7 +933,7 @@ If REGEXP, only list groups matching REGEXP." params (gnus-info-params info) newsrc (cdr newsrc) unread (car (gnus-gethash group gnus-newsrc-hashtb))) - (and unread ; This group might be bogus + (and unread ; This group might be unchecked (or (not regexp) (string-match regexp group)) (<= (setq clevel (gnus-info-level info)) level) @@ -1579,7 +1580,7 @@ be permanent." (defun gnus-fetch-group (group) "Start Gnus if necessary and enter GROUP. Returns whether the fetching was successful or not." - (interactive "sGroup name: ") + (interactive (list (completing-read "Group name: " gnus-active-hashtb))) (unless (get-buffer gnus-group-buffer) (gnus-no-server)) (gnus-group-read-group nil nil group)) @@ -1858,8 +1859,20 @@ ADDRESS." (gnus-request-create-group nname nil args)) t)) -(defun gnus-group-delete-group (group &optional force) - "Delete the current group. Only meaningful with mail groups. +(defun gnus-group-delete-groups (&optional arg) + "Delete the current group. Only meaningful with editable groups." + (interactive "P") + (let ((n (length (gnus-group-process-prefix arg)))) + (when (gnus-yes-or-no-p + (if (= n 1) + "Delete this 1 group? " + (format "Delete these %d groups? " n))) + (gnus-group-iterate arg + (lambda (group) + (gnus-group-delete-group group nil t)))))) + +(defun gnus-group-delete-group (group &optional force no-prompt) + "Delete the current group. Only meaningful with editable groups. If FORCE (the prefix) is non-nil, all the articles in the group will be deleted. This is \"deleted\" as in \"removed forever from the face of the Earth\". There is no undo. The user will be prompted before @@ -1872,10 +1885,11 @@ doing the deletion." (unless (gnus-check-backend-function 'request-delete-group group) (error "This backend does not support group deletion")) (prog1 - (if (not (gnus-yes-or-no-p - (format - "Do you really want to delete %s%s? " - group (if force " and all its contents" "")))) + (if (and (not no-prompt) + (not (gnus-yes-or-no-p + (format + "Do you really want to delete %s%s? " + group (if force " and all its contents" ""))))) () ; Whew! (gnus-message 6 "Deleting group %s..." group) (if (not (gnus-request-delete-group group force)) @@ -2295,12 +2309,12 @@ score file entries for articles to include in the group." An access control list is a list of (identifier . rights) elements. - The identifier string specifies the corresponding user. The + The identifier string specifies the corresponding user. The identifier \"anyone\" is reserved to refer to the universal identity. Rights is a string listing a (possibly empty) set of alphanumeric characters, each character listing a set of operations which is being - controlled. Letters are reserved for ``standard'' rights, listed + controlled. Letters are reserved for ``standard'' rights, listed below. Digits are reserved for implementation or site defined rights. l - lookup (mailbox is visible to LIST/LSUB commands) @@ -2572,8 +2586,7 @@ up is returned." (when (eq 'nnvirtual (car method)) (nnvirtual-catchup-group (gnus-group-real-name group) (nth 1 method) all))) - (if (>= (gnus-info-level (gnus-get-info group)) - gnus-level-zombie) + (if (>= (gnus-group-level group) gnus-level-zombie) (gnus-message 2 "Dead groups can't be caught up") (if (prog1 (gnus-group-goto-group group) @@ -2972,7 +2985,7 @@ entail asking the server for the groups." ;; First we make sure that we have really read the active file. (unless (gnus-read-active-file-p) (let ((gnus-read-active-file t) - (gnus-agent nil)) ; Trick the agent into ignoring the active file. + (gnus-agent nil)) ; Trick the agent into ignoring the active file. (gnus-read-active-file))) ;; Find all groups and sort them. (let ((groups @@ -3057,7 +3070,12 @@ If N is negative, this group and the N-1 previous groups will be checked." (ret (if (numberp n) (- n (length groups)) 0)) (beg (unless n (point))) - group method) + group method + (gnus-inhibit-demon t) + ;; Binding this variable will inhibit multiple fetchings + ;; of the same mail source. + (nnmail-fetched-sources (list t))) + (gnus-run-hooks 'gnus-get-new-news-hook) (while (setq group (pop groups)) (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. @@ -3464,19 +3482,19 @@ and the second element is the address." (or (not info) (and (not (setq marked (nthcdr 3 info))) (or (null articles) - (setcdr (nthcdr 2 info) - (list (list (cons type (gnus-compress-sequence - articles t))))))) + (setcdr (nthcdr 2 info) + (list (list (cons type (gnus-compress-sequence + articles t))))))) (and (not (setq m (assq type (car marked)))) (or (null articles) - (setcar marked - (cons (cons type (gnus-compress-sequence articles t) ) - (car marked))))) + (setcar marked + (cons (cons type (gnus-compress-sequence articles t) ) + (car marked))))) (if force (if (null articles) - (setcar (nthcdr 3 info) - (gnus-delete-alist type (car marked))) - (setcdr m (gnus-compress-sequence articles t))) + (setcar (nthcdr 3 info) + (gnus-delete-alist type (car marked))) + (setcdr m (gnus-compress-sequence articles t))) (setcdr m (gnus-compress-sequence (sort (nconc (gnus-uncompress-range (cdr m)) (copy-sequence articles)) '<) t)))))) @@ -3501,7 +3519,7 @@ or `gnus-group-catchup-group-hook'." (defun gnus-group-timestamp-delta (group) "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." (let* ((time (or (gnus-group-timestamp group) - (list 0 0))) + (list 0 0))) (delta (subtract-time (current-time) time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el index 1d04718..c5dbd2f 100644 --- a/lisp/gnus-kill.el +++ b/lisp/gnus-kill.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'gnus-range) @@ -48,7 +49,8 @@ :type 'boolean) (defcustom gnus-winconf-kill-file nil - "What does this do, Lars?" + "What does this do, Lars? +I don't know, Per." :group 'gnus-score-kill :type 'sexp) diff --git a/lisp/gnus-load.el b/lisp/gnus-load.el index f89f95e..53784fb 100644 --- a/lisp/gnus-load.el +++ b/lisp/gnus-load.el @@ -37,7 +37,7 @@ (put 'gnus-cite 'custom-loads '("gnus-cite")) (put 'gnus-demon 'custom-loads '("gnus-demon")) (put 'gnus-message 'custom-loads '("message")) -(put 'gnus-score-default 'custom-loads '("gnus-sum" "gnus-score")) +(put 'gnus-score-delta-default 'custom-loads '("gnus-sum" "gnus-score")) (put 'nnmail-duplicate 'custom-loads '("nnmail")) (put 'message-interface 'custom-loads '("message")) (put 'nnmail-files 'custom-loads '("nnmail")) diff --git a/lisp/gnus-logic.el b/lisp/gnus-logic.el index c40f49e..0b14ce0 100644 --- a/lisp/gnus-logic.el +++ b/lisp/gnus-logic.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-score) (require 'gnus-util) diff --git a/lisp/gnus-mailcap.el b/lisp/gnus-mailcap.el index dd2b499..932fcb6 100644 --- a/lisp/gnus-mailcap.el +++ b/lisp/gnus-mailcap.el @@ -28,6 +28,7 @@ (eval-when-compile (require 'cl)) (require 'mail-parse) +(require 'mm-util) (defvar mailcap-parse-args-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) @@ -119,12 +120,6 @@ (viewer . "maplay %s") (type . "audio/x-mpeg")) (".*" - (viewer . mailcap-save-binary-file) - (non-viewer . t) - (test . (or (featurep 'nas-sound) - (featurep 'native-sound))) - (type . "audio/*")) - (".*" (viewer . "showaudio") (type . "audio/*"))) ("message" @@ -218,7 +213,7 @@ (viewer . tar-mode) (type . "archive/tar") (test . (fboundp 'tar-mode))))) - "The mailcap structure is an assoc list of assoc lists. + "The mailcap structure is an assoc list of assoc lists. 1st assoc list is keyed on the major content-type 2nd assoc list is keyed on the minor content-type (which can be a regexp) @@ -260,7 +255,7 @@ not.") ;;; (defun mailcap-generate-unique-filename (&optional fmt) - "Generate a unique filename in mailcap-temporary-directory" + "Generate a unique filename in mailcap-temporary-directory." (if (not fmt) (let ((base (format "mailcap-tmp.%d" (user-real-uid))) (fname "") @@ -292,7 +287,7 @@ not.") (kill-buffer (current-buffer)))) (defun mailcap-maybe-eval () - "Maybe evaluate a buffer of emacs lisp code" + "Maybe evaluate a buffer of emacs lisp code." (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ") (eval-buffer (current-buffer)) (emacs-lisp-mode))) @@ -335,8 +330,8 @@ If FORCE, re-parse even if already parsed." fname) (while fnames (setq fname (car fnames)) - (if (and (file-exists-p fname) (file-readable-p fname) - (file-regular-p fname)) + (if (and (file-exists-p fname) (file-readable-p fname) + (file-regular-p fname)) (mailcap-parse-mailcap (car fnames))) (setq fnames (cdr fnames)))) (setq mailcap-parsed-p t))) @@ -600,7 +595,7 @@ If FORCE, re-parse even if already parsed." ((or (null cur-minor) ; New minor area, or (assq 'test info)) ; Has a test, insert at beginning (setcdr old-major (cons (cons minor info) (cdr old-major)))) - ((and (not (assq 'test info)) ; No test info, replace completely + ((and (not (assq 'test info)) ; No test info, replace completely (not (assq 'test cur-minor))) (setcdr cur-minor info)) (t @@ -693,7 +688,7 @@ this type is returned." passed) (t ;; MUST make a copy *sigh*, else we modify mailcap-mime-data - (setq viewer (copy-tree viewer)) + (setq viewer (copy-sequence viewer)) (let ((view (assq 'viewer viewer)) (test (assq 'test viewer))) (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info))) @@ -887,7 +882,7 @@ The path of COMMAND will be returned iff COMMAND is a command." (defun mailcap-mime-types () "Return a list of MIME media types." - (delete-duplicates (mapcar 'cdr mailcap-mime-extensions))) + (mm-delete-duplicates (mapcar 'cdr mailcap-mime-extensions))) (provide 'gnus-mailcap) diff --git a/lisp/gnus-mh.el b/lisp/gnus-mh.el index 6fabb5c..665e361 100644 --- a/lisp/gnus-mh.el +++ b/lisp/gnus-mh.el @@ -67,7 +67,7 @@ Optional argument FOLDER specifies folder name." (errbuf (gnus-get-buffer-create " *Gnus rcvstore*")) ;; Find the rcvstore program. (exec-path (if mh-lib (cons mh-lib exec-path) exec-path))) - (gnus-eval-in-buffer-window gnus-original-article-buffer + (with-current-buffer gnus-original-article-buffer (save-restriction (widen) (unwind-protect diff --git a/lisp/gnus-mlspl.el b/lisp/gnus-mlspl.el index e305b88..6c3ed8f 100644 --- a/lisp/gnus-mlspl.el +++ b/lisp/gnus-mlspl.el @@ -20,22 +20,22 @@ ;; Boston, MA 02111-1307, USA. (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) (require 'gnus-group) (require 'nnmail) (defvar gnus-group-split-updated-hook nil - "Hook called just after nnmail-split-fancy is updated by -gnus-group-split-update") + "Hook called just after nnmail-split-fancy is updated by gnus-group-split-update.") (defvar gnus-group-split-default-catch-all-group "mail.misc" - "Group used by gnus-group-split and gnus-group-split-update as -default catch-all group") + "Group used by gnus-group-split and gnus-group-split-update as default catch-all group.") ;;;###autoload (defun gnus-group-split-setup (&optional auto-update catch-all) - "Sets things up so that nnmail-split-fancy is used for mail + "Set up the split for nnmail-split-fancy. +Sets things up so that nnmail-split-fancy is used for mail splitting, and defines the variable nnmail-split-fancy according with group parameters. @@ -53,19 +53,18 @@ nnmail-pre-get-new-mail-hook." ;;;###autoload (defun gnus-group-split-update (&optional catch-all) - "Computes nnmail-split-fancy from group params, by calling -\(gnus-group-split-fancy nil nil DEFAULTGROUP)" + "Computes nnmail-split-fancy from group params. +It does this by calling \(gnus-group-split-fancy nil nil DEFAULTGROUP)." (interactive) (setq nnmail-split-fancy (gnus-group-split-fancy nil nil (or catch-all gnus-group-split-default-catch-all-group))) - (run-hooks 'gnus-group-split-updated-hook) - ) + (run-hooks 'gnus-group-split-updated-hook)) ;;;###autoload (defun gnus-group-split () - "Uses information from group parameters in order to split mail. See -gnus-group-split-fancy for more information. + "Uses information from group parameters in order to split mail. +See gnus-group-split-fancy for more information. If no group is defined as catch-all, the value of gnus-group-split-default-catch-all-group is used. diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index b16b12d..956f7c2 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -49,8 +49,8 @@ This method will not be used in mail groups and the like, only in \"real\" newsgroups. If not nil nor `native', the value must be a valid method as discussed -in the documentation of `gnus-select-method'. It can also be a list of -methods. If that is the case, the user will be queried for what select +in the documentation of `gnus-select-method'. It can also be a list of +methods. If that is the case, the user will be queried for what select method to use when posting." :group 'gnus-group-foreign :type `(choice (const nil) @@ -106,14 +106,34 @@ the second with the current group name.") "*Alist of styles to use when posting.") (defcustom gnus-group-posting-charset-alist - '(("^no\\." iso-8859-1) - (message-this-is-mail nil) - ("^de\\." nil) - (".*" iso-8859-1) - (message-this-is-news iso-8859-1)) - "Alist of regexps (to match group names) and default charsets to be unencoded when posting." - :type '(repeat (list (regexp :tag "Group") - (symbol :tag "Charset"))) + '(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1)) + (message-this-is-mail nil nil) + (message-this-is-news nil t)) + "Alist of regexps and permitted unencoded charsets for posting. +Each element of the alist has the form (TEST HEADER BODY-LIST), where +TEST is either a regular expression matching the newsgroup header or a +variable to query, +HEADER is the charset which may be left unencoded in the header (nil +means encode all charsets), +BODY-LIST is a list of charsets which may be encoded using 8bit +content-transfer encoding in the body, or one of the special values +nil (always encode using quoted-printable) or t (always use 8bit). + +Note that any value other tha nil for HEADER infringes some RFCs, so +use this option with care." + :type '(repeat (list :tag "Permitted unencoded charsets" + (choice :tag "Where" + (regexp :tag "Group") + (const :tag "Mail message" :value message-this-is-mail) + (const :tag "News article" :value message-this-is-news)) + (choice :tag "Header" + (const :tag "None" nil) + (symbol :tag "Charset")) + (choice :tag "Body" + (const :tag "Any" :value t) + (const :tag "None" :value nil) + (repeat :tag "Charsets" + (symbol :tag "Charset"))))) :group 'gnus-charset) ;;; Internal variables. @@ -225,8 +245,6 @@ Thank you for your help in stamping out bugs. (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) (set (make-local-variable 'gnus-newsgroup-name) ,group) - (set (make-local-variable 'message-posting-charset) - (gnus-setup-posting-charset ,group)) (gnus-run-hooks 'gnus-message-setup-hook)) (gnus-add-buffer) (gnus-configure-windows ,config t) @@ -245,7 +263,7 @@ Thank you for your help in stamping out bugs. (funcall (car elem) group)) (and (symbolp (car elem)) (symbol-value (car elem)))) - (throw 'found (cadr elem)))))))) + (throw 'found (cons (cadr elem) (caddr elem))))))))) (defun gnus-inews-add-send-actions (winconf buffer article) (make-local-hook 'message-sent-hook) @@ -563,7 +581,7 @@ If SILENT, don't prompt the user." ;; the default method. ((null group-method) (or (and (null (eq gnus-post-method 'active)) gnus-post-method) - gnus-select-method message-post-method)) + gnus-select-method message-post-method)) ;; We want the inverse of the default ((and arg (not (eq arg 0))) (if (eq gnus-post-method 'active) diff --git a/lisp/gnus-nocem.el b/lisp/gnus-nocem.el index 7e8a862..8efd1fe 100644 --- a/lisp/gnus-nocem.el +++ b/lisp/gnus-nocem.el @@ -50,8 +50,7 @@ "clewis@ferret.ocunix.on.ca" ; Chris Lewis "jem@xpat.com" ; Despammer from Korea "snowhare@xmission.com" ; Benjamin "Snowhare" Franz - "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM! - ) + "red@redpoll.mrfs.oh.us (Richard E. Depew)") ; ARMM! ARMM! "*List of NoCeM issuers to pay attention to. This can also be a list of `(ISSUER CONDITIONS)' elements." diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index 867d004..e527523 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) ;; (require 'xpm) (require 'annotations) @@ -524,8 +525,8 @@ none, and whose CDR is the corresponding element of DOMAINS." (defun gnus-picons-parse-value (name) (goto-char (point-min)) (if (re-search-forward (concat "" - (regexp-quote name) - " *= * *\\([^ <][^<]*\\) *") + (regexp-quote name) + " *= * *\\([^ <][^<]*\\) *") nil t) (buffer-substring (match-beginning 1) (match-end 1)))) @@ -696,8 +697,8 @@ none, and whose CDR is the corresponding element of DOMAINS." (defun gnus-picons-network-search (user addrs dbs sym-ann right-p marker) (let* ((host (mapconcat 'identity addrs ".")) (key (list (or user "unknown") host (if user - gnus-picons-user-directories - dbs))) + gnus-picons-user-directories + dbs))) (cache (assoc key gnus-picons-url-alist))) (if (null cache) (gnus-picons-url-retrieve diff --git a/lisp/gnus-range.el b/lisp/gnus-range.el index 1964880..5e0dc13 100644 --- a/lisp/gnus-range.el +++ b/lisp/gnus-range.el @@ -225,19 +225,19 @@ Note: LIST has to be sorted over `<'." out))) (defun gnus-remove-from-range (range1 range2) - "Return a range that has all articles from RANGE2 removed from -RANGE1. The returned range is always a list. RANGE2 can also be a -unsorted list of articles. RANGE1 is modified by side effects, RANGE2 -is not modified." + "Return a range that has all articles from RANGE2 removed from RANGE1. +The returned range is always a list. RANGE2 can also be a unsorted +list of articles. RANGE1 is modified by side effects, RANGE2 is not +modified." (if (or (null range1) (null range2)) range1 (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (gnus-copy-sequence range2))) + (range2 (gnus-copy-sequence range2))) (setq range1 (if (listp (cdr range1)) range1 (list range1)) - range2 (sort (if (listp (cdr range2)) range2 (list range2)) - (lambda (e1 e2) - (< (if (consp e1) (car e1) e1) - (if (consp e2) (car e2) e2)))) + range2 (sort (if (listp (cdr range2)) range2 (list range2)) + (lambda (e1 e2) + (< (if (consp e1) (car e1) e1) + (if (consp e2) (car e2) e2)))) r1 (car range1) r2 (car range2) r1_min (if (consp r1) (car r1) r1) @@ -245,7 +245,7 @@ is not modified." r2_min (if (consp r2) (car r2) r2) r2_max (if (consp r2) (cdr r2) r2)) (while (and range1 range2) - (cond ((< r2_max r1_min) ; r2 < r1 + (cond ((< r2_max r1_min) ; r2 < r1 (pop range2) (setq r2 (car range2) r2_min (if (consp r2) (car r2) r2) @@ -266,7 +266,7 @@ is not modified." (push r1_min out) (push (cons r1_min (1- r2_min)) out)) (pop range2) - (if (< r2_max r1_max) ; finished with r1? + (if (< r2_max r1_max) ; finished with r1? (setq r1_min (1+ r2_max)) (pop range1) (setq r1 (car range1) @@ -283,7 +283,7 @@ is not modified." (setq r1 (car range1) r1_min (if (consp r1) (car r1) r1) r1_max (if (consp r1) (cdr r1) r1))) - ((< r1_max r2_min) ; r2 > r1 + ((< r1_max r2_min) ; r2 > r1 (pop range1) (if (eq r1_min r1_max) (push r1_min out) diff --git a/lisp/gnus-salt.el b/lisp/gnus-salt.el index 3d5e80f..181f9cf 100644 --- a/lisp/gnus-salt.el +++ b/lisp/gnus-salt.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) @@ -161,8 +162,8 @@ If given a prefix, mark all unpicked articles as read." (error "No articles have been picked")))) (defun gnus-pick-goto-article (arg) - "Go to the article number indicated by ARG. If ARG is an invalid -article number, then stay on current line." + "Go to the article number indicated by ARG. +If ARG is an invalid article number, then stay on current line." (let (pos) (save-excursion (goto-char (point-min)) @@ -173,7 +174,7 @@ article number, then stay on current line." (goto-char pos)))) (defun gnus-pick-article (&optional arg) - "Pick the article on the current line. + "Pick the article on the current line. If ARG, pick the article on that line instead." (interactive "P") (when arg @@ -243,46 +244,46 @@ This must be bound to a button-down mouse event." ;; (but not outside the window where the drag started). (let (event end end-point (end-of-range (point))) (track-mouse - (while (progn - (setq event (cdr (gnus-read-event-char))) - (or (mouse-movement-p event) - (eq (car-safe event) 'switch-frame))) - (if (eq (car-safe event) 'switch-frame) - nil - (setq end (event-end event) - end-point (posn-point end)) - - (cond - ;; Are we moving within the original window? - ((and (eq (posn-window end) start-window) - (integer-or-marker-p end-point)) - ;; Go to START-POINT first, so that when we move to END-POINT, - ;; if it's in the middle of intangible text, - ;; point jumps in the direction away from START-POINT. - (goto-char start-point) - (goto-char end-point) - (gnus-pick-article) - ;; In case the user moved his mouse really fast, pick - ;; articles on the line between this one and the last one. - (let* ((this-line (1+ (count-lines 1 end-point))) - (min-line (min this-line start-line)) - (max-line (max this-line start-line))) - (while (< min-line max-line) - (goto-line min-line) - (gnus-pick-article) - (setq min-line (1+ min-line))) - (setq start-line this-line)) - (when (zerop (% click-count 3)) - (setq end-of-range (point)))) - (t - (let ((mouse-row (cdr (cdr (mouse-position))))) - (cond - ((null mouse-row)) - ((< mouse-row top) - (mouse-scroll-subr start-window (- mouse-row top))) - ((>= mouse-row bottom) - (mouse-scroll-subr start-window - (1+ (- mouse-row bottom))))))))))) + (while (progn + (setq event (cdr (gnus-read-event-char))) + (or (mouse-movement-p event) + (eq (car-safe event) 'switch-frame))) + (if (eq (car-safe event) 'switch-frame) + nil + (setq end (event-end event) + end-point (posn-point end)) + + (cond + ;; Are we moving within the original window? + ((and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + ;; Go to START-POINT first, so that when we move to END-POINT, + ;; if it's in the middle of intangible text, + ;; point jumps in the direction away from START-POINT. + (goto-char start-point) + (goto-char end-point) + (gnus-pick-article) + ;; In case the user moved his mouse really fast, pick + ;; articles on the line between this one and the last one. + (let* ((this-line (1+ (count-lines 1 end-point))) + (min-line (min this-line start-line)) + (max-line (max this-line start-line))) + (while (< min-line max-line) + (goto-line min-line) + (gnus-pick-article) + (setq min-line (1+ min-line))) + (setq start-line this-line)) + (when (zerop (% click-count 3)) + (setq end-of-range (point)))) + (t + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top))) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window + (1+ (- mouse-row bottom))))))))))) (when (consp event) (let ((fun (key-binding (vector (car event))))) ;; Run the binding of the terminating up-event, if possible. @@ -324,8 +325,8 @@ This must be bound to a button-down mouse event." (setq gnus-binary-mode-map (make-sparse-keymap)) (gnus-define-keys - gnus-binary-mode-map - "g" gnus-binary-show-article)) + gnus-binary-mode-map + "g" gnus-binary-show-article)) (defun gnus-binary-make-menu-bar () (unless (boundp 'gnus-binary-menu) @@ -442,13 +443,13 @@ Two predefined functions are available: (setq gnus-tree-mode-map (make-keymap)) (suppress-keymap gnus-tree-mode-map) (gnus-define-keys - gnus-tree-mode-map - "\r" gnus-tree-select-article - gnus-mouse-2 gnus-tree-pick-article - "\C-?" gnus-tree-read-summary-keys - "h" gnus-tree-show-summary + gnus-tree-mode-map + "\r" gnus-tree-select-article + gnus-mouse-2 gnus-tree-pick-article + "\C-?" gnus-tree-read-summary-keys + "h" gnus-tree-show-summary - "\C-c\C-i" gnus-info-find-node) + "\C-c\C-i" gnus-info-find-node) (substitute-key-definition 'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map)) diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 50583bf..3fc01fb 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) (require 'gnus-range) @@ -220,14 +221,14 @@ This variable allows the same syntax as `gnus-home-score-file'." (gnus-catchup-mark (subject -10)) (gnus-killed-mark (from -1) (subject -20)) (gnus-del-mark (from -2) (subject -15))) -"*Alist of marks and scores." -:group 'gnus-score-adapt -:type '(repeat (cons (symbol :tag "Mark") - (repeat (list (choice :tag "Header" - (const from) - (const subject) - (symbol :tag "other")) - (integer :tag "Score")))))) + "*Alist of marks and scores." + :group 'gnus-score-adapt + :type '(repeat (cons (symbol :tag "Mark") + (repeat (list (choice :tag "Header" + (const from) + (const subject) + (symbol :tag "other")) + (integer :tag "Score")))))) (defcustom gnus-ignored-adaptive-words nil "List of words to be ignored when doing adaptive word scoring." @@ -258,10 +259,10 @@ This variable allows the same syntax as `gnus-home-score-file'." (,gnus-catchup-mark . -10) (,gnus-killed-mark . -20) (,gnus-del-mark . -15)) -"*Alist of marks and scores." -:group 'gnus-score-adapt -:type '(repeat (cons (character :tag "Mark") - (integer :tag "Score")))) + "*Alist of marks and scores." + :group 'gnus-score-adapt + :type '(repeat (cons (character :tag "Mark") + (integer :tag "Score")))) (defcustom gnus-adaptive-word-minimum nil "If a number, this is the minimum score value that can be assigned to a word." @@ -513,7 +514,7 @@ The user will be prompted for header to score on, match type, permanence, and the string to be used. The numerical prefix will be used as score." (interactive (gnus-interactive "P\ny")) - (gnus-summary-increase-score (- (gnus-score-default score)) symp)) + (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) (defun gnus-score-kill-help-buffer () (when (get-buffer "*Score Help*") @@ -527,7 +528,7 @@ The user will be prompted for header to score on, match type, permanence, and the string to be used. The numerical prefix will be used as score." (interactive (gnus-interactive "P\ny")) - (let* ((nscore (gnus-score-default score)) + (let* ((nscore (gnus-score-delta-default score)) (prefix (if (< nscore 0) ?L ?I)) (increase (> nscore 0)) (char-to-header @@ -650,7 +651,7 @@ used as score." ;; Deal with der(r)ided superannuated paradigms. (when (and (eq (1+ prefix) 77) (eq (+ hchar 12) 109) - (eq tchar 114) + (eq (1- tchar) 113) (eq (- pchar 4) 111)) (error "You rang?")) (if mimic @@ -763,7 +764,7 @@ used as score." (pop-to-buffer "*Score Help*") (let ((window-min-height 1)) (shrink-window-if-larger-than-buffer)) - (select-window (get-buffer-window gnus-summary-buffer)))) + (select-window (get-buffer-window gnus-summary-buffer t)))) (defun gnus-summary-header (header &optional no-err extra) ;; Return HEADER for current articles, or error. @@ -818,7 +819,7 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." (setq match (if match (gnus-simplify-subject-re match) ""))) ((eq type 'f) (setq match (gnus-simplify-subject-fuzzy match)))) - (let ((score (gnus-score-default score)) + (let ((score (gnus-score-delta-default score)) (header (format "%s" (downcase header))) new) (when prompt @@ -1001,7 +1002,7 @@ EXTRA is the possible non-standard header." (defun gnus-score-followup-article (&optional score) "Add SCORE to all followups to the article in the current buffer." (interactive "P") - (setq score (gnus-score-default score)) + (setq score (gnus-score-delta-default score)) (when (gnus-buffer-live-p gnus-summary-buffer) (save-excursion (save-restriction @@ -1016,7 +1017,7 @@ EXTRA is the possible non-standard header." (defun gnus-score-followup-thread (&optional score) "Add SCORE to all later articles in the thread the current buffer is part of." (interactive "P") - (setq score (gnus-score-default score)) + (setq score (gnus-score-delta-default score)) (when (gnus-buffer-live-p gnus-summary-buffer) (save-excursion (save-restriction @@ -1061,7 +1062,7 @@ EXTRA is the possible non-standard header." (let ((buffer-read-only nil)) ;; Set score. (gnus-summary-update-mark - (if (= n (or gnus-summary-default-score 0)) ? ;Whitespace + (if (= n (or gnus-summary-default-score 0)) ? ;Whitespace (if (< n (or gnus-summary-default-score 0)) gnus-score-below-mark gnus-score-over-mark)) 'score)) @@ -1516,79 +1517,50 @@ EXTRA is the possible non-standard header." (gnus-message 5 "Scoring...done")))))) +(defun gnus-score-lower-thread (thread score-adjust) + "Lower the socre on THREAD with SCORE-ADJUST. +THREAD is expected to contain a list of the form `(PARENT [CHILD1 +CHILD2 ...])' where PARENT is a header array and each CHILD is a list +of the same form as THREAD. The empty list `nil' is valid. For each +article in the tree, the score of the corresponding entry in +GNUS-NEWSGROUP-SCORED is adjusted by SCORE-ADJUST." + (while thread + (let ((head (car thread))) + (if (listp head) + ;; handle a child and its descendants + (gnus-score-lower-thread head score-adjust) + ;; handle the parent + (let* ((article (mail-header-number head)) + (score (assq article gnus-newsgroup-scored))) + (if score (setcdr score (+ (cdr score) score-adjust)) + (push (cons article score-adjust) gnus-newsgroup-scored))))) + (setq thread (cdr thread)))) -(defun gnus-get-new-thread-ids (articles) - (let ((index (nth 1 (assoc "message-id" gnus-header-index))) - (refind gnus-score-index) - id-list art this tref) - (while articles - (setq art (car articles) - this (aref (car art) index) - tref (aref (car art) refind) - articles (cdr articles)) - (when (string-equal tref "") ;no references line - (push this id-list))) - id-list)) - -;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). (defun gnus-score-orphans (score) - (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) - alike articles art arts this last this-id) - - (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) - articles gnus-scores-articles) - - ;;more or less the same as in gnus-score-string - (erase-buffer) - (while articles - (setq art (car articles) - this (aref (car art) gnus-score-index) - articles (cdr articles)) - ;;completely skip if this is empty (not a child, so not an orphan) - (when (not (string= this "")) - (if (equal last this) - ;; O(N*H) cons-cells used here, where H is the number of - ;; headers. - (push art alike) - (when last - ;; Insert the line, with a text property on the - ;; terminating newline referring to the articles with - ;; this line. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike)) - (setq alike (list art) - last this)))) - (when last ; Bwadr, duplicate code. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike)) - - ;; PLM: now delete those lines that contain an entry from new-thread-ids - (while new-thread-ids - (setq this-id (car new-thread-ids) - new-thread-ids (cdr new-thread-ids)) - (goto-char (point-min)) - (while (search-forward this-id nil t) - ;; found a match. remove this line - (beginning-of-line) - (kill-line 1))) - - ;; now for each line: update its articles with score by moving to - ;; every end-of-line in the buffer and read the articles property - (goto-char (point-min)) - (while (eq 0 (progn - (end-of-line) - (setq arts (get-text-property (point) 'articles)) - (while arts - (setq art (car arts) - arts (cdr arts)) - (setcdr art (+ score (cdr art)))) - (forward-line)))))) - + "Score orphans. +A root is an article with no references. An orphan is an article +which has references, but is not connected via its references to a +root article. This function finds all the orphans, and adjusts their +score in GNUS-NEWSGROUP-SCORED by SCORE." + (let ((threads (gnus-make-threads))) + ;; gnus-make-threads produces a list, where each entry is a "thread" + ;; as described in the gnus-score-lower-thread docs. This function + ;; will be called again (after limiting has been done) if the display + ;; is threaded. It would be nice to somehow save this info and use + ;; it later. + (while threads + (let* ((thread (car threads)) + (id (aref (car thread) gnus-score-index))) + ;; If the parent of the thread is not a root, lower the score of + ;; it and its descendants. Note that some roots seem to satisfy + ;; (eq id nil) and some (eq id ""); not sure why. + (if (and id (not (string= id ""))) + (gnus-score-lower-thread thread score))) + (setq threads (cdr threads))))) (defun gnus-score-integer (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) entries alist) - ;; Find matches. (while scores (setq alist (car scores) @@ -1637,7 +1609,6 @@ EXTRA is the possible non-standard header." (defun gnus-score-date (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) entries alist match match-func article) - ;; Find matches. (while scores (setq alist (car scores) @@ -1724,8 +1695,8 @@ EXTRA is the possible non-standard header." (while articles (setq article (mail-header-number (caar articles))) (gnus-message 7 "Scoring article %s of %s..." article last) + (widen) (when (funcall request-func article gnus-newsgroup-name) - (widen) (goto-char (point-min)) ;; If just parts of the article is to be searched, but the ;; backend didn't support partial fetching, we just narrow @@ -1945,7 +1916,7 @@ EXTRA is the possible non-standard header." ;; with working on them as a group. What a hassle. ;; Just wait 'til you see what horrors we commit against `match'... (if (= gnus-score-index 9) - (setq this (prin1-to-string this))) ; ick. + (setq this (prin1-to-string this))) ; ick. (if simplify (setq this (gnus-map-function gnus-simplify-subject-functions this))) @@ -1998,7 +1969,7 @@ EXTRA is the possible non-standard header." (when extra (setq match (concat "[ (](" extra " \\. \"[^)]*" match "[^(]*\")[ )]") - search-func 're-search-forward)) ; XXX danger?!? + search-func 're-search-forward)) ; XXX danger?!? (cond ;; Fuzzy matches. We save these for later. @@ -2126,6 +2097,7 @@ EXTRA is the possible non-standard header." (cond ;; Permanent. ((null date) + ;; Do nothing. ) ;; Match, update date. ((and found gnus-update-score-entry-dates) @@ -2164,6 +2136,7 @@ EXTRA is the possible non-standard header." (cond ;; Permanent. ((null date) + ;; Do nothing. ) ;; Match, update date. ((and found gnus-update-score-entry-dates) @@ -2470,14 +2443,14 @@ EXTRA is the possible non-standard header." (gnus-summary-raise-score score)) (gnus-summary-next-subject 1 t))) -(defun gnus-score-default (level) +(defun gnus-score-delta-default (level) (if level (prefix-numeric-value level) gnus-score-interactive-default-score)) (defun gnus-summary-raise-thread (&optional score) "Raise the score of the articles in the current thread with SCORE." (interactive "P") - (setq score (gnus-score-default score)) + (setq score (gnus-score-delta-default score)) (let (e) (save-excursion (let ((articles (gnus-summary-articles-in-thread))) @@ -2506,7 +2479,7 @@ EXTRA is the possible non-standard header." (defun gnus-summary-lower-thread (&optional score) "Lower score of articles in the current thread with SCORE." (interactive "P") - (gnus-summary-raise-thread (- (1- (gnus-score-default score))))) + (gnus-summary-raise-thread (- (1- (gnus-score-delta-default score))))) ;;; Finding score files. @@ -2999,8 +2972,7 @@ See `(Gnus)Scoring Tips' for examples of good regular expressions." (cond (bad (cons 'bad bad)) (new (cons 'new new)) - ;; or nil - ))))) + (t nil)))))) (provide 'gnus-score) diff --git a/lisp/gnus-setup.el b/lisp/gnus-setup.el index 29c2a31..c98ef72 100644 --- a/lisp/gnus-setup.el +++ b/lisp/gnus-setup.el @@ -66,19 +66,19 @@ "Directory where Big Brother Database is found.") (defvar gnus-use-mhe nil - "Set this if you want to use MH-E for mail reading") + "Set this if you want to use MH-E for mail reading.") (defvar gnus-use-rmail nil - "Set this if you want to use RMAIL for mail reading") + "Set this if you want to use RMAIL for mail reading.") (defvar gnus-use-sendmail t - "Set this if you want to use SENDMAIL for mail reading") + "Set this if you want to use SENDMAIL for mail reading.") (defvar gnus-use-vm nil - "Set this if you want to use the VM package for mail reading") + "Set this if you want to use the VM package for mail reading.") (defvar gnus-use-sc nil - "Set this if you want to use Supercite") + "Set this if you want to use Supercite.") (defvar gnus-use-mailcrypt t - "Set this if you want to use Mailcrypt for dealing with PGP messages") + "Set this if you want to use Mailcrypt for dealing with PGP messages.") (defvar gnus-use-bbdb nil - "Set this if you want to use the Big Brother DataBase") + "Set this if you want to use the Big Brother DataBase.") (when (and (not gnus-use-installed-gnus) (null (member gnus-gnus-lisp-directory load-path))) diff --git a/lisp/gnus-soup.el b/lisp/gnus-soup.el index 8a9a206..08c96c5 100644 --- a/lisp/gnus-soup.el +++ b/lisp/gnus-soup.el @@ -140,7 +140,7 @@ move those articles instead." (buffer-disable-undo tmp-buf) (save-excursion (while articles - ;; Put the article in a buffer. + ;; Put the article in a buffer. (set-buffer tmp-buf) (when (gnus-request-article-this-buffer (car articles) gnus-newsgroup-name) diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el index 23781b6..7f35c76 100644 --- a/lisp/gnus-spec.el +++ b/lisp/gnus-spec.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) ;;; Internal variables. @@ -562,7 +563,10 @@ If PROPS, insert the result." (symbol-value (intern (format "gnus-%s-line-format-alist" type))) insertable))) - (provide 'gnus-spec) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; gnus-spec.el ends here diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 66c67ed..dde25b8 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-spec) (require 'gnus-group) @@ -173,12 +174,12 @@ The following commands are available: (gnus-tmp-where (nth 1 method)) (elem (assoc method gnus-opened-servers)) (gnus-tmp-status (cond ((eq (nth 1 elem) 'denied) - "(denied)") - ((or (gnus-server-opened method) - (eq (nth 1 elem) 'ok)) - "(opened)") - (t - "(closed)")))) + "(denied)") + ((or (gnus-server-opened method) + (eq (nth 1 elem) 'ok)) + "(opened)") + (t + "(closed)")))) (beginning-of-line) (gnus-add-text-properties (point) @@ -508,28 +509,28 @@ The following commands are available: (suppress-keymap gnus-browse-mode-map) (gnus-define-keys - gnus-browse-mode-map - " " gnus-browse-read-group - "=" gnus-browse-select-group - "n" gnus-browse-next-group - "p" gnus-browse-prev-group - "\177" gnus-browse-prev-group - [delete] gnus-browse-prev-group - "N" gnus-browse-next-group - "P" gnus-browse-prev-group - "\M-n" gnus-browse-next-group - "\M-p" gnus-browse-prev-group - "\r" gnus-browse-select-group - "u" gnus-browse-unsubscribe-current-group - "l" gnus-browse-exit - "L" gnus-browse-exit - "q" gnus-browse-exit - "Q" gnus-browse-exit - "\C-c\C-c" gnus-browse-exit - "?" gnus-browse-describe-briefly - - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug)) + gnus-browse-mode-map + " " gnus-browse-read-group + "=" gnus-browse-select-group + "n" gnus-browse-next-group + "p" gnus-browse-prev-group + "\177" gnus-browse-prev-group + [delete] gnus-browse-prev-group + "N" gnus-browse-next-group + "P" gnus-browse-prev-group + "\M-n" gnus-browse-next-group + "\M-p" gnus-browse-prev-group + "\r" gnus-browse-select-group + "u" gnus-browse-unsubscribe-current-group + "l" gnus-browse-exit + "L" gnus-browse-exit + "q" gnus-browse-exit + "Q" gnus-browse-exit + "\C-c\C-c" gnus-browse-exit + "?" gnus-browse-describe-briefly + + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) (defun gnus-browse-make-menu-bar () (gnus-turn-off-edit-menu 'browse) diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index b1333c0..13f3423 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -27,6 +27,7 @@ (eval-when-compile (require 'cl)) (eval-when-compile (require 'static)) + (require 'gnus) (require 'gnus-win) (require 'gnus-int) @@ -53,7 +54,7 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead." (directory-file-name installation-directory)) "site-lisp/gnus-init") (error nil)) - "*The site-wide Gnus Emacs-Lisp startup file name, or nil if none. + "The site-wide Gnus Emacs-Lisp startup file name, or nil if none. If a file with the `.el' or `.elc' suffixes exists, it will be read instead." :group 'gnus-start :type '(choice file (const nil))) @@ -226,12 +227,12 @@ not match this regexp will be removed before saving the list." :type 'boolean) (defcustom gnus-ignored-newsgroups - (mapconcat 'identity - '("^to\\." ; not "real" groups - "^[0-9. \t]+ " ; all digits in name - "^[\"][]\"[#'()]" ; bogus characters - ) - "\\|") + (mapconcat 'identity + '("^to\\." ; not "real" groups + "^[0-9. \t]+ " ; all digits in name + "^[\"][]\"[#'()]" ; bogus characters + ) + "\\|") "*A regexp to match uninteresting newsgroups in the active file. Any lines in the active file matching this regular expression are removed from the newsgroup list before anything else is done to it, @@ -962,16 +963,16 @@ for new groups, and subscribe the new groups as zombies." (let* ((gnus-subscribe-newsgroup-method gnus-subscribe-newsgroup-method) (check (cond - ((or (and (= (or arg 1) 4) - (not (listp gnus-check-new-newsgroups))) - (null gnus-read-active-file) - (eq gnus-read-active-file 'some)) - 'ask-server) - ((= (or arg 1) 16) - (setq gnus-subscribe-newsgroup-method - 'gnus-subscribe-zombies) - t) - (t gnus-check-new-newsgroups)))) + ((or (and (= (or arg 1) 4) + (not (listp gnus-check-new-newsgroups))) + (null gnus-read-active-file) + (eq gnus-read-active-file 'some)) + 'ask-server) + ((= (or arg 1) 16) + (setq gnus-subscribe-newsgroup-method + 'gnus-subscribe-zombies) + t) + (t gnus-check-new-newsgroups)))) (unless (gnus-check-first-time-used) (if (or (consp check) (eq check 'ask-server)) @@ -1106,10 +1107,10 @@ for new groups, and subscribe the new groups as zombies." hashtb)) (when new-newsgroups (gnus-subscribe-hierarchical-interactive new-newsgroups))) - (if (> groups 0) - (gnus-message 5 "%d new newsgroup%s arrived" - groups (if (> groups 1) "s have" " has")) - (gnus-message 5 "No new newsgroups")) + (if (> groups 0) + (gnus-message 5 "%d new newsgroup%s arrived" + groups (if (> groups 1) "s have" " has")) + (gnus-message 5 "No new newsgroups")) (when got-new (setq gnus-newsrc-last-checked-date new-date)) got-new)) @@ -1263,14 +1264,14 @@ for new groups, and subscribe the new groups as zombies." (setq active (gnus-active group)) (setq num (if active (- (1+ (cdr active)) (car active)) t)) - ;; Shorten the select method if possible, if we need to - ;; store it at all (native groups). - (let ((method (gnus-method-simplify - (or gnus-override-subscribe-method - (gnus-group-method group))))) - (if method - (setq info (list group level nil nil method)) - (setq info (list group level nil))))) + ;; Shorten the select method if possible, if we need to + ;; store it at all (native groups). + (let ((method (gnus-method-simplify + (or gnus-override-subscribe-method + (gnus-group-method group))))) + (if method + (setq info (list group level nil nil method)) + (setq info (list group level nil))))) (unless previous (setq previous (let ((p gnus-newsrc-alist)) @@ -1388,7 +1389,7 @@ newsgroup." t) (condition-case () (inline (gnus-request-group group dont-check method)) - ;(error nil) + ;;(error nil) (quit nil)) (setq active (gnus-parse-active)) ;; If there are no articles in the group, the GROUP @@ -1514,6 +1515,13 @@ newsgroup." ;; be reached) we just set the number of unread articles in this ;; newsgroup to t. This means that Gnus thinks that there are ;; unread articles, but it has no idea how many. + + ;; To be more explicit: + ;; >0 for an active group with messages + ;; 0 for an active group with no unread messages + ;; nil for non-foreign groups that the user has requested not be checked + ;; t for unchecked foreign groups or bogus groups, or groups that can't + ;; be checked, for one reason or other. (if (and (setq method (gnus-info-method info)) (not (inline (gnus-server-equal @@ -1546,7 +1554,15 @@ newsgroup." (setcdr (assoc method retrievegroups) (cons group (cdr (assoc method retrievegroups)))) (push (list method group) retrievegroups)) - (if (member method scanned-methods) + ;; hack: `nnmail-get-new-mail' changes the mail-source depending + ;; on the group, so we must perform a scan for every group + ;; if the users has any directory mail sources. + (if (and (null (assq 'directory + (or mail-sources + (if (listp nnmail-spool-file) + nnmail-spool-file + (list nnmail-spool-file))))) + (member method scanned-methods)) (setq active (gnus-activate-group group)) (setq active (gnus-activate-group group 'scan)) (push method scanned-methods)) @@ -2381,6 +2397,7 @@ If FORCE is non-nil, the .newsrc file is read." "Insert Gnus variables such as gnus-newsrc-alist in lisp format." (let ((print-quoted t) (print-escape-newlines t)) + (insert ";; -*- emacs-lisp -*-\n") (insert ";; Gnus startup file.\n") (insert "\ diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 34aa130..ddd8192 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -28,6 +28,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-group) (require 'gnus-spec) @@ -178,10 +179,13 @@ This variable will only be used if the value of :type 'string) (defcustom gnus-summary-goto-unread t - "*If t, marking commands will go to the next unread article. + "*If t, many commands will go to the next unread article. +This applies to marking commands as well as other commands that +\"naturally\" select the next article, like, for instance, `SPC' at +the end of an article. +If nil, only the marking commands will go to the next (un)read article. If `never', commands that usually go to the next unread article, will -go to the next article, whether it is read or not. -If nil, only the marking commands will go to the next (un)read article." +go to the next article, whether it is read or not." :group 'gnus-summary-marks :link '(custom-manual "(gnus)Setting Marks") :type '(choice (const :tag "off" nil) @@ -370,7 +374,7 @@ It uses the same syntax as the `gnus-split-methods' variable." (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) -(defcustom gnus-unread-mark ? ;Whitespace +(defcustom gnus-unread-mark ? ;Whitespace "*Mark used for unread articles." :group 'gnus-summary-marks :type 'character) @@ -485,7 +489,7 @@ It uses the same syntax as the `gnus-split-methods' variable." :group 'gnus-summary-marks :type 'character) -(defcustom gnus-empty-thread-mark ? ;Whitespace +(defcustom gnus-empty-thread-mark ? ;Whitespace "*There is no thread under the article." :group 'gnus-summary-marks :type 'character) @@ -839,11 +843,14 @@ which it may alter in any way.") '(("^hk\\>\\|^tw\\>\\|\\" cn-big5) ("^cn\\>\\|\\" cn-gb-2312) ("^fj\\>\\|^japan\\>" iso-2022-jp-2) + ("^tnn\\>\\|^pin\\>\\|^sci.lang.japan" iso-2022-7bit) ("^relcom\\>" koi8-r) ("^fido7\\>" koi8-r) ("^\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2) ("^israel\\>" iso-8859-1) ("^han\\>" euc-kr) + ("^alt.chinese.text.big5\\>" chinese-big5) + ("^soc.culture.vietnamese\\>" vietnamese-viqr) ("^\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1) (".*" iso-8859-1)) "Alist of regexps (to match group names) and default charsets to be used when reading." @@ -907,6 +914,10 @@ For example: ((1 . cn-gb-2312) (2 . big5))." (symbol :tag "Charset"))) :group 'gnus-charset) +(defcustom gnus-preserve-marks t + "Whether marks are preserved when moving, copying and respooling messages." + :type 'boolean + :group 'gnus-summary-marks) ;;; Internal variables @@ -921,8 +932,7 @@ For example: ((1 . cn-gb-2312) (2 . big5))." (defvar gnus-thread-indent-array nil) (defvar gnus-thread-indent-array-level gnus-thread-indent-level) (defvar gnus-sort-gathered-threads-function 'gnus-thread-sort-by-number - "Function called to sort the articles within a thread after it has -been gathered together.") + "Function called to sort the articles within a thread after it has been gathered together.") ;; Avoid highlighting in kill files. (defvar gnus-summary-inhibit-highlight nil) @@ -1197,7 +1207,7 @@ If RE-ONLY is non-nil, strip leading `Re:'s only." (defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext) (goto-char (point-min)) (while (re-search-forward regexp nil t) - (replace-match (or newtext "")))) + (replace-match (or newtext "")))) (defun gnus-simplify-buffer-fuzzy () "Simplify string in the buffer fuzzily. @@ -1379,7 +1389,7 @@ increase the score of each group you read." "\C-d" gnus-summary-enter-digest-group "\M-\C-d" gnus-summary-read-document "\M-\C-e" gnus-summary-edit-parameters - "\M-\C-g" gnus-summary-customize-parameters + "\M-\C-a" gnus-summary-customize-parameters "\C-c\C-b" gnus-bug "*" gnus-cache-enter-article "\M-*" gnus-cache-remove-article @@ -1617,8 +1627,7 @@ increase the score of each group you read." "c" gnus-article-copy-part "e" gnus-article-externalize-part "i" gnus-article-inline-part - "|" gnus-article-pipe-part) - ) + "|" gnus-article-pipe-part)) (defun gnus-summary-make-menu-bar () (gnus-turn-off-edit-menu 'summary) @@ -1702,7 +1711,8 @@ increase the score of each group you read." ["Toggle MIME" gnus-summary-toggle-mime t] ["Verbose header" gnus-summary-verbose-headers t] ["Toggle header" gnus-summary-toggle-header t] - ["Toggle smileys" gnus-smiley-display t]) + ["Toggle smileys" gnus-smiley-display t] + ["HZ" gnus-article-decode-HZ t]) ("Output" ["Save in default format" gnus-summary-save-article t] ["Save in file" gnus-summary-save-article-file t] @@ -1781,8 +1791,7 @@ increase the score of each group you read." ["Mark thread as read" gnus-summary-kill-thread t] ["Lower thread score" gnus-summary-lower-thread t] ["Raise thread score" gnus-summary-raise-thread t] - ["Rethread current" gnus-summary-rethread-current t] - )) + ["Rethread current" gnus-summary-rethread-current t])) (easy-menu-define gnus-summary-post-menu gnus-summary-mode-map "" @@ -2005,7 +2014,8 @@ increase the score of each group you read." (list 'gnus-summary-header (nth 1 header))) (list 'quote (nth 1 (car ts))) - (list 'gnus-score-default nil) + (list 'gnus-score-delta-default + nil) (nth 1 (car ps)) t) t) @@ -2611,7 +2621,7 @@ marks of articles." (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? ;Whitespace + ? ;Whitespace (if (< gnus-tmp-score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark))) (gnus-tmp-replied @@ -2676,7 +2686,7 @@ marks of articles." (if (or (null gnus-summary-default-score) (<= (abs (- score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? ;Whitespace + ? ;Whitespace (if (< score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark)) 'score)) @@ -3651,7 +3661,7 @@ If LINE, insert the rebuilt thread starting on line LINE." ;; using some other form will lead to serious barfage. (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) ;; (8% speedup to gnus-summary-prepare, just for fun :-) - (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ; + (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" (vector thread) 2)) (defsubst gnus-article-sort-by-number (h1 h2) @@ -3979,7 +3989,7 @@ or a straight list of headers." (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? ;Whitespace + ? ;Whitespace (if (< gnus-tmp-score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark)) gnus-tmp-replied @@ -4243,16 +4253,14 @@ If SELECT-ARTICLES, only select those articles from GROUP." ((and (or (<= scored marked) (= scored number)) (natnump gnus-large-newsgroup) (> number gnus-large-newsgroup)) - (let ((input (read-from-minibuffer - (format - "How many articles from %s (max %d): " - (gnus-limit-string gnus-newsgroup-name 35) - number) - (static-if (< emacs-major-version 20) - (number-to-string gnus-large-newsgroup) - (cons - (number-to-string gnus-large-newsgroup) - 0))))) + (let* ((cursor-in-echo-area nil) + (input (read-from-minibuffer + (format + "How many articles from %s (max %d): " + (gnus-limit-string gnus-newsgroup-name 35) + number) + (cons (number-to-string gnus-large-newsgroup) + 0)))) (if (string-match "^[ \t]*$" input) number input))) @@ -4371,9 +4379,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; Add all marks lists to the list of marks lists. (while (setq type (pop types)) (setq list (symbol-value - (setq symbol - (intern (format "gnus-newsgroup-%s" - (car type)))))) + (setq symbol + (intern (format "gnus-newsgroup-%s" + (car type)))))) (when list ;; Get rid of the entries of the articles that have the @@ -4392,24 +4400,25 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq arts (cdr arts))) (setq list (cdr all))))) - (or (memq (cdr type) uncompressed) - (setq list (gnus-compress-sequence (set symbol (sort list '<)) t))) + (unless (memq (cdr type) uncompressed) + (setq list (gnus-compress-sequence (set symbol (sort list '<)) t))) - (when (gnus-check-backend-function 'request-set-mark - gnus-newsgroup-name) - ;; uncompressed:s are not proper flags (they are cons cells) - ;; cache is a internal gnus flag - (unless (memq (cdr type) (cons 'cache uncompressed)) - (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) - (del (gnus-remove-from-range (gnus-copy-sequence old) list)) - (add (gnus-remove-from-range (gnus-copy-sequence list) old))) - (if add - (push (list add 'add (list (cdr type))) delta-marks)) - (if del - (push (list del 'del (list (cdr type))) delta-marks))))) + (when (gnus-check-backend-function + 'request-set-mark gnus-newsgroup-name) + ;; uncompressed:s are not proper flags (they are cons cells) + ;; cache is a internal gnus flag + (unless (memq (cdr type) (cons 'cache uncompressed)) + (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) + (del (gnus-remove-from-range (gnus-copy-sequence old) list)) + (add (gnus-remove-from-range + (gnus-copy-sequence list) old))) + (when add + (push (list add 'add (list (cdr type))) delta-marks)) + (when del + (push (list del 'del (list (cdr type))) delta-marks))))) (when list - (push (cons (cdr type) list) newmarked))) + (push (cons (cdr type) list) newmarked))) (when delta-marks (unless (gnus-check-group gnus-newsgroup-name) @@ -5194,7 +5203,10 @@ displayed, no centering will be performed." ;; If the range of read articles is a single range, then the ;; first unread article is the article after the last read ;; article. Sounds logical, doesn't it? - (if (not (listp (cdr read))) + (if (and (not (listp (cdr read))) + (or (< (car read) (car active)) + (progn (setq read (list read)) + nil))) (setq first (max (car active) (1+ (cdr read)))) ;; `read' is a list of ranges. (when (/= (setq nlast (or (and (numberp (car read)) (car read)) @@ -5251,8 +5263,7 @@ displayed, no centering will be performed." (key-binding (read-key-sequence (substitute-command-keys - "\\\\[gnus-summary-universal-argument]" - )))) + "\\\\[gnus-summary-universal-argument]")))) 'undefined) (gnus-error 1 "Undefined key") (save-excursion @@ -5350,7 +5361,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (defun gnus-summary-exit (&optional temporary) "Exit reading current newsgroup, and then return to group selection mode. -gnus-exit-group-hook is called with no arguments if that value is non-nil." +`gnus-exit-group-hook' is called with no arguments if that value is non-nil." (interactive) (gnus-set-global-variables) (gnus-kill-save-kill-buffer) @@ -5379,6 +5390,8 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." (gnus-dup-enter-articles)) (when gnus-use-trees (gnus-tree-close group)) + (when gnus-use-cache + (gnus-cache-write-active)) ;; Remove entries for this group. (nnmail-purge-split-history (gnus-group-real-name group)) ;; Make all changes in this group permanent. @@ -5727,8 +5740,8 @@ returned." (if backward (gnus-summary-find-prev unread) (gnus-summary-find-next unread))) - (gnus-summary-show-thread) - (setq n (1- n))) + (unless (zerop (setq n (1- n))) + (gnus-summary-show-thread))) (when (/= 0 n) (gnus-message 7 "No more%s articles" (if unread " unread" ""))) @@ -6807,15 +6820,7 @@ of what's specified by the `gnus-refer-thread-limit' variable." (t ;; We fetch the article. (catch 'found - (dolist (gnus-override-method - (cond ((null gnus-refer-article-method) - (list 'current gnus-select-method)) - ((consp (car gnus-refer-article-method)) - gnus-refer-article-method) - (t - (list gnus-refer-article-method)))) - (when (eq 'current gnus-override-method) - (setq gnus-override-method gnus-current-select-method)) + (dolist (gnus-override-method (gnus-refer-article-methods)) (gnus-check-server gnus-override-method) ;; Fetch the header, and display the article. (when (setq number (gnus-summary-insert-subject message-id)) @@ -6823,6 +6828,28 @@ of what's specified by the `gnus-refer-thread-limit' variable." (throw 'found t))) (gnus-message 3 "Couldn't fetch article %s" message-id))))))) +(defun gnus-refer-article-methods () + "Return a list of referrable methods." + (cond + ;; No method, so we default to current and native. + ((null gnus-refer-article-method) + (list gnus-current-select-method gnus-select-method)) + ;; Current. + ((eq 'current gnus-refer-article-method) + (list gnus-current-select-method)) + ;; List of select methods. + ((not (stringp (cadr gnus-refer-article-method))) + (let (out) + (dolist (method gnus-refer-article-method) + (push (if (eq 'current method) + gnus-current-select-method + method) + out)) + (nreverse out))) + ;; One single select method. + (t + (list gnus-refer-article-method)))) + (defun gnus-summary-edit-parameters () "Edit the group parameters of the current group." (interactive) @@ -7414,7 +7441,9 @@ re-spool using this method. For this function to work, both the current newsgroup and the newsgroup that you want to move to have to support the `request-move' -and `request-accept' functions." +and `request-accept' functions. + +ACTION can be either `move' (the default), `crosspost' or `copy'." (interactive "P") (unless action (setq action 'move)) @@ -7480,7 +7509,7 @@ and `request-accept' functions." gnus-newsgroup-name)) ; Server (list 'gnus-request-accept-article to-newsgroup (list 'quote select-method) - (not articles) t) ; Accept form + (not articles) t) ; Accept form (not articles))) ; Only save nov last time ;; Copy the article. ((eq action 'copy) @@ -7521,9 +7550,9 @@ and `request-accept' functions." art-group)))))) (cond ((not art-group) - (gnus-message 1 "Couldn't %s article %s: %s" - (cadr (assq action names)) article - (nnheader-get-report (car to-method)))) + (gnus-message 1 "Couldn't %s article %s: %s" + (cadr (assq action names)) article + (nnheader-get-report (car to-method)))) ((and (eq art-group 'junk) (eq action 'move)) (gnus-summary-mark-article article gnus-canceled-mark) @@ -7548,13 +7577,14 @@ and `request-accept' functions." info (gnus-add-to-range (gnus-info-read info) (list (cdr art-group))))) - ;; Copy any marks over to the new group. + ;; See whether the article is to be put in the cache. (let ((marks (if (gnus-group-auto-expirable-p to-group) default-marks no-expire-marks)) (to-article (cdr art-group))) - ;; See whether the article is to be put in the cache. + ;; Enter the article into the cache in the new group, + ;; if that is required. (when gnus-use-cache (gnus-cache-possibly-enter-article to-group to-article @@ -7566,34 +7596,36 @@ and `request-accept' functions." (memq article gnus-newsgroup-dormant) (memq article gnus-newsgroup-unreads))) - (when (and (equal to-group gnus-newsgroup-name) - (not (memq article gnus-newsgroup-unreads))) - ;; Mark this article as read in this group. - (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) - (setcdr (gnus-active to-group) to-article) - (setcdr gnus-newsgroup-active to-article)) - - (while marks - (when (memq article (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))) - (push (cdar marks) to-marks) - ;; If the other group is the same as this group, - ;; then we have to add the mark to the list. - (when (equal to-group gnus-newsgroup-name) - (set (intern (format "gnus-newsgroup-%s" (caar marks))) - (cons to-article - (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))))) - ;; Copy the marks to other group. - (gnus-add-marked-articles - to-group (cdar marks) (list to-article) info)) - (setq marks (cdr marks))) - - (gnus-request-set-mark to-group (list (list (list to-article) - 'set - to-marks))) + (when gnus-preserve-marks + ;; Copy any marks over to the new group. + (when (and (equal to-group gnus-newsgroup-name) + (not (memq article gnus-newsgroup-unreads))) + ;; Mark this article as read in this group. + (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) + (setcdr (gnus-active to-group) to-article) + (setcdr gnus-newsgroup-active to-article)) + + (while marks + (when (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + (push (cdar marks) to-marks) + ;; If the other group is the same as this group, + ;; then we have to add the mark to the list. + (when (equal to-group gnus-newsgroup-name) + (set (intern (format "gnus-newsgroup-%s" (caar marks))) + (cons to-article + (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))))) + ;; Copy the marks to other group. + (gnus-add-marked-articles + to-group (cdar marks) (list to-article) info)) + (setq marks (cdr marks))) + + (gnus-request-set-mark to-group (list (list (list to-article) + 'set + to-marks)))) (gnus-dribble-enter (concat "(gnus-group-set-info '" @@ -7724,12 +7756,11 @@ latter case, they will be copied into the relevant groups." (kill-buffer (current-buffer))))) (defun gnus-summary-article-posted-p () - "Say whether the current (mail) article is available from `gnus-select-method' as well. + "Say whether the current (mail) article is available from news as well. This will be the case if the article has both been mailed and posted." (interactive) (let ((id (mail-header-references (gnus-summary-article-header))) - (gnus-override-method - (or gnus-refer-article-method gnus-select-method))) + (gnus-override-method (car (gnus-refer-article-methods)))) (if (gnus-request-head id "") (gnus-message 2 "The current message was found on %s" gnus-override-method) @@ -8157,7 +8188,8 @@ the actual number of articles marked is returned." "Mark N articles as read forwards. If N is negative, mark backwards instead. Mark with MARK, ?r by default. The difference between N and the actual number of articles marked is -returned." +returned. +Iff NO-EXPIRE, auto-expiry will be inhibited." (interactive "p") (gnus-summary-show-thread) (let ((backward (< n 0)) @@ -8250,7 +8282,8 @@ Four MARK strings are reserved: `? ' (unread), `?!' (ticked), `??' (dormant) and `?E' (expirable). If MARK is nil, then the default character `?r' is used. If ARTICLE is nil, then the article on the current line will be -marked." +marked. +Iff NO-EXPIRE, auto-expiry will be inhibited." ;; The mark might be a string. (when (stringp mark) (setq mark (aref mark 0))) @@ -8780,9 +8813,7 @@ Returns nil if no threads were there to be hidden." (subst-char-in-region start (point) ?\n ?\^M) (gnus-summary-goto-subject article)) (goto-char start) - nil) - ;;(gnus-summary-position-point) - )))) + nil))))) (defun gnus-summary-go-to-next-thread (&optional previous) "Go to the same level (or less) next thread. @@ -9324,8 +9355,10 @@ If REVERSE, save parts that do not match TYPE." "Read the headers of article ID and enter them into the Gnus system." (let ((group gnus-newsgroup-name) (gnus-override-method - (and (gnus-news-group-p gnus-newsgroup-name) - gnus-refer-article-method)) + (or + gnus-override-method + (and (gnus-news-group-p gnus-newsgroup-name) + (car (gnus-refer-article-methods))))) where) ;; First we check to see whether the header in question is already ;; fetched. @@ -9502,16 +9535,16 @@ If REVERSE, save parts that do not match TYPE." (gnus-info-set-read ',info ',(gnus-info-read info)) (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) (gnus-group-update-group ,group t)))) - ;; Propagate the read marks to the backend. - (if (gnus-check-backend-function 'request-set-mark group) - (let ((del (gnus-remove-from-range (gnus-info-read info) read)) - (add (gnus-remove-from-range read (gnus-info-read info)))) - (when (or add del) - (unless (gnus-check-group group) - (error "Can't open server for %s" group)) - (gnus-request-set-mark - group (delq nil (list (if add (list add 'add '(read))) - (if del (list del 'del '(read))))))))) + ;; Propagate the read marks to the backend. + (if (gnus-check-backend-function 'request-set-mark group) + (let ((del (gnus-remove-from-range (gnus-info-read info) read)) + (add (gnus-remove-from-range read (gnus-info-read info)))) + (when (or add del) + (unless (gnus-check-group group) + (error "Can't open server for %s" group)) + (gnus-request-set-mark + group (delq nil (list (if add (list add 'add '(read))) + (if del (list del 'del '(read))))))))) ;; Enter this list into the group info. (gnus-info-set-read info read) ;; Set the number of unread articles in gnus-newsrc-hashtb. @@ -9676,38 +9709,38 @@ If REVERSE, save parts that do not match TYPE." "Setup newsgroup default charset." (if (equal gnus-newsgroup-name "nndraft:drafts") (setq gnus-newsgroup-charset nil) - (let* ((name (and gnus-newsgroup-name - (gnus-group-real-name gnus-newsgroup-name))) - (ignored-charsets - (or gnus-newsgroup-ephemeral-ignored-charsets - (append - (and gnus-newsgroup-name - (or (gnus-group-find-parameter gnus-newsgroup-name - 'ignored-charsets t) - (let ((alist gnus-group-ignored-charsets-alist) - elem (charsets nil)) - (while (setq elem (pop alist)) - (when (and name - (string-match (car elem) name)) - (setq alist nil - charsets (cdr elem)))) - charsets)))) - gnus-newsgroup-ignored-charsets))) - (setq gnus-newsgroup-charset - (or gnus-newsgroup-ephemeral-charset - (and gnus-newsgroup-name - (or (gnus-group-find-parameter gnus-newsgroup-name 'charset) - (let ((alist gnus-group-charset-alist) - elem charset) - (while (setq elem (pop alist)) - (when (and name - (string-match (car elem) name)) - (setq alist nil - charset (cadr elem)))) - charset))) - gnus-default-charset)) - (set (make-local-variable 'gnus-newsgroup-ignored-charsets) - ignored-charsets)))) + (let* ((name (and gnus-newsgroup-name + (gnus-group-real-name gnus-newsgroup-name))) + (ignored-charsets + (or gnus-newsgroup-ephemeral-ignored-charsets + (append + (and gnus-newsgroup-name + (or (gnus-group-find-parameter gnus-newsgroup-name + 'ignored-charsets t) + (let ((alist gnus-group-ignored-charsets-alist) + elem (charsets nil)) + (while (setq elem (pop alist)) + (when (and name + (string-match (car elem) name)) + (setq alist nil + charsets (cdr elem)))) + charsets))) + gnus-newsgroup-ignored-charsets)))) + (setq gnus-newsgroup-charset + (or gnus-newsgroup-ephemeral-charset + (and gnus-newsgroup-name + (or (gnus-group-find-parameter gnus-newsgroup-name 'charset) + (let ((alist gnus-group-charset-alist) + elem charset) + (while (setq elem (pop alist)) + (when (and name + (string-match (car elem) name)) + (setq alist nil + charset (cadr elem)))) + charset))) + gnus-default-charset)) + (set (make-local-variable 'gnus-newsgroup-ignored-charsets) + ignored-charsets)))) ;;; ;;; Mime Commands diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index d86f573..34f5a7b 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-group) (require 'gnus-start) @@ -221,7 +222,7 @@ If TOPIC, start with that topic." (> unread 0)) (and gnus-list-groups-with-ticked-articles (cdr (assq 'tick (gnus-info-marks info)))) - ; Has right readedness. + ;; Has right readedness. ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) @@ -998,7 +999,7 @@ articles in the topic and its subtopics." (if (null arg) (not gnus-topic-mode) (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. - (if (not gnus-topic-mode) + (if (not gnus-topic-mode) (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) @@ -1065,9 +1066,9 @@ If performed over a topic line, toggle folding the topic." (save-excursion (gnus-message 5 "Expiring groups in %s..." topic) (let ((gnus-group-marked - (mapcar (lambda (entry) (car (nth 2 entry))) - (gnus-topic-find-groups topic gnus-level-killed t)))) - (gnus-group-expire-articles nil)) + (mapcar (lambda (entry) (car (nth 2 entry))) + (gnus-topic-find-groups topic gnus-level-killed t)))) + (gnus-group-expire-articles nil)) (gnus-message 5 "Expiring groups in %s...done" topic)))) (defun gnus-topic-read-group (&optional all no-article group) @@ -1520,7 +1521,7 @@ If REVERSE, reverse the sorting order." (error "Can't find topic `%s'" current)) (unless to-top (error "Can't find topic `%s'" to)) - (if (gnus-topic-find-topology to current-top 0) ;; Don't care the level + (if (gnus-topic-find-topology to current-top 0);; Don't care the level (error "Can't move `%s' to its sub-level" current)) (gnus-topic-find-topology current nil nil 'delete) (while (cdr to-top) diff --git a/lisp/gnus-undo.el b/lisp/gnus-undo.el index 6d7e4ab..8823747 100644 --- a/lisp/gnus-undo.el +++ b/lisp/gnus-undo.el @@ -84,11 +84,11 @@ (setq gnus-undo-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-undo-mode-map - "\M-\C-_" gnus-undo - "\C-_" gnus-undo - "\C-xu" gnus-undo - ;; many people are used to type `C-/' on X terminals and get `C-_'. - [(control /)] gnus-undo)) + "\M-\C-_" gnus-undo + "\C-_" gnus-undo + "\C-xu" gnus-undo + ;; many people are used to type `C-/' on X terminals and get `C-_'. + [(control /)] gnus-undo)) (defun gnus-undo-make-menu-bar () ;; This is disabled for the time being. diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 5d6d6e2..9c665a9 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -33,6 +33,7 @@ (eval-when-compile (require 'cl)) (eval-when-compile (require 'static)) + (require 'custom) (require 'nnheader) (require 'message) @@ -536,6 +537,7 @@ If N, return the Nth ancestor instead." first 't2 last 't1)) ((gnus-functionp function) + ;; Do nothing. ) (t (error "Invalid sort spec: %s" function)))) diff --git a/lisp/gnus-uu.el b/lisp/gnus-uu.el index aa2e95f..b0772e5 100644 --- a/lisp/gnus-uu.el +++ b/lisp/gnus-uu.el @@ -386,17 +386,17 @@ didn't work, and overwrite existing files. Otherwise, ask each time." "P" gnus-uu-decode-postscript-and-save) (gnus-define-keys - (gnus-uu-extract-view-map "v" gnus-uu-extract-map) - "u" gnus-uu-decode-uu-view - "U" gnus-uu-decode-uu-and-save-view - "s" gnus-uu-decode-unshar-view - "S" gnus-uu-decode-unshar-and-save-view - "o" gnus-uu-decode-save-view - "O" gnus-uu-decode-save-view - "b" gnus-uu-decode-binhex-view - "B" gnus-uu-decode-binhex-view - "p" gnus-uu-decode-postscript-view - "P" gnus-uu-decode-postscript-and-save-view) + (gnus-uu-extract-view-map "v" gnus-uu-extract-map) + "u" gnus-uu-decode-uu-view + "U" gnus-uu-decode-uu-and-save-view + "s" gnus-uu-decode-unshar-view + "S" gnus-uu-decode-unshar-and-save-view + "o" gnus-uu-decode-save-view + "O" gnus-uu-decode-save-view + "b" gnus-uu-decode-binhex-view + "B" gnus-uu-decode-binhex-view + "p" gnus-uu-decode-postscript-view + "P" gnus-uu-decode-postscript-and-save-view) ;; Commands. @@ -567,8 +567,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time." ;; Process marking. (defun gnus-uu-mark-by-regexp (regexp &optional unmark) - "Ask for a regular expression and set the process mark on all articles that match." - (interactive (list (read-from-minibuffer "Mark (regexp): "))) + "Set the process mark on articles whose subjects match REGEXP. +When called interactively, prompt for REGEXP. +Optional UNMARK non-nil means unmark instead of mark." + (interactive "sMark (regexp): \nP") (let ((articles (gnus-uu-find-articles-matching regexp))) (while articles (if unmark @@ -577,9 +579,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (message "")) (gnus-summary-position-point)) -(defun gnus-uu-unmark-by-regexp (regexp &optional unmark) - "Ask for a regular expression and remove the process mark on all articles that match." - (interactive (list (read-from-minibuffer "Mark (regexp): "))) +(defun gnus-uu-unmark-by-regexp (regexp) + "Remove the process mark from articles whose subjects match REGEXP. +When called interactively, prompt for REGEXP." + (interactive "sUnmark (regexp): ") (gnus-uu-mark-by-regexp regexp t)) (defun gnus-uu-mark-series () @@ -656,7 +659,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (defun gnus-uu-mark-over (&optional score) "Mark all articles with a score over SCORE (the prefix)." (interactive "P") - (let ((score (gnus-score-default score)) + (let ((score (or score gnus-summary-default-score 0)) (data gnus-newsgroup-data)) (save-excursion (while data diff --git a/lisp/gnus-vm.el b/lisp/gnus-vm.el index 74fae9f..a7f6934 100644 --- a/lisp/gnus-vm.el +++ b/lisp/gnus-vm.el @@ -32,6 +32,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus-art) (eval-when-compile diff --git a/lisp/gnus-win.el b/lisp/gnus-win.el index bbaa4f9..6a335e8 100644 --- a/lisp/gnus-win.el +++ b/lisp/gnus-win.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'gnus) (defgroup gnus-windows nil @@ -84,9 +85,9 @@ (article 1.0))) (t '(vertical 1.0 - (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) - (article 1.0))))) + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + (article 1.0))))) (server (vertical 1.0 (server 1.0 point) @@ -285,7 +286,7 @@ See the Gnus manual for an explanation of the syntax used.") (defun gnus-configure-frame (split &optional window) "Split WINDOW according to SPLIT." (unless window - (setq window (get-buffer-window (current-buffer)))) + (setq window (or (get-buffer-window (current-buffer)) (selected-window)))) (select-window window) ;; This might be an old-stylee buffer config. (when (vectorp split) @@ -318,8 +319,10 @@ See the Gnus manual for an explanation of the syntax used.") (t (cdr (assq type gnus-window-to-buffer)))))) (unless buffer (error "Invalid buffer type: %s" type)) - (switch-to-buffer (gnus-get-buffer-create - (gnus-window-to-buffer-helper buffer))) + (let ((buf (gnus-get-buffer-create + (gnus-window-to-buffer-helper buffer)))) + (if (eq buf (window-buffer (selected-window))) (set-buffer buf) + (switch-to-buffer buf))) (when (memq 'frame-focus split) (setq gnus-window-frame-focus window)) ;; We return the window if it has the `point' spec. @@ -420,7 +423,7 @@ See the Gnus manual for an explanation of the syntax used.") (setq gnus-frame-split-p nil) (unless split - (error "No such setting: %s" setting)) + (error "No such setting in `gnus-buffer-configuration': %s" setting)) (if (and (setq all-visible (gnus-all-windows-visible-p split)) (not force)) @@ -443,12 +446,12 @@ See the Gnus manual for an explanation of the syntax used.") (gnus-delete-windows-in-gnusey-frames)) ;; Just remove some windows. (gnus-remove-some-windows) - (switch-to-buffer nntp-server-buffer)) + (set-buffer nntp-server-buffer)) (select-frame frame))) - (switch-to-buffer nntp-server-buffer) (let (gnus-window-frame-focus) - (gnus-configure-frame split (get-buffer-window (current-buffer))) + (set-buffer nntp-server-buffer) + (gnus-configure-frame split) (when gnus-window-frame-focus (select-frame (window-frame gnus-window-frame-focus)))))))) @@ -505,7 +508,7 @@ should have point." (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer))) (setq win (get-buffer-window buf t))) (if (memq 'point split) - (setq all-visible win)) + (setq all-visible win)) (setq all-visible nil))) (t (when (eq type 'frame) diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index 4b74674..191b38c 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -762,8 +762,7 @@ If it is non-nil, it must be a toolbar. The five valid values are gnus-summary-catchup t "Catchup"] [gnus-summary-catchup-and-exit gnus-summary-catchup-and-exit t "Catchup and exit"] - [gnus-summary-exit gnus-summary-exit t "Exit this summary"] - ) + [gnus-summary-exit gnus-summary-exit t "Exit this summary"]) "The summary buffer toolbar.") (defvar gnus-summary-mail-toolbar @@ -773,14 +772,10 @@ If it is non-nil, it must be a toolbar. The five valid values are [gnus-summary-next-unread gnus-summary-next-unread-article t "Next unread article"] [gnus-summary-mail-reply gnus-summary-reply t "Reply"] -; [gnus-summary-mail-get gnus-mail-get t "Message get"] [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] [gnus-summary-mail-save gnus-summary-save-article t "Save"] [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] -; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"] [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"] -; [gnus-summary-mail-spell gnus-mail-spell t "Spell"] -; [gnus-summary-mail-help gnus-mail-help t "Message help"] [gnus-summary-caesar-message gnus-summary-caesar-message t "Rot 13"] [gnus-uu-decode-uu @@ -793,8 +788,7 @@ If it is non-nil, it must be a toolbar. The five valid values are gnus-summary-catchup t "Catchup"] [gnus-summary-catchup-and-exit gnus-summary-catchup-and-exit t "Catchup and exit"] - [gnus-summary-exit gnus-summary-exit t "Exit this summary"] - ) + [gnus-summary-exit gnus-summary-exit t "Exit this summary"]) "The summary buffer mail toolbar.") (defun gnus-xmas-setup-group-toolbar () diff --git a/lisp/ietf-drums.el b/lisp/ietf-drums.el index c28c942..6ef4fc1 100644 --- a/lisp/ietf-drums.el +++ b/lisp/ietf-drums.el @@ -228,8 +228,8 @@ "Narrow to the header section in the current buffer." (narrow-to-region (goto-char (point-min)) - (if (re-search-forward "^\n" nil 1) - (1- (point)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) (point-max))) (goto-char (point-min))) diff --git a/lisp/imap.el b/lisp/imap.el index d9e3fb1..6d8fd45 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -29,7 +29,7 @@ ;; imap.el is roughly divided in two parts, one that parses IMAP ;; responses from the server and storing data into buffer-local ;; variables, and one for utility functions which send commands to -;; server, waits for an answer, and return information. The latter +;; server, waits for an answer, and return information. The latter ;; part is layered on top of the previous. ;; ;; The imap.el API consist of the following functions, other functions @@ -69,7 +69,7 @@ ;; imap-body-lines ;; ;; It is my hope that theese commands should be pretty self -;; explanatory for someone that know IMAP. All functions have +;; explanatory for someone that know IMAP. All functions have ;; additional documentation on how to invoke them. ;; ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP @@ -79,7 +79,7 @@ ;; the UNSELECT extension in Cyrus IMAPD. ;; ;; Without the work of John McClary Prevost and Jim Radford this library -;; would not have seen the light of day. Many thanks. +;; would not have seen the light of day. Many thanks. ;; ;; This is a transcript of short interactive session for demonstration ;; purposes. @@ -88,7 +88,7 @@ ;; => " *imap* my.mail.server:0" ;; ;; The rest are invoked with current buffer as the buffer returned by -;; `imap-open'. It is possible to do all without this, but it would +;; `imap-open'. It is possible to do all without this, but it would ;; look ugly here since `buffer' is always the last argument for all ;; imap.el API functions. ;; @@ -123,11 +123,13 @@ ;; o Accept list of articles instead of message set string in most ;; imap-message-* functions. ;; o Cyrus IMAPd 1.6.x `imtest' support in the imtest wrapper -;; o Format-spec'ify the ssl horror ;; ;; Revision history: ;; -;; - this is unreleased software +;; - 19991218 added starttls/digest-md5 patch, +;; by Daiki Ueno +;; NB! you need SLIM for starttls.el and digest-md5.el +;; - 19991023 commited to pgnus ;; ;;; Code: @@ -145,6 +147,8 @@ (autoload 'starttls-negotiate "starttls") (autoload 'digest-md5-parse-digest-challenge "digest-md5") (autoload 'digest-md5-digest-response "digest-md5") + (autoload 'digest-md5-digest-uri "digest-md5") + (autoload 'digest-md5-challenge "digest-md5") (autoload 'rfc2104-hash "rfc2104") (autoload 'utf7-encode "utf7") (autoload 'utf7-decode "utf7") @@ -161,26 +165,14 @@ program should accept IMAP commands on stdin and return responses to stdout.") -(defvar imap-ssl-program 'auto - "Program to use for SSL connections. It is called like this - -`imap-ssl-program' `imap-ssl-arguments' -ssl2 -connect host:port - -where -ssl2 can also be -ssl3 to indicate which ssl version to use. It -should accept IMAP commands on stdin and return responses to stdout. - -For SSLeay set this to \"s_client\" and `imap-ssl-arguments' to nil, -for OpenSSL set this to \"openssl\" and `imap-ssl-arguments' to -\"s_client\". - -If 'auto it tries s_client first and then openssl.") - -(defvar imap-ssl-arguments nil - "Arguments to pass to `imap-ssl-program'. - -For SSLeay set this to nil, for OpenSSL to \"s_client\". - -If `imap-ssl-program' is 'auto this variable has no effect.") +(defvar imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p" + "openssl s_client -ssl2 -connect %s:%p" + "s_client -ssl3 -connect %s:%p" + "s_client -ssl2 -connect %s:%p") + "A string, or list of strings, containing commands for SSL connections. +Within a string, %s is replaced with the server address and %p with +port number on server. The program should accept IMAP commands on +stdin and return responses to stdout.") (defvar imap-default-user (user-login-name) "Default username to use.") @@ -194,14 +186,14 @@ If `imap-ssl-program' is 'auto this variable has no effect.") "Hooks called after receiving each FETCH response.") (defvar imap-streams '(kerberos4 starttls ssl network) - "Priority of streams to consider when opening connection to -server.") + "Priority of streams to consider when opening connection to server.") (defvar imap-stream-alist '((kerberos4 imap-kerberos4s-p imap-kerberos4-open) (ssl imap-ssl-p imap-ssl-open) (network imap-network-p imap-network-open) - (starttls imap-starttls-p imap-starttls-open)) + (starttls imap-starttls-p imap-starttls-open) + (tls imap-tls-p imap-tls-open)) "Definition of network streams. (NAME CHECK OPEN) @@ -211,30 +203,29 @@ server support the stream and OPEN is a function for opening the stream.") (defvar imap-authenticators '(kerberos4 digest-md5 cram-md5 login anonymous) - "Priority of authenticators to consider when authenticating to -server.") - -(defvar imap-authenticator-alist - '((kerberos4 imap-kerberos4a-p imap-kerberos4-auth) - (cram-md5 imap-cram-md5-p imap-cram-md5-auth) - (login imap-login-p imap-login-auth) - (anonymous imap-anonymous-p imap-anonymous-auth) - (digest-md5 imap-digest-md5-p imap-digest-md5-auth)) + "Priority of authenticators to consider when authenticating to server.") + +(defvar imap-authenticator-alist + '((kerberos4 imap-kerberos4a-p imap-kerberos4-auth) + (cram-md5 imap-cram-md5-p imap-cram-md5-auth) + (login imap-login-p imap-login-auth) + (anonymous imap-anonymous-p imap-anonymous-auth) + (digest-md5 imap-digest-md5-p imap-digest-md5-auth)) "Definition of authenticators. (NAME CHECK AUTHENTICATE) -NAME names the authenticator. CHECK is a function returning non-nil if +NAME names the authenticator. CHECK is a function returning non-nil if the server support the authenticator and AUTHENTICATE is a function for doing the actuall authentification.") -(defvar imap-utf7-p nil +(defvar imap-use-utf7 t "If non-nil, do utf7 encoding/decoding of mailbox names. Since the UTF7 decoding currently only decodes into ISO-8859-1 characters, you may disable this decoding if you need to access UTF7 encoded mailboxes which doesn't translate into ISO-8859-1.") -;; Internal constants. Change theese and die. +;; Internal constants. Change theese and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) @@ -268,8 +259,9 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") (defvar imap-username nil) (defvar imap-password nil) (defvar imap-state 'closed - "IMAP state. Valid states are `closed', `initial', `nonauth', -`auth', `selected' and `examine'.") + "IMAP state. +Valid states are `closed', `initial', `nonauth', `auth', `selected' +and `examine'.") (defvar imap-server-eol "\r\n" "The EOL string sent from the server.") @@ -308,10 +300,10 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") "Lower limit on command tags that have been parsed.") (defvar imap-failed-tags nil - "Alist of tags that failed. Each element is a list with four -elements; tag (a integer), response state (a symbol, `OK', `NO' or -`BAD'), response code (a string), and human readable response text (a -string).") + "Alist of tags that failed. +Each element is a list with four elements; tag (a integer), response +state (a symbol, `OK', `NO' or `BAD'), response code (a string), and +human readable response text (a string).") (defvar imap-tag 0 "Command tag number.") @@ -320,21 +312,21 @@ string).") "Process.") (defvar imap-continuation nil - "Non-nil indicates that the server emitted a continuation request. The -actually value is really the text on the continuation line.") + "Non-nil indicates that the server emitted a continuation request. +The actually value is really the text on the continuation line.") (defvar imap-log nil "Imap session trace.") -(defvar imap-debug nil;"*imap-debug*" +(defvar imap-debug nil ;"*imap-debug*" "Random debug spew.") ;; Utility functions: (defun imap-read-passwd (prompt &rest args) - "Read a password using PROMPT. If ARGS, PROMPT is used as an -argument to `format'." + "Read a password using PROMPT. +If ARGS, PROMPT is used as an argument to `format'." (let ((prompt (if args (apply 'format prompt args) prompt))) @@ -349,7 +341,7 @@ argument to `format'." prompt))) (defsubst imap-utf7-encode (string) - (if imap-utf7-p + (if imap-use-utf7 (and string (condition-case () (utf7-encode string t) @@ -360,7 +352,7 @@ argument to `format'." string)) (defsubst imap-utf7-decode (string) - (if imap-utf7-p + (if imap-use-utf7 (and string (condition-case () (utf7-decode string t) @@ -411,74 +403,67 @@ argument to `format'." (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer))) - (let ((response (match-string 1))) - (erase-buffer) - (message "Kerberized IMAP connection: %s" response) - (if (and response (let ((case-fold-search nil)) - (not (string-match "failed" response)))) - process - (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) - (delete-process process) - nil)))))) + (let ((response (match-string 1))) + (erase-buffer) + (message "Kerberized IMAP connection: %s" response) + (if (and response (let ((case-fold-search nil)) + (not (string-match "failed" response)))) + process + (if (memq (process-status process) '(open run)) + (imap-send-command-wait "LOGOUT")) + (delete-process process) + nil)))))) (defun imap-ssl-p (buffer) nil) -(defun imap-ssl-open-2 (name buffer server port &optional extra-ssl-args) - (let* ((port (or port imap-default-ssl-port)) - (ssl-program-name imap-ssl-program) - (ssl-program-arguments (append imap-ssl-arguments extra-ssl-args - (list "-connect" - (format "%s:%d" server port)))) - (process (ignore-errors - (cond ((eq system-type 'windows-nt) - (let (selective-display - (coding-system-for-write 'binary) - (coding-system-for-read 'raw-text-dos)) - (open-ssl-stream name buffer server port))) - (t - (as-binary-process - (open-ssl-stream name buffer server port))))))) - (when process - (with-current-buffer buffer - (goto-char (point-min)) - (while (and (memq (process-status process) '(open run)) - (goto-char (point-max)) - (forward-line -1) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) - (erase-buffer)) - (when (memq (process-status process) '(open run)) - process)))) - -(defun imap-ssl-open-1 (name buffer server port &optional extra-ssl-args) - (or (and (eq imap-ssl-program 'auto) - (let ((imap-ssl-program "s_client") - (imap-ssl-arguments nil)) - (message "imap: Opening IMAP connection with %s %s..." - imap-ssl-program (car-safe extra-ssl-args)) - (imap-ssl-open-2 name buffer server port extra-ssl-args))) - (and (eq imap-ssl-program 'auto) - (let ((imap-ssl-program "openssl") - (imap-ssl-arguments '("s_client"))) - (message "imap: Opening IMAP connection with %s %s..." - imap-ssl-program (car-safe extra-ssl-args)) - (imap-ssl-open-2 name buffer server port extra-ssl-args))) - (and (not (eq imap-ssl-program 'auto)) - (progn (message "imap: Opening IMAP connection with %s %s..." - imap-ssl-program (car-safe extra-ssl-args)) - (imap-ssl-open-2 name buffer server port extra-ssl-args))))) - (defun imap-ssl-open (name buffer server port) - (or (imap-ssl-open-1 name buffer server port '("-ssl3")) - (imap-ssl-open-1 name buffer server port '("-ssl2")))) + "Open a SSL connection to server." + (let ((cmds (if (listp imap-ssl-program) imap-ssl-program + (list imap-ssl-program))) + cmd done) + (while (and (not done) (setq cmd (pop cmds))) + (message "imap: Opening SSL connection with `%s'..." cmd) + (let* ((port (or port imap-default-ssl-port)) + (ssl-program-name shell-file-name) + (ssl-program-arguments + (list shell-command-switch + (format-spec cmd (format-spec-make + ?s server + ?p (number-to-string port))))) + process) + (when (setq process + (ignore-errors + (cond ((eq system-type 'windows-nt) + (let (selective-display + (coding-system-for-write 'binary) + (coding-system-for-read 'raw-text-dos)) + (open-ssl-stream name buffer server port))) + (t + (as-binary-process + (open-ssl-stream name buffer server port)))))) + (with-current-buffer buffer + (goto-char (point-min)) + (while (and (memq (process-status process) '(open run)) + (goto-char (point-max)) + (forward-line -1) + (not (imap-parse-greeting))) + (accept-process-output process 1) + (sit-for 1)) + (and imap-log + (with-current-buffer (get-buffer-create imap-log) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer))) + (erase-buffer) + (when (memq (process-status process) '(open run)) + (setq done process)))))) + (if done + (progn + (message "imap: Opening SSL connection with `%s'...done" cmd) + done) + (message "imap: Failed opening SSL connection") + nil))) (defun imap-network-p (buffer) t) @@ -531,45 +516,45 @@ argument to `format'." (set-process-filter imap-process nil))) (when (memq (process-status process) '(open run)) process)))) - + ;; Server functions; authenticator stuff: (defun imap-interactive-login (buffer loginfunc) - "Login to server in BUFFER. LOGINFUNC is passed a username and a -password, it should return t if it where sucessful authenticating -itself to the server, nil otherwise. Returns t if login was -successful, nil otherwise." + "Login to server in BUFFER. +LOGINFUNC is passed a username and a password, it should return t if +it where sucessful authenticating itself to the server, nil otherwise. +Returns t if login was successful, nil otherwise." (with-current-buffer buffer (make-variable-buffer-local 'imap-username) (make-variable-buffer-local 'imap-password) (let (user passwd ret) -;; (condition-case () - (while (or (not user) (not passwd)) - (setq user (or imap-username - (read-from-minibuffer - (concat "IMAP username for " imap-server ": ") - (or user imap-default-user)))) - (setq passwd (or imap-password - (imap-read-passwd - (concat "IMAP password for " user "@" - imap-server ": ")))) - (when (and user passwd) - (if (funcall loginfunc user passwd) - (progn - (setq ret t - imap-username user) - (if (and (not imap-password) - (y-or-n-p "Store password for this session? ")) - (setq imap-password passwd))) - (message "Login failed...") - (setq passwd nil) - (sit-for 1)))) -;; (quit (with-current-buffer buffer -;; (setq user nil -;; passwd nil))) -;; (error (with-current-buffer buffer -;; (setq user nil -;; passwd nil)))) + ;; (condition-case () + (while (or (not user) (not passwd)) + (setq user (or imap-username + (read-from-minibuffer + (concat "IMAP username for " imap-server ": ") + (or user imap-default-user)))) + (setq passwd (or imap-password + (imap-read-passwd + (concat "IMAP password for " user "@" + imap-server ": ")))) + (when (and user passwd) + (if (funcall loginfunc user passwd) + (progn + (setq ret t + imap-username user) + (if (and (not imap-password) + (y-or-n-p "Store password for this session? ")) + (setq imap-password passwd))) + (message "Login failed...") + (setq passwd nil) + (sit-for 1)))) + ;; (quit (with-current-buffer buffer + ;; (setq user nil + ;; passwd nil))) + ;; (error (with-current-buffer buffer + ;; (setq user nil + ;; passwd nil)))) ret))) (defun imap-kerberos4a-p (buffer) @@ -602,6 +587,26 @@ successful, nil otherwise." (encoded (base64-encode-string response))) encoded)))))))) +(defun imap-login-p (buffer) + (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))) + +(defun imap-login-auth (buffer) + "Login to server using the LOGIN command." + (imap-interactive-login buffer + (lambda (user passwd) + (imap-ok-p (imap-send-command-wait + (concat "LOGIN \"" user "\" \"" + passwd "\"")))))) + +(defun imap-anonymous-p (buffer) + t) + +(defun imap-anonymous-auth (buffer) + (with-current-buffer buffer + (imap-ok-p (imap-send-command-wait + (concat "LOGIN anonymous \"" (concat (user-login-name) "@" + (system-name)) "\""))))) + (defun imap-digest-md5-p (buffer) (and (condition-case () (require 'digest-md5) @@ -613,7 +618,7 @@ successful, nil otherwise." (imap-interactive-login buffer (lambda (user passwd) - (let ((tag + (let ((tag (imap-send-command (list "AUTHENTICATE DIGEST-MD5" @@ -621,10 +626,10 @@ successful, nil otherwise." (digest-md5-parse-digest-challenge (base64-decode-string challenge)) (let* ((digest-uri - (digest-md5-digest-uri + (digest-md5-digest-uri "imap" (digest-md5-challenge 'realm))) (response - (digest-md5-digest-response + (digest-md5-digest-response user passwd digest-uri))) (base64-encode-string response 'no-line-break)))) ))) @@ -634,26 +639,6 @@ successful, nil otherwise." (imap-send-command-1 "") (imap-ok-p (imap-wait-for-tag tag))))))) -(defun imap-login-p (buffer) - (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))) - -(defun imap-login-auth (buffer) - "Login to server using the LOGIN command." - (imap-interactive-login buffer - (lambda (user passwd) - (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" user "\" \"" - passwd "\"")))))) - -(defun imap-anonymous-p (buffer) - t) - -(defun imap-anonymous-auth (buffer) - (with-current-buffer buffer - (imap-ok-p (imap-send-command-wait - (concat "LOGIN anonymous \"" (concat (user-login-name) "@" - (system-name)) "\""))))) - ;; Server functions: (defun imap-open-1 (buffer) @@ -679,21 +664,21 @@ successful, nil otherwise." imap-process)))) (defun imap-open (server &optional port stream auth buffer) - "Open a IMAP connection to host SERVER at PORT returning a -buffer. If PORT is unspecified, a default value is used (143 except + "Open a IMAP connection to host SERVER at PORT returning a buffer. +If PORT is unspecified, a default value is used (143 except for SSL which use 993). STREAM indicates the stream to use, see `imap-streams' for available -streams. If nil, it choices the best stream the server is capable of. +streams. If nil, it choices the best stream the server is capable of. AUTH indicates authenticator to use, see `imap-authenticators' for -available authenticators. If nil, it choices the best stream the +available authenticators. If nil, it choices the best stream the server is capable of. BUFFER can be a buffer or a name of a buffer, which is created if -necessery. If nil, the buffer name is generated." +necessery. If nil, the buffer name is generated." (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0)))) (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapc 'make-variable-buffer-local imap-local-variables) + (mapcar 'make-variable-buffer-local imap-local-variables) (buffer-disable-undo) (setq imap-server (or server imap-server)) (setq imap-port (or port imap-port)) @@ -707,7 +692,7 @@ necessery. If nil, the buffer name is generated." (let ((streams imap-streams)) (while (setq stream (pop streams)) (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - (setq stream-changed (not (eq (or imap-stream + (setq stream-changed (not (eq (or imap-stream imap-default-stream) stream)) imap-stream stream @@ -724,7 +709,7 @@ necessery. If nil, the buffer name is generated." (when (null imap-auth) (let ((auths imap-authenticators)) (while (setq auth (pop auths)) - (if (funcall (nth 1 (assq auth imap-authenticator-alist)) + (if (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) (setq imap-auth auth auths nil))) @@ -735,8 +720,8 @@ necessery. If nil, the buffer name is generated." buffer))) (defun imap-opened (&optional buffer) - "Return non-nil if connection to imap server in BUFFER is open. If -BUFFER is nil then the current buffer is used." + "Return non-nil if connection to imap server in BUFFER is open. +If BUFFER is nil then the current buffer is used." (and (setq buffer (get-buffer (or buffer (current-buffer)))) (buffer-live-p buffer) (with-current-buffer buffer @@ -744,8 +729,8 @@ BUFFER is nil then the current buffer is used." (memq (process-status imap-process) '(open run)))))) (defun imap-authenticate (&optional user passwd buffer) - "Authenticate to server in BUFFER, using current buffer if nil. It -uses the authenticator specified when opening the server. If the + "Authenticate to server in BUFFER, using current buffer if nil. +It uses the authenticator specified when opening the server. If the authenticator requires username/passwords, they are queried from the user and optionally stored in the buffer. If USER and/or PASSWD is specified, the user will not be questioned and the username and/or @@ -760,8 +745,8 @@ password is remembered in the buffer." (setq imap-state 'auth))))) (defun imap-close (&optional buffer) - "Close connection to server in BUFFER. If BUFFER is nil, the current -buffer is used." + "Close connection to server in BUFFER. +If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) (and (imap-opened) (not (imap-ok-p (imap-send-command-wait "LOGOUT"))) @@ -776,9 +761,9 @@ buffer is used." t)) (defun imap-capability (&optional identifier buffer) - "Return a list of identifiers which server in BUFFER support. If -IDENTIFIER, return non-nil if it's among the servers capabilities. If -BUFFER is nil, the current buffer is assumed." + "Return a list of identifiers which server in BUFFER support. +If IDENTIFIER, return non-nil if it's among the servers capabilities. +If BUFFER is nil, the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (unless imap-capability (unless (imap-ok-p (imap-send-command-wait "CAPABILITY")) @@ -788,8 +773,8 @@ BUFFER is nil, the current buffer is assumed." imap-capability))) (defun imap-namespace (&optional buffer) - "Return a namespace hierarchy at server in BUFFER. If BUFFER is nil, -the current buffer is assumed." + "Return a namespace hierarchy at server in BUFFER. +If BUFFER is nil, the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (unless imap-namespace (when (imap-capability 'NAMESPACE) @@ -832,8 +817,8 @@ the current buffer is assumed." result))) (defun imap-mailbox-map (func &optional buffer) - "Map a function across each mailbox in `imap-mailbox-data', -returning a list. Function should take a mailbox name (a string) as + "Map a function across each mailbox in `imap-mailbox-data', returning a list. +Function should take a mailbox name (a string) as the only argument." (imap-mailbox-map-1 func 'imap-utf7-decode buffer)) @@ -853,8 +838,8 @@ the only argument." (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine))) (defun imap-mailbox-select-1 (mailbox &optional examine) - "Select MAILBOX on server in BUFFER. If EXAMINE is non-nil, do a -read-only select." + "Select MAILBOX on server in BUFFER. +If EXAMINE is non-nil, do a read-only select." (if (imap-current-mailbox-p-1 mailbox examine) imap-current-mailbox (setq imap-current-mailbox mailbox) @@ -874,7 +859,7 @@ read-only select." (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine)))) (defun imap-mailbox-examine (mailbox &optional buffer) - "Examine MAILBOX on server in BUFFER" + "Examine MAILBOX on server in BUFFER." (imap-mailbox-select mailbox 'exmine buffer)) (defun imap-mailbox-unselect (&optional buffer) @@ -894,43 +879,43 @@ read-only select." t))) (defun imap-mailbox-expunge (&optional buffer) - "Expunge articles in current folder in BUFFER. If BUFFER is -nil the current buffer is assumed." + "Expunge articles in current folder in BUFFER. +If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (not (eq imap-state 'examine))) (imap-ok-p (imap-send-command-wait "EXPUNGE"))))) (defun imap-mailbox-close (&optional buffer) - "Expunge articles and close current folder in BUFFER. If BUFFER is -nil the current buffer is assumed." + "Expunge articles and close current folder in BUFFER. +If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (imap-ok-p (imap-send-command-wait "CLOSE"))) - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth) - t))) + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth) + t))) (defun imap-mailbox-create-1 (mailbox) (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\"")))) (defun imap-mailbox-create (mailbox &optional buffer) - "Create MAILBOX on server in BUFFER. If BUFFER is nil the current -buffer is assumed." + "Create MAILBOX on server in BUFFER. +If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (imap-mailbox-create-1 (imap-utf7-encode mailbox)))) (defun imap-mailbox-delete (mailbox &optional buffer) - "Delete MAILBOX on server in BUFFER. If BUFFER is nil the current -buffer is assumed." + "Delete MAILBOX on server in BUFFER. +If BUFFER is nil the current buffer is assumed." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (list "DELETE \"" mailbox "\"")))))) (defun imap-mailbox-rename (oldname newname &optional buffer) - "Rename mailbox OLDNAME to NEWNAME on server in BUFFER. If BUFFER is -nil the current buffer is assumed." + "Rename mailbox OLDNAME to NEWNAME on server in BUFFER. +If BUFFER is nil the current buffer is assumed." (let ((oldname (imap-utf7-encode oldname)) (newname (imap-utf7-encode newname))) (with-current-buffer (or buffer (current-buffer)) @@ -941,7 +926,7 @@ nil the current buffer is assumed." (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer) "Return a list of subscribed mailboxes on server in BUFFER. If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is -non-nil, a hierarchy delimiter is added to root. REFERENCE is a +non-nil, a hierarchy delimiter is added to root. REFERENCE is a implementation-specific string that has to be passed to lsub command." (with-current-buffer (or buffer (current-buffer)) ;; Make sure we know the hierarchy separator for root's hierarchy @@ -965,7 +950,7 @@ implementation-specific string that has to be passed to lsub command." (defun imap-mailbox-list (root &optional reference add-delimiter buffer) "Return a list of mailboxes matching ROOT on server in BUFFER. If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to -root. REFERENCE is a implementation-specific string that has to be +root. REFERENCE is a implementation-specific string that has to be passed to list command." (with-current-buffer (or buffer (current-buffer)) ;; Make sure we know the hierarchy separator for root's hierarchy @@ -987,27 +972,27 @@ passed to list command." (nreverse out))))) (defun imap-mailbox-subscribe (mailbox &optional buffer) - "Send the SUBSCRIBE command on the mailbox to server in -BUFFER. Returns non-nil if successful." + "Send the SUBSCRIBE command on the mailbox to server in BUFFER. +Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" (imap-utf7-encode mailbox) "\""))))) (defun imap-mailbox-unsubscribe (mailbox &optional buffer) - "Send the SUBSCRIBE command on the mailbox to server in -BUFFER. Returns non-nil if successful." + "Send the SUBSCRIBE command on the mailbox to server in BUFFER. +Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " (imap-utf7-encode mailbox) "\""))))) (defun imap-mailbox-status (mailbox items &optional buffer) - "Get status items ITEM in MAILBOX from server in BUFFER. ITEMS can -be a symbol or a list of symbols, valid symbols are one of the STATUS -data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity or -'unseen. If ITEMS is a list of symbols, a list of values is returned, -if ITEMS is a symbol only it's value is returned." + "Get status items ITEM in MAILBOX from server in BUFFER. +ITEMS can be a symbol or a list of symbols, valid symbols are one of +the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity +or 'unseen. If ITEMS is a list of symbols, a list of values is +returned, if ITEMS is a symbol only it's value is returned." (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait (list "STATUS \"" @@ -1031,11 +1016,10 @@ if ITEMS is a symbol only it's value is returned." (imap-send-command-wait (list "GETACL \"" (or mailbox imap-current-mailbox) "\""))) - (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox)))))) + (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox)))))) (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer) - "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in -BUFFER." + "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p @@ -1047,8 +1031,7 @@ BUFFER." rights)))))) (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer) - "Removes any pair for IDENTIFIER in MAILBOX from -server in BUFFER." + "Removes any pair for IDENTIFIER in MAILBOX from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p @@ -1081,8 +1064,8 @@ server in BUFFER." props)))) (defun imap-fetch (uids props &optional receive nouidfetch buffer) - "Fetch properties PROPS from message set UIDS from server in -BUFFER. UIDS can be a string, number or a list of numbers. If RECEIVE + "Fetch properties PROPS from message set UIDS from server in BUFFER. +UIDS can be a string, number or a list of numbers. If RECEIVE is non-nil return theese properties." (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait @@ -1118,8 +1101,7 @@ is non-nil return theese properties." propname))) (defun imap-message-map (func propname &optional buffer) - "Map a function across each mailbox in `imap-message-data', -returning a list." + "Map a function across each mailbox in `imap-message-data', returning a list." (with-current-buffer (or buffer (current-buffer)) (let (result) (mapatoms @@ -1181,8 +1163,7 @@ returning a list." (imap-mailbox-get-1 'search imap-current-mailbox))))) (defun imap-message-flag-permanent-p (flag &optional mailbox buffer) - "Return t iff FLAG can be permanently (between IMAP sessions) saved -on articles, in MAILBOX on server in BUFFER." + "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER." (with-current-buffer (or buffer (current-buffer)) (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox)) (member flag (imap-mailbox-get 'permanentflags mailbox))))) @@ -1232,8 +1213,8 @@ on articles, in MAILBOX on server in BUFFER." (defun imap-message-copy (articles mailbox &optional dont-create no-copyuid buffer) "Copy ARTICLES (a string message set) to MAILBOX on server in -BUFFER, creating mailbox if it doesn't exist. If dont-create is -non-nil, it will not create a mailbox. On success, return a list with +BUFFER, creating mailbox if it doesn't exist. If dont-create is +non-nil, it will not create a mailbox. On success, return a list with the UIDVALIDITY of the mailbox the article(s) was copied to as the first element, rest of list contain the saved articles' UIDs." (when articles @@ -1271,9 +1252,10 @@ first element, rest of list contain the saved articles' UIDs." (imap-message-appenduid-1 (imap-utf7-encode mailbox)))) (defun imap-message-append (mailbox article &optional flags date-time buffer) - "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER. FLAGS and -DATE-TIME is currently not used. Return a cons holding uidvalidity of -MAILBOX and UID the newly created article got, or nil on failure." + "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER. +FLAGS and DATE-TIME is currently not used. Return a cons holding +uidvalidity of MAILBOX and UID the newly created article got, or nil +on failure." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (and (let ((imap-current-target-mailbox mailbox)) @@ -1283,8 +1265,7 @@ MAILBOX and UID the newly created article got, or nil on failure." (imap-message-appenduid-1 mailbox))))) (defun imap-body-lines (body) - "Return number of lines in article by looking at the mime bodystructure -BODY." + "Return number of lines in article by looking at the mime bodystructure BODY." (if (listp body) (if (stringp (car body)) (cond ((and (string= (car body) "TEXT") @@ -1337,7 +1318,7 @@ BODY." (imap-send-command-1 cmdstr) (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil) ;; abort command if no cont-req + (setq command nil);; abort command if no cont-req (let ((process imap-process) (stream imap-stream)) (with-current-buffer cmd @@ -1361,7 +1342,7 @@ BODY." (setq cmdstr nil) (unwind-protect (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil) ;; abort command if no cont-req + (setq command nil);; abort command if no cont-req (setq command (cons (funcall cmd imap-continuation) command))) (setq imap-continuation nil))) @@ -1387,8 +1368,8 @@ BODY." (delete-process process)) (defun imap-find-next-line () - "Return point at end of current line, taking into account -literals. Return nil if no complete line has arrived." + "Return point at end of current line, taking into account literals. +Return nil if no complete line has arrived." (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}" imap-server-eol) nil t) @@ -1455,7 +1436,7 @@ literals. Return nil if no complete line has arrived." (if (< (point-max) (+ pos len)) nil (goto-char (+ pos len)) - (buffer-substring-no-properties pos (+ pos len)))))) + (buffer-substring pos (+ pos len)))))) ;; string = quoted / literal ;; @@ -1469,13 +1450,20 @@ literals. Return nil if no complete line has arrived." ;; TEXT-CHAR = (defsubst imap-parse-string () - (let (strstart strend) - (cond ((and (eq (char-after (point)) ?\") - (setq strstart (point)) - (setq strend (search-forward "\"" nil t 2))) - (buffer-substring-no-properties (1+ strstart) (1- strend))) - ((eq (char-after) ?{) - (imap-parse-literal))))) + (cond ((eq (char-after) ?\") + (forward-char 1) + (let ((p (point)) (name "")) + (skip-chars-forward "^\"\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^\"\\\\") + (setq name (concat name (buffer-substring p (point))))) + (forward-char 1) + name)) + ((eq (char-after) ?{) + (imap-parse-literal)))) ;; nil = "NIL" @@ -1986,8 +1974,7 @@ literals. Return nil if no complete line has arrived." ;; ; revisions of this specification. (defun imap-parse-flag-list () - (let ((str (buffer-substring-no-properties - (point) (search-forward ")" nil t))) + (let ((str (buffer-substring (point) (search-forward ")" nil t))) pos) (while (setq pos (string-match "\\\\" str (and pos (+ 2 pos)))) (setq str (replace-match "\\\\" nil t str))) @@ -2020,31 +2007,31 @@ literals. Return nil if no complete line has arrived." (defun imap-parse-envelope () (when (eq (char-after) ?\() (imap-forward) - (vector (prog1 (imap-parse-nstring) ;; date + (vector (prog1 (imap-parse-nstring);; date (imap-forward)) - (prog1 (imap-parse-nstring) ;; subject + (prog1 (imap-parse-nstring);; subject (imap-forward)) - (prog1 (imap-parse-address-list) ;; from + (prog1 (imap-parse-address-list);; from (imap-forward)) - (prog1 (imap-parse-address-list) ;; sender + (prog1 (imap-parse-address-list);; sender (imap-forward)) - (prog1 (imap-parse-address-list) ;; reply-to + (prog1 (imap-parse-address-list);; reply-to (imap-forward)) - (prog1 (imap-parse-address-list) ;; to + (prog1 (imap-parse-address-list);; to (imap-forward)) - (prog1 (imap-parse-address-list) ;; cc + (prog1 (imap-parse-address-list);; cc (imap-forward)) - (prog1 (imap-parse-address-list) ;; bcc + (prog1 (imap-parse-address-list);; bcc (imap-forward)) - (prog1 (imap-parse-nstring) ;; in-reply-to + (prog1 (imap-parse-nstring);; in-reply-to (imap-forward)) - (prog1 (imap-parse-nstring) ;; message-id + (prog1 (imap-parse-nstring);; message-id (imap-forward))))) ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil (defsubst imap-parse-string-list () - (cond ((eq (char-after) ?\() ;; body-fld-param + (cond ((eq (char-after) ?\();; body-fld-param (let (strlist str) (imap-forward) (while (setq str (imap-parse-string)) @@ -2089,7 +2076,7 @@ literals. Return nil if no complete line has arrived." (defsubst imap-parse-body-ext () (let (ext) - (when (eq (char-after) ?\ ) ;; body-fld-dsp + (when (eq (char-after) ?\ );; body-fld-dsp (imap-forward) (let (dsp) (if (eq (char-after) ?\() @@ -2101,12 +2088,12 @@ literals. Return nil if no complete line has arrived." (imap-forward)) (assert (imap-parse-nil))) (push (nreverse dsp) ext)) - (when (eq (char-after) ?\ ) ;; body-fld-lang + (when (eq (char-after) ?\ );; body-fld-lang (imap-forward) (if (eq (char-after) ?\() (push (imap-parse-string-list) ext) (push (imap-parse-nstring) ext)) - (while (eq (char-after) ?\ ) ;; body-extension + (while (eq (char-after) ?\ );; body-extension (imap-forward) (setq ext (append (imap-parse-body-extension) ext))))) ext)) @@ -2182,35 +2169,35 @@ literals. Return nil if no complete line has arrived." (setq subbody (imap-parse-body))) (push subbody body)) (imap-forward) - (push (imap-parse-string) body) ;; media-subtype - (when (eq (char-after) ?\ ) ;; body-ext-mpart: + (push (imap-parse-string) body);; media-subtype + (when (eq (char-after) ?\ );; body-ext-mpart: (imap-forward) - (if (eq (char-after) ?\() ;; body-fld-param + (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-... + (append (imap-parse-body-ext) body)));; body-ext-... (assert (eq (char-after) ?\))) (imap-forward) (nreverse body)) - (push (imap-parse-string) body) ;; media-type + (push (imap-parse-string) body);; media-type (imap-forward) - (push (imap-parse-string) body) ;; media-subtype + (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 + (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 + (push (imap-parse-nstring) body);; body-fld-id (imap-forward) - (push (imap-parse-nstring) body) ;; body-fld-desc + (push (imap-parse-nstring) body);; body-fld-desc (imap-forward) - (push (imap-parse-string) body) ;; body-fld-enc + (push (imap-parse-string) body);; body-fld-enc (imap-forward) - (push (imap-parse-number) body) ;; body-fld-octets + (push (imap-parse-number) body);; body-fld-octets ;; ok, we're done parsing the required parts, what comes now is one ;; of three things: @@ -2220,131 +2207,129 @@ literals. Return nil if no complete line has arrived." ;; 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)... + ;; 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 + (cond ((eq (char-after) ?\();; body-type-msg: + (push (imap-parse-envelope) body);; envelope (imap-forward) - (push (imap-parse-body) body) ;; body + (push (imap-parse-body) body);; 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 + (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... + (backward-char)))));; no match... ;; ...and then parse the third one here... - (when (eq (char-after) ?\ ) ;; body-ext-1part: + (when (eq (char-after) ?\ );; body-ext-1part: (imap-forward) - (push (imap-parse-nstring) body) ;; body-fld-md5 + (push (imap-parse-nstring) body);; body-fld-md5 (setq body (append (imap-parse-body-ext) body)));; body-ext-1part.. (assert (eq (char-after) ?\))) (imap-forward) (nreverse body))))) -(when imap-debug ; (untrace-all) +(when imap-debug ; (untrace-all) (require 'trace) (buffer-disable-undo (get-buffer-create imap-debug)) - (mapc (lambda (f) (trace-function-background f imap-debug)) - '( -imap-read-passwd -imap-utf7-encode -imap-utf7-decode -imap-error-text -imap-kerberos4s-p -imap-kerberos4-open -imap-ssl-p -imap-ssl-open-2 -imap-ssl-open-1 -imap-ssl-open -imap-network-p -imap-network-open -imap-interactive-login -imap-kerberos4a-p -imap-kerberos4-auth -imap-cram-md5-p -imap-cram-md5-auth -imap-login-p -imap-login-auth -imap-anonymous-p -imap-anonymous-auth -imap-open-1 -imap-open -imap-opened -imap-authenticate -imap-close -imap-capability -imap-namespace -imap-send-command-wait -imap-mailbox-put -imap-mailbox-get -imap-mailbox-map-1 -imap-mailbox-map -imap-current-mailbox -imap-current-mailbox-p-1 -imap-current-mailbox-p -imap-mailbox-select-1 -imap-mailbox-select -imap-mailbox-examine -imap-mailbox-unselect -imap-mailbox-expunge -imap-mailbox-close -imap-mailbox-create-1 -imap-mailbox-create -imap-mailbox-delete -imap-mailbox-rename -imap-mailbox-lsub -imap-mailbox-list -imap-mailbox-subscribe -imap-mailbox-unsubscribe -imap-mailbox-status -imap-mailbox-acl-get -imap-mailbox-acl-set -imap-mailbox-acl-delete -imap-current-message -imap-list-to-message-set -imap-fetch-asynch -imap-fetch -imap-message-put -imap-message-get -imap-message-map -imap-search -imap-message-flag-permanent-p -imap-message-flags-set -imap-message-flags-del -imap-message-flags-add -imap-message-copyuid-1 -imap-message-copyuid -imap-message-copy -imap-message-appenduid-1 -imap-message-appenduid -imap-message-append -imap-body-lines -imap-envelope-from -imap-send-command-1 -imap-send-command -imap-wait-for-tag -imap-sentinel -imap-find-next-line -imap-arrival-filter -imap-parse-greeting -imap-parse-response -imap-parse-resp-text -imap-parse-resp-text-code -imap-parse-data-list -imap-parse-fetch -imap-parse-status -imap-parse-acl -imap-parse-flag-list -imap-parse-envelope -imap-parse-body-extension -imap-parse-body - ))) + (mapcar (lambda (f) (trace-function-background f imap-debug)) + '( + imap-read-passwd + imap-utf7-encode + imap-utf7-decode + imap-error-text + imap-kerberos4s-p + imap-kerberos4-open + imap-ssl-p + imap-ssl-open + imap-network-p + imap-network-open + imap-interactive-login + imap-kerberos4a-p + imap-kerberos4-auth + imap-cram-md5-p + imap-cram-md5-auth + imap-login-p + imap-login-auth + imap-anonymous-p + imap-anonymous-auth + imap-open-1 + imap-open + imap-opened + imap-authenticate + imap-close + imap-capability + imap-namespace + imap-send-command-wait + imap-mailbox-put + imap-mailbox-get + imap-mailbox-map-1 + imap-mailbox-map + imap-current-mailbox + imap-current-mailbox-p-1 + imap-current-mailbox-p + imap-mailbox-select-1 + imap-mailbox-select + imap-mailbox-examine + imap-mailbox-unselect + imap-mailbox-expunge + imap-mailbox-close + imap-mailbox-create-1 + imap-mailbox-create + imap-mailbox-delete + imap-mailbox-rename + imap-mailbox-lsub + imap-mailbox-list + imap-mailbox-subscribe + imap-mailbox-unsubscribe + imap-mailbox-status + imap-mailbox-acl-get + imap-mailbox-acl-set + imap-mailbox-acl-delete + imap-current-message + imap-list-to-message-set + imap-fetch-asynch + imap-fetch + imap-message-put + imap-message-get + imap-message-map + imap-search + imap-message-flag-permanent-p + imap-message-flags-set + imap-message-flags-del + imap-message-flags-add + imap-message-copyuid-1 + imap-message-copyuid + imap-message-copy + imap-message-appenduid-1 + imap-message-appenduid + imap-message-append + imap-body-lines + imap-envelope-from + imap-send-command-1 + imap-send-command + imap-wait-for-tag + imap-sentinel + imap-find-next-line + imap-arrival-filter + imap-parse-greeting + imap-parse-response + imap-parse-resp-text + imap-parse-resp-text-code + imap-parse-data-list + imap-parse-fetch + imap-parse-status + imap-parse-acl + imap-parse-flag-list + imap-parse-envelope + imap-parse-body-extension + imap-parse-body + ))) (provide 'imap) diff --git a/lisp/lpath.el b/lisp/lpath.el index 2e4010b..ca2d1db 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -62,14 +62,15 @@ w3-meta-charset-content-type-regexp url-current-callback-func url-current-callback-data url-be-asynchronous temporary-file-directory - babel-translations babel-history))) + babel-translations babel-history + display-time-mail-function))) (maybe-bind '(mail-mode-hook enable-multibyte-characters browse-url-browser-function adaptive-fill-first-line-regexp adaptive-fill-regexp url-current-mime-headers help-echo-owns-message w3-meta-content-type-charset-regexp w3-meta-charset-content-type-regexp - babel-translations babel-history)) + babel-translations babel-history display-time-mail-function)) (maybe-fbind '(color-instance-rgb-components temp-directory glyph-width annotation-glyph window-pixel-width glyph-height @@ -97,9 +98,10 @@ url-generic-parse-url valid-image-instantiator-format-p babel-fetch babel-wash sc-cite-regexp coding-system-get find-coding-system - find-coding-systems-for-charsets font-lock-set-defaults - function-max-args get-charset-property toolbar-gnus + find-coding-systems-for-charsets find-coding-systems-region + font-lock-set-defaults function-max-args get-charset-property make-symbolic-link map-extents smiley-encode-buffer + toolbar-gnus ))) (setq load-path (cons "." load-path)) diff --git a/lisp/mail-prsvr.el b/lisp/mail-prsvr.el index 82187fc..de43787 100644 --- a/lisp/mail-prsvr.el +++ b/lisp/mail-prsvr.el @@ -29,6 +29,10 @@ This variable should never be set. Instead, it should be bound by functions that wish to call mail-parse functions and let them know what the desired charset is to be.") +(defvar mail-parse-mule-charset nil + "Default MULE charset used by low-level libraries. +This variable should never be set.") + (defvar mail-parse-ignored-charsets nil "Ignored charsets used by low-level libraries. This variable should never be set. Instead, it should be bound by diff --git a/lisp/mail-source.el b/lisp/mail-source.el index 3cf7425..4500ed4 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -27,7 +27,8 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'pop3-movemail "pop3")) + (autoload 'pop3-movemail "pop3") + (autoload 'pop3-get-message-count "pop3")) (require 'format-spec) (defgroup mail-source nil @@ -40,6 +41,12 @@ This variable is a list of mail source specifiers." :group 'mail-source :type 'sexp) +(defcustom mail-source-primary-source nil + "*Primary source for incoming mail. +If non-nil, this maildrop will be checked periodically for new mail." + :group 'mail-source + :type 'sexp) + (defcustom mail-source-crash-box "~/.emacs-mail-crash-box" "File where mail will be stored while processing it." :group 'mail-source @@ -60,11 +67,24 @@ This variable is a list of mail source specifiers." :group 'mail-source :type 'boolean) +(defcustom mail-source-report-new-mail-interval 5 + "Interval in minutes between checks for new mail." + :group 'mail-source + :type 'number) + +(defcustom mail-source-idle-time-delay 5 + "Number of idle seconds to wait before checking for new mail." + :group 'mail-source + :type 'number) + ;;; Internal variables. (defvar mail-source-string "" "A dynamically bound string that says what the current mail source is.") +(defvar mail-source-new-mail-available nil + "Flag indicating when new mail is available.") + (eval-and-compile (defvar mail-source-common-keyword-map '((:plugged)) @@ -112,6 +132,7 @@ Common keywords should be listed here.") (:subtype hotmail) (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) (:password) + (:dontexpunge) (:authentication password))) "Mapping from keywords to default values. All keywords that can be used must be listed here.")) @@ -133,8 +154,8 @@ All keywords that can be used must be listed here.")) (eval-and-compile (defun mail-source-strip-keyword (keyword) - "Strip the leading colon off the KEYWORD." - (intern (substring (symbol-name keyword) 1)))) + "Strip the leading colon off the KEYWORD." + (intern (substring (symbol-name keyword) 1)))) (eval-and-compile (defun mail-source-bind-1 (type) @@ -426,7 +447,7 @@ If ARGS, PROMPT is used as an argument to `format'." (mail-source-run-script prescript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + ?s server ?P port ?u user) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) @@ -466,6 +487,9 @@ If ARGS, PROMPT is used as an argument to `format'." (push (cons from password) mail-source-password-cache))) (prog1 (mail-source-callback callback server) + ;; Update display-time's mail flag, if relevant. + (if (equal source mail-source-primary-source) + (setq mail-source-new-mail-available nil)) (mail-source-run-script postscript (format-spec-make ?p password ?t mail-source-crash-box @@ -477,6 +501,109 @@ If ARGS, PROMPT is used as an argument to `format'." mail-source-password-cache)) 0)))) +(defun mail-source-check-pop (source) + "Check whether there is new mail." + (mail-source-bind (pop source) + (let ((from (format "%s:%s:%s" server user port)) + (mail-source-string (format "pop:%s@%s" user server)) + result) + (when (eq authentication 'password) + (setq password + (or password + (cdr (assoc from mail-source-password-cache)) + (mail-source-read-passwd + (format "Password for %s at %s: " user server)))) + (unless (assoc from mail-source-password-cache) + (push (cons from password) mail-source-password-cache))) + (when server + (setenv "MAILHOST" server)) + (setq result + (cond + ;; No easy way to check whether mail is waiting for these. + (program) + (function) + ;; The default is to use pop3.el. + (t + (let ((pop3-password password) + (pop3-maildrop user) + (pop3-mailhost server) + (pop3-port port) + (pop3-authentication-scheme + (if (eq authentication 'apop) 'apop 'pass))) + (save-excursion (pop3-get-message-count)))))) + (if result + ;; Inform display-time that we have new mail. + (setq mail-source-new-mail-available (> result 0)) + ;; We nix out the password in case the error + ;; was because of a wrong password being given. + (setq mail-source-password-cache + (delq (assoc from mail-source-password-cache) + mail-source-password-cache))) + result))) + +(defun mail-source-new-mail-p () + "Handler for `display-time' to indicate when new mail is available." + ;; Only report flag setting; flag is updated on a different schedule. + mail-source-new-mail-available) + + +(defvar mail-source-report-new-mail nil) +(defvar mail-source-report-new-mail-timer nil) +(defvar mail-source-report-new-mail-idle-timer nil) + +(eval-when-compile (require 'timer)) + +(defun mail-source-start-idle-timer () + ;; Start our idle timer if necessary, so we delay the check until the + ;; user isn't typing. + (unless mail-source-report-new-mail-idle-timer + (setq mail-source-report-new-mail-idle-timer + (run-with-idle-timer + mail-source-idle-time-delay + nil + (lambda () + (setq mail-source-report-new-mail-idle-timer nil) + (mail-source-check-pop mail-source-primary-source)))) + ;; Since idle timers created when Emacs is already in the idle + ;; state don't get activated until Emacs _next_ becomes idle, we + ;; need to force our timer to be considered active now. We do + ;; this by being naughty and poking the timer internals directly + ;; (element 0 of the vector is nil if the timer is active). + (aset mail-source-report-new-mail-idle-timer 0 nil))) + +(defun mail-source-report-new-mail (arg) + "Toggle whether to report when new mail is available. +This only works when `display-time' is enabled." + (interactive "P") + (if (not mail-source-primary-source) + (error "Need to set `mail-source-primary-source' to check for new mail.")) + (let ((on (if (null arg) + (not mail-source-report-new-mail) + (> (prefix-numeric-value arg) 0)))) + (setq mail-source-report-new-mail on) + (and mail-source-report-new-mail-timer + (cancel-timer mail-source-report-new-mail-timer)) + (and mail-source-report-new-mail-idle-timer + (cancel-timer mail-source-report-new-mail-idle-timer)) + (setq mail-source-report-new-mail-timer nil) + (setq mail-source-report-new-mail-idle-timer nil) + (if on + (progn + (require 'time) + (setq display-time-mail-function #'mail-source-new-mail-p) + ;; Set up the main timer. + (setq mail-source-report-new-mail-timer + (run-at-time t (* 60 mail-source-report-new-mail-interval) + #'mail-source-start-idle-timer)) + ;; When you get new mail, clear "Mail" from the mode line. + (add-hook 'nnmail-post-get-new-mail-hook + 'display-time-event-handler) + (message "Mail check enabled")) + (setq display-time-mail-function nil) + (remove-hook 'nnmail-post-get-new-mail-hook + 'display-time-event-handler) + (message "Mail check disabled")))) + (defun mail-source-fetch-maildir (source callback) "Fetcher for maildir sources." (mail-source-bind (maildir source) @@ -546,13 +673,16 @@ If ARGS, PROMPT is used as an argument to `format'." (defun mail-source-fetch-webmail (source callback) "Fetch for webmail source." (mail-source-bind (webmail source) - (when (eq authentication 'password) - (setq password - (or password - (mail-source-read-passwd - (format "Password for %s at %s: " user subtype))))) - (webmail-fetch mail-source-crash-box subtype user password) - (mail-source-callback callback (symbol-name subtype)))) + (let ((mail-source-string (format "webmail:%s:%s" subtype user)) + (webmail-newmail-only dontexpunge) + (webmail-move-to-trash-can (not dontexpunge))) + (when (eq authentication 'password) + (setq password + (or password + (mail-source-read-passwd + (format "Password for %s at %s: " user subtype))))) + (webmail-fetch mail-source-crash-box subtype user password) + (mail-source-callback callback (symbol-name subtype))))) (provide 'mail-source) diff --git a/lisp/md5.el b/lisp/md5.el index a6c19aa..a246b1a 100644 --- a/lisp/md5.el +++ b/lisp/md5.el @@ -360,10 +360,10 @@ Returns a vector of 16 bytes containing the message digest." c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) - (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) - (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) - (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) - (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) + (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) + (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) + (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) + (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Here begins the merger with the XEmacs API and the md5.el from the URL @@ -378,7 +378,7 @@ hash of a portion of OBJECT. The optional CODING and NOERROR arguments are ignored. They are only placeholders to ensure the compatibility with XEmacsen with file-coding or Mule support." - (let ((buffer nil)) + (let ((buffer nil)) (unwind-protect (save-excursion (setq buffer (generate-new-buffer " *md5-work*")) diff --git a/lisp/message.el b/lisp/message.el index e2b1599..27c419d 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -37,6 +37,7 @@ (eval-when-compile (require 'cl)) (eval-when-compile (require 'smtp)) + (require 'mailheader) (require 'nnheader) (require 'easymenu) @@ -190,7 +191,7 @@ Otherwise, most addresses look like `angles', but they look like :group 'message-headers) (defcustom message-syntax-checks nil - ; Guess this one shouldn't be easy to customize... + ;; Guess this one shouldn't be easy to customize... "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -391,7 +392,7 @@ If t, use `message-user-organization-file'." (defcustom message-make-forward-subject-function 'message-forward-subject-author-subject - "*A list of functions that are called to generate a subject header for forwarded messages. + "*A list of functions that are called to generate a subject header for forwarded messages. The subject generated by the previous function is passed into each successive function. @@ -401,9 +402,9 @@ The provided functions are: newsgroup)), in brackets followed by the subject * message-forward-subject-fwd (Subject of article with 'Fwd:' prepended to it." - :group 'message-forwarding - :type '(radio (function-item message-forward-subject-author-subject) - (function-item message-forward-subject-fwd))) + :group 'message-forwarding + :type '(radio (function-item message-forward-subject-author-subject) + (function-item message-forward-subject-fwd))) (defcustom message-forward-as-mime t "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." @@ -762,8 +763,7 @@ these lines." :type 'message-header-lines) (defcustom message-default-news-headers "" - "*A string of header lines to be inserted in outgoing news -articles." + "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news :type 'message-header-lines) @@ -1288,10 +1288,10 @@ The cdr of ech entry is a function for applying the face to a region.") "\\([^\0-\b\n-\r\^?].*\\)? " ;; The time the message was sent. - "\\([^\0-\r \^?]+\\) +" ; day of the week - "\\([^\0-\r \^?]+\\) +" ; month - "\\([0-3]?[0-9]\\) +" ; day of month - "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day + "\\([^\0-\r \^?]+\\) +" ; day of the week + "\\([^\0-\r \^?]+\\) +" ; month + "\\([0-3]?[0-9]\\) +" ; day of month + "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day ;; Perhaps a time zone, specified by an abbreviation, or by a ;; numeric offset. @@ -1461,10 +1461,10 @@ The cdr of ech entry is a function for applying the face to a region.") (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) (error "Invalid header `%s'" (car headers))) (setq hclean (match-string 1 (car headers))) - (save-restriction - (message-narrow-to-headers) - (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) - (insert (car headers) ?\n)))) + (save-restriction + (message-narrow-to-headers) + (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) + (insert (car headers) ?\n)))) (setq headers (cdr headers)))) @@ -2120,8 +2120,8 @@ text was killed." ;; We build the table, if necessary. (when (or (not message-caesar-translation-table) (/= (aref message-caesar-translation-table ?a) (+ ?a n))) - (setq message-caesar-translation-table - (message-make-caesar-translation-table n))) + (setq message-caesar-translation-table + (message-make-caesar-translation-table n))) ;; Then we translate the region. Do it this way to retain ;; text properties. (while (< b e) @@ -2168,9 +2168,9 @@ Mail and USENET news headers are not rotated." (narrow-to-region (point) (point-max))) (let ((body (buffer-substring (point-min) (point-max)))) (unless (equal 0 (call-process-region - (point-min) (point-max) program t t)) - (insert body) - (message "%s failed" program)))))) + (point-min) (point-max) program t t)) + (insert body) + (message "%s failed" program)))))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -2571,10 +2571,12 @@ The text will also be indented the normal way." (defun message-send (&optional arg) "Send the message in the current buffer. -If `message-interactive' is non-nil, wait for success indication -or error messages, and inform user. -Otherwise any failure is reported in a message back to -the user from the mailer." +If `message-interactive' is non-nil, wait for success indication or +error messages, and inform user. +Otherwise any failure is reported in a message back to the user from +the mailer. +The usage of ARG is defined by the instance that called Message. +It should typically alter the sending method in some way or other." (interactive "P") ;; Disabled test. (when (or (buffer-modified-p) @@ -2727,10 +2729,11 @@ This sub function is for exclusive use of `message-send-mail'." (defun message-send-mail (&optional arg) (require 'mail-utils) - (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) - (case-fold-search nil) - (news (message-news-p)) - failure) + (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) + (case-fold-search nil) + (news (message-news-p)) + (message-this-is-mail t) + failure) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -2814,10 +2817,7 @@ This sub function is for exclusive use of `message-send-mail'." ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) - (list "-f" - (if (null user-mail-address) - (user-login-name) - user-mail-address))) + (list "-f" (message-make-address))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -2963,17 +2963,18 @@ This sub function is for exclusive use of `message-send-news'." (not (funcall message-send-news-function method))))) (defun message-send-news (&optional arg) - (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) - (case-fold-search nil) - (method (if (message-functionp message-post-method) - (funcall message-post-method arg) - message-post-method)) - (message-syntax-checks - (if arg - (cons '(existing-newsgroups . disabled) - message-syntax-checks) - message-syntax-checks)) - result) + (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) + (case-fold-search nil) + (method (if (message-functionp message-post-method) + (funcall message-post-method arg) + message-post-method)) + (message-syntax-checks + (if arg + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) + (message-this-is-news t) + result) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -3541,9 +3542,9 @@ If NOW, use that time instead." "Make an Organization header." (let* ((organization (when message-user-organization - (if (message-functionp message-user-organization) - (funcall message-user-organization) - message-user-organization)))) + (if (message-functionp message-user-organization) + (funcall message-user-organization) + message-user-organization)))) (save-excursion (message-set-work-buffer) (cond ((stringp organization) @@ -4592,7 +4593,7 @@ that further discussion should take place only in " (when (yes-or-no-p "Do you really want to cancel this article? ") (let (from newsgroups message-id distribution buf sender) (save-excursion - ;; Get header info. from original article. + ;; Get header info from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") @@ -5191,8 +5192,7 @@ regexp varstr." (defun message-encode-message-body () (unless message-inhibit-body-encoding (let ((mail-parse-charset (or mail-parse-charset - message-default-charset - message-posting-charset)) + message-default-charset)) (case-fold-search t) lines content-type-p) (message-goto-body) @@ -5263,4 +5263,8 @@ regexp varstr." (run-hooks 'message-load-hook) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; message.el ends here diff --git a/lisp/messcompat.el b/lisp/messcompat.el index c9f0f7d..9ffbd89 100644 --- a/lisp/messcompat.el +++ b/lisp/messcompat.el @@ -72,7 +72,7 @@ If a form, the result from the form will be used instead.") ;; Deleted the autoload cookie because this crashes in loaddefs.el. (defvar message-signature-file mail-signature-file - "*File containing the text inserted at end of message. buffer.") + "*File containing the text inserted at end of the message buffer.") (defvar message-default-headers mail-default-headers "*A string containing header lines to be inserted in outgoing messages. diff --git a/lisp/mm-bodies.el b/lisp/mm-bodies.el index 64bcac3..0901615 100644 --- a/lisp/mm-bodies.el +++ b/lisp/mm-bodies.el @@ -36,7 +36,7 @@ ;; 8bit treatment gets any char except: 0x32 - 0x7f, CR, LF, TAB, BEL, ;; BS, vertical TAB, form feed, and ^_ -(defvar mm-8bit-char-regexp "[^\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f]") +(defvar mm-7bit-chars "\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f") (defvar mm-body-charset-encoding-alist nil "Alist of MIME charsets to encodings. @@ -80,7 +80,7 @@ If no encoding was done, nil is returned." (not (mm-coding-system-equal charset buffer-file-coding-system))) (while (not (eobp)) - (if (eq (char-charset (char-after)) 'ascii) + (if (eq (mm-charset-after) 'ascii) (when start (save-restriction (narrow-to-region start (point)) @@ -101,12 +101,17 @@ If no encoding was done, nil is returned." (cond ((eq bits '7bit) bits) - ((eq charset mail-parse-charset) + ((and (not mm-use-ultra-safe-encoding) + (or (eq t (cdr message-posting-charset)) + (memq charset (cdr message-posting-charset)) + (eq charset mail-parse-charset))) bits) (t (let ((encoding (or encoding (cdr (assq charset mm-body-charset-encoding-alist)) (mm-qp-or-base64)))) + (when mm-use-ultra-safe-encoding + (setq encoding (mm-safer-encoding encoding))) (mm-encode-content-transfer-encoding encoding "text/plain") encoding))))) @@ -116,9 +121,10 @@ If no encoding was done, nil is returned." ((not (featurep 'mule)) (if (save-excursion (goto-char (point-min)) - (re-search-forward mm-8bit-char-regexp nil t)) - '8bit - '7bit)) + (skip-chars-forward mm-7bit-chars) + (eobp)) + '7bit + '8bit)) (t ;; Mule version (if (and (null (delq 'ascii @@ -128,7 +134,7 @@ If no encoding was done, nil is returned." ;;!!!Emacs 20.3. Sometimes. (save-excursion (goto-char (point-min)) - (skip-chars-forward "\0-\177") + (skip-chars-forward mm-7bit-chars) (eobp))) '7bit '8bit)))) @@ -154,8 +160,10 @@ If no encoding was done, nil is returned." (delete-region (point) (point-max)) (point)))) ((memq encoding '(7bit 8bit binary)) + ;; Do nothing. ) ((null encoding) + ;; Do nothing. ) ((memq encoding '(x-uuencode x-uue)) (funcall mm-uu-decode-function (point-min) (point-max))) @@ -179,7 +187,7 @@ If no encoding was done, nil is returned." "Decode the current article that has been encoded with ENCODING. The characters in CHARSET should then be decoded." (if (stringp charset) - (setq charset (intern (downcase charset)))) + (setq charset (intern (downcase charset)))) (if (or (not charset) (eq 'gnus-all mail-parse-ignored-charsets) (memq 'gnus-all mail-parse-ignored-charsets) @@ -208,7 +216,7 @@ The characters in CHARSET should then be decoded." (defun mm-decode-string (string charset) "Decode STRING with CHARSET." (if (stringp charset) - (setq charset (intern (downcase charset)))) + (setq charset (intern (downcase charset)))) (if (or (not charset) (eq 'gnus-all mail-parse-ignored-charsets) (memq 'gnus-all mail-parse-ignored-charsets) @@ -216,12 +224,12 @@ The characters in CHARSET should then be decoded." (setq charset mail-parse-charset)) (or (when (featurep 'mule) - (let ((mule-charset (mm-charset-to-coding-system charset))) - (if (and (not mule-charset) - (listp mail-parse-ignored-charsets) - (memq 'gnus-unknown mail-parse-ignored-charsets)) - (setq mule-charset - (mm-charset-to-coding-system mail-parse-charset))) + (let ((mule-charset (mm-charset-to-coding-system charset))) + (if (and (not mule-charset) + (listp mail-parse-ignored-charsets) + (memq 'gnus-unknown mail-parse-ignored-charsets)) + (setq mule-charset + (mm-charset-to-coding-system mail-parse-charset))) (when (and charset mule-charset (mm-multibyte-p) (or (not (eq mule-charset 'ascii)) diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 8fbef31..83f8ec4 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -28,6 +28,12 @@ (require 'gnus-mailcap) (require 'mm-bodies) +(defgroup mime-display () + "Display of MIME in mail and news articles." + :link '(custom-manual "(emacs-mime)Customization") + :group 'mail + :group 'news) + ;;; Convenience macros. (defmacro mm-handle-buffer (handle) @@ -64,7 +70,7 @@ `(list ,buffer ,type ,encoding ,undisplayer ,disposition ,description ,cache ,id)) -(defvar mm-inline-media-tests +(defcustom mm-inline-media-tests '(("image/jpeg" mm-inline-image (lambda (handle) @@ -132,32 +138,43 @@ ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) ("multipart/related" ignore identity)) - "Alist of media types/test that say whether the media types can be displayed inline.") + "Alist of media types/tests saying whether types can be displayed inline." + :type '(repeat (list (string :tag "MIME type") + (function :tag "Display function") + (function :tag "Display test"))) + :group 'mime-display) -(defvar mm-inlined-types +(defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" "application/pgp-signature") - "List of media types that are to be displayed inline.") + "List of media types that are to be displayed inline." + :type '(repeat string) + :group 'mime-display) -(defvar mm-automatic-display +(defcustom mm-automatic-display '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" "message/rfc822" "text/x-patch" "application/pgp-signature") - "A list of MIME types to be displayed automatically.") - -(defvar mm-attachment-override-types '("text/x-vcard") - "Types that should have \"attachment\" ignored if they can be displayed inline.") - -(defvar mm-inline-override-types nil - "Types that should be treated as attachments even if they can be displayed inline.") - -(defvar mm-inline-override-types nil - "Types that should be treated as attachments even if they can be displayed inline.") - -(defvar mm-automatic-external-display nil - "List of MIME type regexps that will be displayed externally automatically.") - -(defvar mm-discouraged-alternatives nil + "A list of MIME types to be displayed automatically." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-attachment-override-types '("text/x-vcard") + "Types to have \"attachment\" ignored if they can be displayed inline." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-inline-override-types nil + "Types to be treated as attachments even if they can be displayed inline." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-automatic-external-display nil + "List of MIME type regexps that will be displayed externally automatically." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-discouraged-alternatives nil "List of MIME types that are discouraged when viewing multipart/alternative. Viewing agents are supposed to view the last possible part of a message, as that is supposed to be the richest. However, users may prefer other @@ -166,7 +183,9 @@ for instance, text/html parts are very unwanted, and text/richtech are somewhat unwanted, then the value of this variable should be set to: - (\"text/html\" \"text/richtext\")") + (\"text/html\" \"text/richtext\")" + :type '(repeat string) + :group 'mime-display) (defvar mm-tmp-directory (cond ((fboundp 'temp-directory) (temp-directory)) @@ -174,8 +193,10 @@ to: ("/tmp/")) "Where mm will store its temporary files.") -(defvar mm-inline-large-images nil - "If non-nil, then all images fit in the buffer.") +(defcustom mm-inline-large-images nil + "If non-nil, then all images fit in the buffer." + :type 'boolean + :group 'mime-display) ;;; Internal variables. @@ -249,13 +270,13 @@ to: (defun mm-dissect-multipart (ctl) (goto-char (point-min)) (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) - (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) - start parts - (end (save-excursion - (goto-char (point-max)) - (if (re-search-backward close-delimiter nil t) - (match-beginning 0) - (point-max))))) + (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) + start parts + (end (save-excursion + (goto-char (point-max)) + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + (point-max))))) (while (search-forward boundary end t) (goto-char (match-beginning 0)) (when start @@ -308,88 +329,107 @@ external if displayed external." (mm-insert-inline handle (mm-get-part handle)) 'inline) (mm-display-external - handle (or method 'mailcap-save-binary-file)) - 'external))))))) + handle (or method 'mailcap-save-binary-file))))))))) (defun mm-display-external (handle method) "Display HANDLE using METHOD." - (mm-with-unibyte-buffer - (if (functionp method) - (let ((cur (current-buffer))) - (if (eq method 'mailcap-save-binary-file) - (progn - (set-buffer (generate-new-buffer "*mm*")) - (setq method nil)) - (mm-insert-part handle) - (let ((win (get-buffer-window cur t))) - (when win - (select-window win))) - (switch-to-buffer (generate-new-buffer "*mm*"))) - (buffer-disable-undo) - (mm-set-buffer-file-coding-system mm-binary-coding-system) - (insert-buffer-substring cur) + (let ((outbuf (current-buffer))) + (mm-with-unibyte-buffer + (if (functionp method) + (let ((cur (current-buffer))) + (if (eq method 'mailcap-save-binary-file) + (progn + (set-buffer (generate-new-buffer "*mm*")) + (setq method nil)) + (mm-insert-part handle) + (let ((win (get-buffer-window cur t))) + (when win + (select-window win))) + (switch-to-buffer (generate-new-buffer "*mm*"))) + (buffer-disable-undo) + (mm-set-buffer-file-coding-system mm-binary-coding-system) + (insert-buffer-substring cur) + (message "Viewing with %s" method) + (let ((mm (current-buffer)) + (non-viewer (assq 'non-viewer + (mailcap-mime-info + (mm-handle-media-type handle) t)))) + (unwind-protect + (if method + (funcall method) + (mm-save-part handle)) + (when (and (not non-viewer) + method) + (mm-handle-set-undisplayer handle mm))))) + ;; The function is a string to be executed. + (mm-insert-part handle) + (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory))) + (filename (mail-content-type-get + (mm-handle-disposition handle) 'filename)) + (mime-info (mailcap-mime-info + (mm-handle-media-type handle) t)) + (needsterm (or (assoc "needsterm" mime-info) + (assoc "needsterminal" mime-info))) + (copiousoutput (assoc "copiousoutput" mime-info)) + file buffer) + ;; We create a private sub-directory where we store our files. + (make-directory dir) + (set-file-modes dir 448) + (if filename + (setq file (expand-file-name (file-name-nondirectory filename) + dir)) + (setq file (make-temp-name (expand-file-name "mm." dir)))) + (let ((coding-system-for-write mm-binary-coding-system)) + (write-region (point-min) (point-max) file nil 'nomesg)) (message "Viewing with %s" method) - (let ((mm (current-buffer)) - (non-viewer (assq 'non-viewer - (mailcap-mime-info - (mm-handle-media-type handle) t)))) - (unwind-protect - (if method - (funcall method) - (mm-save-part handle)) - (when (and (not non-viewer) - method) - (mm-handle-set-undisplayer handle mm))))) - ;; The function is a string to be executed. - (mm-insert-part handle) - (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory))) - (filename (mail-content-type-get - (mm-handle-disposition handle) 'filename)) - (mime-info (mailcap-mime-info - (mm-handle-media-type handle) t)) - (needsterm (or (assoc "needsterm" mime-info) - (assoc "needsterminal" mime-info))) - (copiousoutput (assoc "copiousoutput" mime-info)) - process file buffer) - ;; We create a private sub-directory where we store our files. - (make-directory dir) - (set-file-modes dir 448) - (if filename - (setq file (expand-file-name (file-name-nondirectory filename) - dir)) - (setq file (make-temp-name (expand-file-name "mm." dir)))) - (let ((coding-system-for-write mm-binary-coding-system)) - (write-region (point-min) (point-max) file nil 'nomesg)) - (message "Viewing with %s" method) - (unwind-protect - (setq process - (cond (needsterm - (start-process "*display*" nil - "xterm" - "-e" shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle)))) - (copiousoutput - (start-process "*display*" + (cond (needsterm + (unwind-protect + (start-process "*display*" nil + "xterm" + "-e" shell-file-name + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (mm-handle-set-undisplayer handle (cons file buffer))) + (message "Displaying %s..." (format method file)) + 'external) + (copiousoutput + (with-current-buffer outbuf + (forward-line 1) + (mm-insert-inline + handle + (unwind-protect + (progn + (call-process shell-file-name nil (setq buffer (generate-new-buffer "*mm*")) - shell-file-name + nil shell-command-switch (mm-mailcap-command method file (mm-handle-type handle))) - (switch-to-buffer buffer)) - (t - (start-process "*display*" - (setq buffer - (generate-new-buffer "*mm*")) - shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle)))))) - (mm-handle-set-undisplayer handle (cons file buffer))) - (message "Displaying %s..." (format method file)))))) - + (if (buffer-live-p buffer) + (save-excursion + (set-buffer buffer) + (buffer-string)))) + (progn + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))) + (ignore-errors (kill-buffer buffer)))))) + 'inline) + (t + (unwind-protect + (start-process "*display*" + (setq buffer + (generate-new-buffer "*mm*")) + shell-file-name + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (mm-handle-set-undisplayer handle (cons file buffer))) + (message "Displaying %s..." (format method file)) + 'external))))))) + (defun mm-mailcap-command (method file type-list) (let ((ctl (cdr type-list)) (beg 0) @@ -418,6 +458,7 @@ external if displayed external." (while (setq handle (pop handles)) (cond ((stringp handle) + ;; Do nothing. ) ((and (listp handle) (stringp (car handle))) @@ -434,6 +475,7 @@ external if displayed external." (while (setq handle (pop handles)) (cond ((stringp handle) + ;; Do nothing. ) ((and (listp handle) (stringp (car handle))) @@ -637,6 +679,8 @@ external if displayed external." (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) (mailcap-mime-info type 'all))) (method (completing-read "Viewer: " methods))) + (when (string= method "") + (error "No method given")) (mm-display-external (copy-sequence handle) method))) (defun mm-preferred-alternative (handles &optional preferred) diff --git a/lisp/mm-encode.el b/lisp/mm-encode.el index 766f1ea..5a87160 100644 --- a/lisp/mm-encode.el +++ b/lisp/mm-encode.el @@ -38,6 +38,18 @@ If the encoding is `qp-or-base64', then either quoted-printable or base64 will be used, depending on what is more efficient.") +(defvar mm-use-ultra-safe-encoding nil + "If non-nil, use encodings aimed at Procrustean bed survival. + +This means that textual parts are encoded as quoted-printable if they +contain lines longer than 76 characters or starting with \"From \" in +the body. Non-7bit encodings (8bit, binary) are generally disallowed. +This is to reduce the probability that a broken MTA or MDA changes the +message. + +This variable should never be set directly, but bound before a call to +`mml-generate-mime' or similar functions.") + (defun mm-insert-rfc822-headers (charset encoding) "Insert text/plain headers with CHARSET and ENCODING." (insert "MIME-Version: 1.0\n") @@ -60,6 +72,14 @@ or base64 will be used, depending on what is more efficient.") "application/octet-stream" (mailcap-extension-to-mime (match-string 0 file)))) +(defun mm-safer-encoding (encoding) + "Return a safer but similar encoding." + (cond + ((memq encoding '(7bit 8bit quoted-printable)) 'quoted-printable) + ;; The remaing encodings are binary and base64 (and perhaps some + ;; non-standard ones), which are both turned into base64. + (t 'base64))) + (defun mm-encode-content-transfer-encoding (encoding &optional type) (cond ((eq encoding 'quoted-printable) @@ -75,8 +95,10 @@ or base64 will be used, depending on what is more efficient.") (message "Error while decoding: %s" error) nil))) ((memq encoding '(7bit 8bit binary)) + ;; Do nothing. ) ((null encoding) + ;; Do nothing. ) ((functionp encoding) (ignore-errors (funcall encoding (point-min) (point-max)))) @@ -119,9 +141,13 @@ The encoding used is returned." (while rules (when (string-match (caar rules) type) (throw 'found - (if (eq (cadar rules) 'qp-or-base64) - (mm-qp-or-base64) - (cadar rules)))) + (let ((encoding + (if (eq (cadar rules) 'qp-or-base64) + (mm-qp-or-base64) + (cadar rules)))) + (if mm-use-ultra-safe-encoding + (mm-safer-encoding encoding) + encoding)))) (pop rules))))) (defun mm-qp-or-base64 () diff --git a/lisp/mm-util.el b/lisp/mm-util.el index 8006fec..bf94df4 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -24,6 +24,8 @@ ;;; Code: +(require 'mail-prsvr) + (defvar mm-mime-mule-charset-alist '((us-ascii ascii) (iso-8859-1 latin-iso8859-1) @@ -65,7 +67,6 @@ chinese-cns11643-7)) "Alist of MIME-charset/MULE-charsets.") - (eval-and-compile (mapcar (lambda (elem) @@ -208,6 +209,36 @@ used as the line break code type of the coding system." (or (get-charset-property charset 'prefered-coding-system) (get-charset-property charset 'preferred-coding-system))) +(defun mm-charset-after (&optional pos) + "Return charset of a character in current buffer at position POS. +If POS is nil, it defauls to the current point. +If POS is out of range, the value is nil. +If the charset is `composition', return the actual one." + (let ((charset (cond + ((fboundp 'charset-after) + (charset-after pos)) + ((fboundp 'char-charset) + (char-charset (char-after pos))) + ((< (mm-char-int (char-after pos)) 128) + 'ascii) + (mail-parse-mule-charset ;; cached mule-charset + mail-parse-mule-charset) + ((boundp 'current-language-environment) + (let ((entry (assoc current-language-environment + language-info-alist))) + (setq mail-parse-mule-charset + (or (car (last (assq 'charset entry))) + 'latin-iso8859-1)))) + (t ;; figure out the charset + (setq mail-parse-mule-charset + (or (car (last (assq mail-parse-charset + mm-mime-mule-charset-alist))) + 'latin-iso8859-1)))))) + (if (eq charset 'composition) + (let ((p (or pos (point)))) + (cadr (find-charset-region p (1+ p)))) + charset))) + (defun mm-mime-charset (charset) "Return the MIME charset corresponding to the MULE CHARSET." (if (fboundp 'coding-system-get) @@ -223,18 +254,26 @@ used as the line break code type of the coding system." ;; This is for XEmacs. (mm-mule-charset-to-mime-charset charset))) +(defun mm-delete-duplicates (list) + "Simple substitute for CL `delete-duplicates', testing with `equal'." + (let (result head) + (while list + (setq head (car list)) + (setq list (delete head list)) + (setq result (cons head result))) + (nreverse result))) + (defun mm-find-mime-charset-region (b e) "Return the MIME charsets needed to encode the region between B and E." - (let ((charsets - (mapcar 'mm-mime-charset - (delq 'ascii - (mm-find-charset-region b e))))) + (let ((charsets (mapcar 'mm-mime-charset + (delq 'ascii + (mm-find-charset-region b e))))) (when (memq 'iso-2022-jp-2 charsets) (setq charsets (delq 'iso-2022-jp charsets))) - (delete-duplicates charsets) + (setq charsets (mm-delete-duplicates charsets)) (if (and (> (length charsets) 1) - (fboundp 'find-coding-systems-for-charsets) - (memq 'utf-8 (find-coding-systems-for-charsets charsets))) + (fboundp 'find-coding-systems-region) + (memq 'utf-8 (find-coding-systems-region b e))) '(utf-8) charsets))) @@ -289,12 +328,28 @@ See also `with-temp-file' and `with-output-to-string'." (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0) (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body)) +(defmacro mm-with-unibyte (&rest forms) + "Set default `enable-multibyte-characters' to `nil', eval the FORMS." + (let ((multibyte (make-symbol "multibyte"))) + `(if (or (string-match "XEmacs\\|Lucid" emacs-version) + (not (boundp 'enable-multibyte-characters))) + (progn ,@forms) + (let ((,multibyte (default-value 'enable-multibyte-characters))) + (unwind-protect + (progn + (setq-default enable-multibyte-characters nil) + ,@forms) + (setq-default enable-multibyte-characters ,multibyte)))))) +(put 'mm-with-unibyte 'lisp-indent-function 0) +(put 'mm-with-unibyte 'edebug-form-spec '(body)) + (defun mm-find-charset-region (b e) "Return a list of charsets in the region." (cond ((and (mm-multibyte-p) (fboundp 'find-charset-region)) - (find-charset-region b e)) + ;; Remove composition since the base charsets have been included. + (delq 'composition (find-charset-region b e))) ((not (boundp 'current-language-environment)) (save-excursion (save-restriction @@ -303,19 +358,24 @@ See also `with-temp-file' and `with-output-to-string'." (skip-chars-forward "\0-\177") (if (eobp) '(ascii) - (delq nil (list 'ascii mail-parse-charset)))))) + (delq nil (list 'ascii + (or (car (last (assq mail-parse-charset + mm-mime-mule-charset-alist))) + 'latin-iso8859-1))))))) (t ;; We are in a unibyte buffer, so we futz around a bit. (save-excursion (save-restriction (narrow-to-region b e) (goto-char (point-min)) - (let ((entry (assoc (capitalize current-language-environment) + (let ((entry (assoc current-language-environment language-info-alist))) (skip-chars-forward "\0-\177") (if (eobp) '(ascii) - (list 'ascii (car (last (assq 'charset entry))))))))))) + (delq nil (list 'ascii + (or (car (last (assq 'charset entry))) + 'latin-iso8859-1)))))))))) (defun mm-read-charset (prompt) "Return a charset." diff --git a/lisp/mm-uu.el b/lisp/mm-uu.el index 4f66013..d5bbaac 100644 --- a/lisp/mm-uu.el +++ b/lisp/mm-uu.el @@ -1,10 +1,10 @@ ;;; mm-uu.el -- Return uu stuffs as mm handles -;; Copyright (c) 1998,99 by Shenghuo Zhu +;; Copyright (c) 1998,99 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu -;; Keywords: postscript uudecode binhex shar forward +;; Keywords: postscript uudecode binhex shar forward news -;; This file is part of pgnus. +;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -155,7 +155,7 @@ To disable dissecting shar codes, for instance, add (let ((nnheader-file-name-translation-alist '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) (nnheader-translate-file-chars (match-string 1)))))) - (forward-line) ;; in case of failure + (forward-line);; in case of failure (setq start-char-1 (point)) (setq end-line (symbol-value (intern (concat "mm-uu-" (symbol-name type) @@ -172,48 +172,48 @@ To disable dissecting shar codes, for instance, add (if (> start-char text-start) (push (mm-make-handle (mm-uu-copy-to-buffer text-start start-char) - text-plain-type) + text-plain-type) result)) (push (cond ((eq type 'postscript) (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - '("application/postscript"))) + '("application/postscript"))) ((eq type 'forward) (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1) '("message/rfc822" (charset . gnus-decoded)))) ((eq type 'uu) (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - (list (or (and file-name - (string-match "\\.[^\\.]+$" file-name) - (mailcap-extension-to-mime - (match-string 0 file-name))) - "application/octet-stream")) - 'x-uuencode nil - (if (and file-name (not (equal file-name ""))) - (list mm-dissect-disposition - (cons 'filename file-name))))) + (list (or (and file-name + (string-match "\\.[^\\.]+$" file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-uuencode nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) ((eq type 'binhex) (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - (list (or (and file-name - (string-match "\\.[^\\.]+$" file-name) - (mailcap-extension-to-mime - (match-string 0 file-name))) - "application/octet-stream")) - 'x-binhex nil - (if (and file-name (not (equal file-name ""))) - (list mm-dissect-disposition - (cons 'filename file-name))))) + (list (or (and file-name + (string-match "\\.[^\\.]+$" file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-binhex nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) ((eq type 'shar) (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - '("application/x-shar")))) + '("application/x-shar")))) result) (setq text-start end-char)))) (when result (if (> (point-max) (1+ text-start)) (push (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) - text-plain-type) + text-plain-type) result)) (setq result (cons "multipart/mixed" (nreverse result)))) result))) diff --git a/lisp/mm-view.el b/lisp/mm-view.el index f076c2e..6076bb5 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -23,6 +23,7 @@ ;;; Code: +(eval-when-compile (require 'cl)) (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) @@ -109,10 +110,11 @@ `(lambda () (let (buffer-read-only) (if (functionp 'remove-specifier) - (mapc (lambda (prop) - (remove-specifier - (face-property 'default prop) (current-buffer))) - '(background background-pixmap foreground))) + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) + (current-buffer))) + '(background background-pixmap foreground))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) ((or (equal type "enriched") @@ -173,7 +175,7 @@ (mm-enable-multibyte) (let (handles) (let (gnus-article-mime-handles) - ;; Double decode problem may happen. See mm-inline-message. + ;; Double decode problem may happen. See mm-inline-message. (run-hooks 'gnus-article-decode-hook) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) @@ -218,12 +220,13 @@ handle `(lambda () (let (buffer-read-only) - (ignore-errors - ;; This is only valid on XEmacs. - (mapc (lambda (prop) - (remove-specifier - (face-property 'default prop) (current-buffer))) - '(background background-pixmap foreground))) + (condition-case nil + ;; This is only valid on XEmacs. + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) (current-buffer))) + '(background background-pixmap foreground)) + (error nil)) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) (defun mm-display-patch-inline (handle) diff --git a/lisp/mml.el b/lisp/mml.el index 9203465..320f6aa 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -32,8 +32,7 @@ (autoload 'message-make-message-id "message")) (defvar mml-generate-multipart-alist - '(("signed" . rfc2015-generate-signed-multipart) - ("encrypted" . rfc2015-generate-encrypted-multipart)) + nil "*Alist of multipart generation functions. Each entry has the form (NAME . FUNCTION), where @@ -64,6 +63,13 @@ suggestion each time. The function is called with one parameter, which is a number that says how many times the function has been called for this message.") +(defvar mml-confirmation-set nil + "A list of symbols, each of which disables some warning. +`unknown-encoding': always send messages contain characters with +unknown encoding; `use-ascii': always use ASCII for those characters +with unknown encoding; `multipart': always send messages with more than +one charsets.") + (defun mml-parse () "Parse the current buffer as an MML document." (goto-char (point-min)) @@ -76,7 +82,7 @@ called for this message.") (defun mml-parse-1 () "Parse the current buffer as an MML document." - (let (struct tag point contents charsets warn) + (let (struct tag point contents charsets warn use-ascii) (while (and (not (eobp)) (not (looking-at "<#/multipart"))) (cond @@ -93,12 +99,23 @@ called for this message.") (setq point (point) contents (mml-read-part) charsets (mm-find-mime-charset-region point (point))) + (when (memq nil charsets) + (if (or (memq 'unknown-encoding mml-confirmation-set) + (y-or-n-p + "Warning: You message contains characters with unknown encoding. Really send?")) + (if (setq use-ascii + (or (memq 'use-ascii mml-confirmation-set) + (y-or-n-p "Use ASCII as charset?"))) + (setq charsets (delq nil charsets)) + (setq warn nil)) + (error "Edit your message to remove those characters"))) (if (< (length charsets) 2) (push (nconc tag (list (cons 'contents contents))) struct) (let ((nstruct (mml-parse-singlepart-with-multiple-charsets - tag point (point)))) + tag point (point) use-ascii))) (when (and warn + (not (memq 'multipart mml-confirmation-set)) (not (y-or-n-p (format @@ -110,17 +127,20 @@ called for this message.") (forward-line 1)) (nreverse struct))) -(defun mml-parse-singlepart-with-multiple-charsets (orig-tag beg end) +(defun mml-parse-singlepart-with-multiple-charsets + (orig-tag beg end &optional use-ascii) (save-excursion (narrow-to-region beg end) (goto-char (point-min)) - (let ((current (mm-mime-charset (char-charset (following-char)))) + (let ((current (or (mm-mime-charset (mm-charset-after)) + (and use-ascii 'us-ascii))) charset struct space newline paragraph) (while (not (eobp)) (cond ;; The charset remains the same. - ((or (eq (setq charset (mm-mime-charset - (char-charset (following-char)))) 'us-ascii) + ((or (eq (setq charset (mm-mime-charset (mm-charset-after))) + 'us-ascii) + (and use-ascii (not charset)) (eq charset current))) ;; The initial charset was ascii. ((eq current 'us-ascii) @@ -596,7 +616,7 @@ called for this message.") (format "Content type (default %s): " default) (mapcar 'list - (delete-duplicates + (mm-delete-duplicates (nconc (mapcar (lambda (m) (cdr m)) mailcap-mime-extensions) @@ -613,8 +633,7 @@ called for this message.") nil type))) (cdr l)))) - mailcap-mime-data))) - :test 'equal))))) + mailcap-mime-data)))))))) (if (not (equal string "")) string default))) @@ -706,35 +725,41 @@ TYPE is the MIME type to use." (defun mml-insert-multipart (&optional type) (interactive (list (completing-read "Multipart type (default mixed): " - '(("mixed") ("alternative") ("digest") ("parallel") - ("signed") ("encrypted")) - nil nil "mixed"))) + '(("mixed") ("alternative") ("digest") ("parallel") + ("signed") ("encrypted")) + nil nil "mixed"))) (or type (setq type "mixed")) (mml-insert-empty-tag "multipart" 'type type) (forward-line -1)) +(defun mml-insert-part (&optional type) + (interactive + (list (mml-minibuffer-read-type ""))) + (mml-insert-tag 'part 'type type 'disposition "inline") + (forward-line -1)) + (defun mml-preview (&optional raw) - "Display current buffer with Gnus, in a new buffer. + "Display current buffer with Gnus, in a new buffer. If RAW, don't highlight the article." - (interactive "P") - (let ((buf (current-buffer))) - (switch-to-buffer (get-buffer-create - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) - (erase-buffer) - (insert-buffer buf) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t) - (replace-match "\n")) - (mml-to-mime) - (unless raw - (run-hooks 'gnus-article-decode-hook) - (let ((gnus-newsgroup-name "dummy")) - (gnus-article-prepare-display))) - (fundamental-mode) - (setq buffer-read-only t) - (goto-char (point-min)))) + (interactive "P") + (let ((buf (current-buffer))) + (switch-to-buffer (get-buffer-create + (concat (if raw "*Raw MIME preview of " + "*MIME preview of ") (buffer-name)))) + (erase-buffer) + (insert-buffer buf) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (replace-match "\n")) + (mml-to-mime) + (unless raw + (run-hooks 'gnus-article-decode-hook) + (let ((gnus-newsgroup-name "dummy")) + (gnus-article-prepare-display))) + (fundamental-mode) + (setq buffer-read-only t) + (goto-char (point-min)))) (defun mml-validate () "Validate the current MML document." diff --git a/lisp/nnagent.el b/lisp/nnagent.el index ed62850..d551c9e 100644 --- a/lisp/nnagent.el +++ b/lisp/nnagent.el @@ -58,13 +58,18 @@ (nnoo-define-basics nnagent) +(defun nnagent-server (server) + (and server (format "%s+%s" (car gnus-command-method) server))) + (deffoo nnagent-open-server (server &optional defs) (setq defs `((nnagent-directory ,(gnus-agent-directory)) (nnagent-active-file ,(gnus-agent-lib-file "active")) (nnagent-newsgroups-file ,(gnus-agent-lib-file "newsgroups")) (nnagent-get-new-mail nil))) - (nnoo-change-server 'nnagent server defs) + (nnoo-change-server 'nnagent + (nnagent-server server) + defs) (let ((dir (gnus-agent-directory)) err) (cond @@ -121,6 +126,72 @@ (append-to-file (point-min) (point-max) (gnus-agent-lib-file "flags"))) nil) +(deffoo nnagent-request-group (group &optional server dont-check) + (nnoo-parent-function 'nnagent 'nnml-request-group + (list group (nnagent-server server) dont-check))) + +(deffoo nnagent-close-group (group &optional server) + (nnoo-parent-function 'nnagent 'nnml-close-group + (list group (nnagent-server server)))) + +(deffoo nnagent-request-accept-article (group &optional server last) + (nnoo-parent-function 'nnagent 'nnml-request-accept-article + (list group (nnagent-server server) last))) + +(deffoo nnagent-request-article (id &optional group server buffer) + (nnoo-parent-function 'nnagent 'nnml-request-article + (list id group (nnagent-server server) buffer))) + +(deffoo nnagent-request-create-group (group &optional server args) + (nnoo-parent-function 'nnagent 'nnml-request-create-group + (list group (nnagent-server server) args))) + +(deffoo nnagent-request-delete-group (group &optional force server) + (nnoo-parent-function 'nnagent 'nnml-request-delete-group + (list group force (nnagent-server server)))) + +(deffoo nnagent-request-expire-articles (articles group &optional server force) + (nnoo-parent-function 'nnagent 'nnml-request-expire-articles + (list articles group (nnagent-server server) force))) + +(deffoo nnagent-request-list (&optional server) + (nnoo-parent-function 'nnagent 'nnml-request-list + (list (nnagent-server server)))) + +(deffoo nnagent-request-list-newsgroups (&optional server) + (nnoo-parent-function 'nnagent 'nnml-request-list-newsgroups + (list (nnagent-server server)))) + +(deffoo nnagent-request-move-article + (article group server accept-form &optional last) + (nnoo-parent-function 'nnagent 'nnml-request-move-article + (list article group (nnagent-server server) + accept-form last))) + +(deffoo nnagent-request-rename-group (group new-name &optional server) + (nnoo-parent-function 'nnagent 'nnml-request-rename-group + (list group new-name (nnagent-server server)))) + +(deffoo nnagent-request-scan (&optional group server) + (nnoo-parent-function 'nnagent 'nnml-request-scan + (list group (nnagent-server server)))) + +(deffoo nnagent-retrieve-headers (sequence &optional group server fetch-old) + (nnoo-parent-function 'nnagent 'nnml-retrieve-headers + (list sequence group (nnagent-server server) fetch-old))) + +(deffoo nnagent-set-status (article name value &optional group server) + (nnoo-parent-function 'nnagent 'nnml-set-status + (list article name value group (nnagent-server server)))) + +(deffoo nnagent-server-opened (&optional server) + (nnoo-parent-function 'nnagent 'nnml-server-opened + (list (nnagent-server server)))) + +(deffoo nnagent-status-message (&optional server) + (nnoo-parent-function 'nnagent 'nnml-status-message + (list (nnagent-server server)))) + ;; Use nnml functions for just about everything. (nnoo-import nnagent (nnml)) diff --git a/lisp/nnbabyl.el b/lisp/nnbabyl.el index 3d5c5b9..0b6d87b 100644 --- a/lisp/nnbabyl.el +++ b/lisp/nnbabyl.el @@ -30,6 +30,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (condition-case nil (require 'rmail) @@ -260,7 +261,7 @@ (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented.")) (deffoo nnbabyl-request-expire-articles - (articles newsgroup &optional server force) + (articles newsgroup &optional server force) (nnbabyl-possibly-change-newsgroup newsgroup server) (let* ((is-old t) rest) @@ -296,7 +297,7 @@ (nconc rest articles)))) (deffoo nnbabyl-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last) (let ((buf (get-buffer-create " *nnbabyl move*")) result) (and @@ -432,9 +433,9 @@ (widen) (narrow-to-region (save-excursion - (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) - (goto-char (point-min)) - (end-of-line)) + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) (if leave-delim (progn (forward-line 1) (point)) (match-beginning 0))) (progn @@ -558,10 +559,10 @@ (nnbabyl-create-mbox) (unless (and nnbabyl-mbox-buffer - (buffer-name nnbabyl-mbox-buffer) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) - (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) + (buffer-name nnbabyl-mbox-buffer) + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) ;; This buffer has changed since we read it last. Possibly. (save-excursion (let ((delim (concat "^" nnbabyl-mail-delimiter)) diff --git a/lisp/nndb.el b/lisp/nndb.el index 8b71f5d..4868f01 100644 --- a/lisp/nndb.el +++ b/lisp/nndb.el @@ -77,7 +77,7 @@ "*The program used to put a message in an NNDB group.") (defvoo nndb-server-side-expiry nil - "If t, expiry calculation will occur on the server side") + "If t, expiry calculation will occur on the server side.") (defvoo nndb-set-expire-date-on-mark nil "If t, the expiry date for a given article will be set to the time @@ -146,7 +146,7 @@ article was posted to nndb") (nntp-send-command nil "X-TOUCH" article)) (deffoo nndb-request-update-mark - (group article mark) + (group article mark) "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) (nndb-touch-article group article)) @@ -293,8 +293,7 @@ Optional LAST is ignored." (list art))) (deffoo nndb-request-replace-article (article group buffer) - "ARTICLE is the number of the article in GROUP to be replaced -with the contents of the BUFFER." + "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." (set-buffer buffer) (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) (nnheader-insert "") diff --git a/lisp/nndoc.el b/lisp/nndoc.el index 9758f61..8a1dea3 100644 --- a/lisp/nndoc.el +++ b/lisp/nndoc.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'message) (require 'nnmail) @@ -292,7 +293,6 @@ from the document.") (setq nndoc-dissection-alist nil) (save-excursion (set-buffer nndoc-current-buffer) - (mm-enable-multibyte) (erase-buffer) (if (stringp nndoc-address) (nnheader-insert-file-contents nndoc-address) @@ -557,10 +557,7 @@ from the document.") (defun nndoc-transform-lanl-gov-announce (article) (goto-char (point-max)) (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t) - (replace-match "\n\nGet it at \\1 (\\2)" t nil)) - ;; (when (re-search-backward "^\\\\\\\\$" nil t) - ;; (replace-match "" t t)) - ) + (replace-match "\n\nGet it at \\1 (\\2)" t nil))) (defun nndoc-generate-lanl-gov-head (article) (let ((entry (cdr (assq article nndoc-dissection-alist))) @@ -578,8 +575,7 @@ from the document.") (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)" nil t) (setq subject (concat (match-string 1) subject)) - (setq from (concat (match-string 2) " <" e-mail ">")))) - )) + (setq from (concat (match-string 2) " <" e-mail ">")))))) (while (and from (string-match "(\[^)\]*)" from)) (setq from (replace-match "" t t from))) (insert "From: " (or from "unknown") diff --git a/lisp/nndraft.el b/lisp/nndraft.el index 0e765fc..487ffc1 100644 --- a/lisp/nndraft.el +++ b/lisp/nndraft.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nnmail) (require 'gnus-start) @@ -134,8 +135,9 @@ info (gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft "")) (nndraft-articles) t)) - (let (marks) - (when (setq marks (nth 3 info)) + (let ((marks (nth 3 info))) + (when marks + ;; Nix out all marks except the `unsend'-able article marks. (setcar (nthcdr 3 info) (if (assq 'unsend marks) (list (assq 'unsend marks)) @@ -149,7 +151,7 @@ (nndraft-possibly-change-group group) (let ((gnus-verbose-backends nil) (buf (current-buffer)) - article file) + article file) (with-temp-buffer (insert-buffer-substring buf) (setq article (nndraft-request-accept-article diff --git a/lisp/nneething.el b/lisp/nneething.el index 3caee7b..fdf72e3 100644 --- a/lisp/nneething.el +++ b/lisp/nneething.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nnmail) (require 'nnoo) @@ -106,7 +107,7 @@ included.") (and large (zerop (% count 20)) (nnheader-message 5 "nneething: Receiving headers... %d%%" - (/ (* count 100) number)))) + (/ (* count 100) number)))) (when large (nnheader-message 5 "nneething: Receiving headers...done")) @@ -294,8 +295,7 @@ included.") (concat "Lines: " (int-to-string (count-lines (point-min) (point-max))) "\n")) - "") - ))) + "")))) (defun nneething-from-line (uid &optional file) "Return a From header based of UID." diff --git a/lisp/nnfolder.el b/lisp/nnfolder.el index c942f6f..9c4b5b3 100644 --- a/lisp/nnfolder.el +++ b/lisp/nnfolder.el @@ -40,27 +40,29 @@ "The name of the nnfolder directory.") (defvoo nnfolder-active-file - (nnheader-concat nnfolder-directory "active") + (nnheader-concat nnfolder-directory "active") "The name of the active file.") ;; I renamed this variable to something more in keeping with the general GNU ;; style. -SLB (defvoo nnfolder-ignore-active-file nil - "If non-nil, causes nnfolder to do some extra work in order to determine -the true active ranges of an mbox file. Note that the active file is still -saved, but it's values are not used. This costs some extra time when -scanning an mbox when opening it.") + "If non-nil, the active file is ignores. +This causes nnfolder to do some extra work in order to determine the +true active ranges of an mbox file. Note that the active file is +still saved, but it's values are not used. This costs some extra time +when scanning an mbox when opening it.") (defvoo nnfolder-distrust-mbox nil - "If non-nil, causes nnfolder to not trust the user with respect to -inserting unaccounted for mail in the middle of an mbox file. This can greatly -slow down scans, which now must scan the entire file for unmarked messages. -When nil, scans occur forward from the last marked message, a huge -time saver for large mailboxes.") + "If non-nil, the folder will be distrusted. +This means that nnfolder will not trust the user with respect to +inserting unaccounted for mail in the middle of an mbox file. This +can greatly slow down scans, which now must scan the entire file for +unmarked messages. When nil, scans occur forward from the last marked +message, a huge time saver for large mailboxes.") (defvoo nnfolder-newsgroups-file - (concat (file-name-as-directory nnfolder-directory) "newsgroups") + (concat (file-name-as-directory nnfolder-directory) "newsgroups") "Mail newsgroups description file.") (defvoo nnfolder-get-new-mail t @@ -320,7 +322,7 @@ If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.") numbers)))) (deffoo nnfolder-request-expire-articles - (articles newsgroup &optional server force) + (articles newsgroup &optional server force) (nnfolder-possibly-change-group newsgroup server) (let* ((is-old t) ;; The articles we have deleted so far. @@ -343,12 +345,12 @@ If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.") nil t)) (forward-sexp) (when (setq is-old - (nnmail-expired-article-p - newsgroup - (buffer-substring - (point) (progn (end-of-line) (point))) - force nnfolder-inhibit-expiry)) - (nnheader-message 5 "Deleting article %d..." + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) + force nnfolder-inhibit-expiry)) + (nnheader-message 5 "Deleting article %d..." (car maybe-expirable) newsgroup) (nnfolder-delete-mail) ;; Must remember which articles were actually deleted diff --git a/lisp/nnheader.el b/lisp/nnheader.el index 24a31ae..c75bde2 100644 --- a/lisp/nnheader.el +++ b/lisp/nnheader.el @@ -29,6 +29,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'mail-utils) (require 'mime) @@ -46,13 +47,13 @@ on your system, you could say something like: \(setq nnheader-file-name-translation-alist '((?: . ?_)))") (eval-and-compile - (autoload 'nnmail-message-id "nnmail") - (autoload 'mail-position-on-field "sendmail") - (autoload 'message-remove-header "message") - (autoload 'cancel-function-timers "timers") - (autoload 'gnus-point-at-eol "gnus-util") - (autoload 'gnus-delete-line "gnus-util") - (autoload 'gnus-buffer-live-p "gnus-util")) + (autoload 'nnmail-message-id "nnmail") + (autoload 'mail-position-on-field "sendmail") + (autoload 'message-remove-header "message") + (autoload 'cancel-function-timers "timers") + (autoload 'gnus-point-at-eol "gnus-util") + (autoload 'gnus-delete-line "gnus-util") + (autoload 'gnus-buffer-live-p "gnus-util")) ;;; Header access macros. @@ -297,7 +298,9 @@ on your system, you could say something like: '(prog1 (if (eq (char-after) ?\t) 0 - (let ((num (ignore-errors (read (current-buffer))))) + (let ((num (condition-case nil + (read (current-buffer)) + (error nil)))) (if (numberp num) num 0))) (unless (eobp) (search-forward "\t" eol 'move)))) @@ -806,7 +809,9 @@ If FULL, translate everything." (if full ;; Do complete translation. (setq leaf (copy-sequence file) - path "") + path "" + i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1))) + 2 0)) ;; We translate -- but only the file name. We leave the directory ;; alone. (if (string-match "/[^/]+\\'" file) @@ -837,7 +842,7 @@ The first string in ARGS can be a format string." "Get the most recent report from BACKEND." (condition-case () (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" - backend)))) + backend)))) (error (nnheader-message 5 "")))) (defun nnheader-insert (format &rest args) diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 8cd98f2..ae77d1d 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -36,9 +36,8 @@ ;; ;; Todo, minor things: ;; +;; o Don't require half of Gnus -- backends should be standalone ;; o Support escape characters in `message-tokenize-header' -;; o Split-fancy. -;; o Support NOV nnmail-extra-headers. ;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B) ;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow) ;; o Split up big fetches (1,* header especially) in smaller chunks @@ -54,7 +53,7 @@ ;; o IMAP2BIS compatibility? (RFC2061) ;; o ACAP stuff (perhaps a different project, would be nice to ACAPify ;; .newsrc.eld) -;; o What about Gnus's article editing, can we support it? +;; o What about Gnus's article editing, can we support it? NO! ;; o Use \Draft to support the draft group?? ;;; Code: @@ -66,7 +65,6 @@ (require 'nnmail) (require 'nnheader) (require 'gnus) -(require 'gnus-async) (require 'gnus-range) (require 'gnus-start) (require 'gnus-int) @@ -114,14 +112,21 @@ element in each \"rule\" is the name of the IMAP mailbox, and the second is a regexp that nnimap will try to match on the header to find a fit. -The first element can also be a list. In that case, the first element +The first element can also be a list. In that case, the first element is the server the second element is the group on that server in which the matching article will be stored. The second element can also be a function. In that case, it will be called narrowed to the headers with the first element of the rule as the argument. It should return a non-nil value if it thinks that the -mail belongs in that group.") +mail belongs in that group. + +This variable can also have a function as its value, the function will +be called with the headers narrowed and should return a group where it +thinks the article should be splitted to.") + +(defvar nnimap-split-fancy nil + "Like `nnmail-split-fancy', which see.") ;; Authorization / Privacy variables @@ -136,7 +141,7 @@ handle. Change this if -1) you want to connect with SSL. The SSL integration with IMAP is +1) you want to connect with SSL. The SSL integration with IMAP is brain-dead so you'll have to tell it specifically. 2) your server is more capable than your environment -- i.e. your @@ -160,13 +165,14 @@ Kerberos. Possible choices: kerberos4, cram-md5, login, anonymous.") (defvoo nnimap-directory (nnheader-concat gnus-directory "overview/") - "Directory to keep NOV cache files for nnimap groups. See also -`nnimap-nov-file-name'.") + "Directory to keep NOV cache files for nnimap groups. +See also `nnimap-nov-file-name'.") (defvoo nnimap-nov-file-name "nnimap." - "NOV cache base filename. The group name and -`nnimap-nov-file-name-suffix' will be appended. A typical complete -file name would be ~/News/overview/nnimap.pdc.INBOX.ding.nov, or + "NOV cache base filename. +The group name and `nnimap-nov-file-name-suffix' will be appended. A +typical complete file name would be +~/News/overview/nnimap.pdc.INBOX.ding.nov, or ~/News/overview/nnimap/pdc/INBOX/ding/nov if `nnmail-use-long-file-names' is nil") @@ -174,13 +180,14 @@ file name would be ~/News/overview/nnimap.pdc.INBOX.ding.nov, or "Suffix for NOV cache base filename.") (defvoo nnimap-nov-is-evil nil - "If non-nil, nnimap will never generate or use a local nov database -for this backend. Using nov databases will speed up header fetching -considerably. Unlike other backends, you do not need to take special -care if you flip this variable.") + "If non-nil, nnimap will never generate or use a local nov database for this backend. +Using nov databases will speed up header fetching considerably. +Unlike other backends, you do not need to take special care if you +flip this variable.") (defvoo nnimap-expunge-on-close 'always ; 'ask, 'never - "When a IMAP group with articles marked for deletion is closed, this + "Whether to expunge a group when it is closed. +When a IMAP group with articles marked for deletion is closed, this variable determine if nnimap should actually remove the articles or not. @@ -192,11 +199,11 @@ When setting this variable to `never', you can only expunge articles by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.") (defvoo nnimap-list-pattern "*" - "A string LIMIT or list of strings with mailbox wildcards used to -limit available groups. Se below for available wildcards. + "A string LIMIT or list of strings with mailbox wildcards used to limit available groups. +See below for available wildcards. The LIMIT string can be a cons cell (REFERENCE . LIMIT), where -REFERENCE will be passed as the first parameter to LIST/LSUB. The +REFERENCE will be passed as the first parameter to LIST/LSUB. The semantics of this are server specific, on the University of Washington server you can specify a directory. @@ -207,8 +214,7 @@ There are two wildcards * and %. * matches everything, % matches everything in the current hierarchy.") (defvoo nnimap-news-groups nil - "IMAP support a news-like mode, also known as bulletin board mode, -where replies is sent via IMAP instead of SMTP. + "IMAP support a news-like mode, also known as bulletin board mode, where replies is sent via IMAP instead of SMTP. This variable should contain a regexp matching groups where you wish replies to be stored to the mailbox directly. @@ -219,12 +225,12 @@ Example: This will match all groups not beginning with \"INBOX\". Note that there is nothing technically different between mail-like and -news-like mailboxes. If you wish to have a group with todo items or +news-like mailboxes. If you wish to have a group with todo items or similar which you wouldn't want to set up a mailing list for, you can use this to make replies go directly to the group.") (defvoo nnimap-server-address nil - "Obsolete. Use `nnimap-address'.") + "Obsolete. Use `nnimap-address'.") (defcustom nnimap-authinfo-file "~/.authinfo" "Authorization information for IMAP servers. In .netrc format." @@ -244,8 +250,7 @@ use this to make replies go directly to the group.") (string :format "Password: %v"))))))) (defcustom nnimap-prune-cache t - "If non-nil, nnimap check wheter articles still exist on server -before using data stored in NOV cache." + "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache." :type 'boolean) (defvar nnimap-request-list-method 'imap-mailbox-list @@ -255,7 +260,7 @@ restrict visible folders.") ;; Internal variables: -(defvar nnimap-debug nil) ;; "*nnimap-debug*") +(defvar nnimap-debug nil);; "*nnimap-debug*") (defvar nnimap-current-move-server nil) (defvar nnimap-current-move-group nil) (defvar nnimap-current-move-article nil) @@ -267,28 +272,16 @@ restrict visible folders.") "Gnus callback the nnimap asynchronous callback should call.") (defvar nnimap-callback-buffer nil "Which buffer the asynchronous article prefetch callback should work in.") - -;; Various server variables. +(defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. +(defvar nnimap-current-server nil) ;; Current server +(defvar nnimap-server-buffer nil) ;; Current servers' buffer -;; Internal variables. -(defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. -(defvar nnimap-current-server nil) ;; Current server -(defvar nnimap-server-buffer nil) ;; Current servers' buffer (nnoo-define-basics nnimap) ;; Utility functions: -(defun nnimap-replace-in-string (string regexp to) - "Replace substrings in STRING matching REGEXP with TO." - (if (string-match regexp string) - (concat (substring string 0 (match-beginning 0)) - to - (nnimap-replace-in-string (substring string (match-end 0)) - regexp to)) - string)) - (defsubst nnimap-get-server-buffer (server) "Return buffer for SERVER, if nil use current server." (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist))) @@ -308,7 +301,7 @@ If SERVER is nil, uses the current server." (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity))) (if old-uidvalidity (if (not (equal old-uidvalidity new-uidvalidity)) - nil ;; uidvalidity clash + nil ;; uidvalidity clash (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity) t) (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity)) @@ -340,7 +333,7 @@ If EXAMINE is non-nil the group is selected read-only." (zerop (imap-mailbox-get 'exists group)) (yes-or-no-p (format - "nnimap: Group %s is not uidvalid. Continue? " group))) + "nnimap: Group %s is not uidvalid. Continue? " group))) imap-current-mailbox (imap-mailbox-unselect) (error "nnimap: Group %s is not uid-valid." group)) @@ -367,39 +360,26 @@ If EXAMINE is non-nil the group is selected read-only." nnimap-progress-how-often) nnimap-progress-chars))) (with-current-buffer nntp-server-buffer - (nnheader-insert-nov - (with-current-buffer nnimap-server-buffer - (make-full-mail-header - imap-current-message - (or (nnimap-replace-whitespace - (imap-message-envelope-subject imap-current-message)) - "(none)") - (nnimap-replace-whitespace - (imap-envelope-from - (car-safe (imap-message-envelope-from - imap-current-message)))) - (nnimap-replace-whitespace - (imap-message-envelope-date imap-current-message)) - (nnimap-replace-whitespace - (imap-message-envelope-message-id imap-current-message)) - (nnimap-replace-whitespace - (let ((str (if (imap-capability 'IMAP4rev1) - (nth 2 (assoc - "HEADER.FIELDS REFERENCES" - (imap-message-get - imap-current-message 'BODYDETAIL))) - (imap-message-get imap-current-message - 'RFC822.HEADER)))) - (if (> (length str) (length "References: ")) - (substring str (length "References: ")) - (if (and (setq str (imap-message-envelope-in-reply-to - imap-current-message)) - (string-match "<[^>]+>" str)) - (substring str (match-beginning 0) (match-end 0)))))) - (imap-message-get imap-current-message 'RFC822.SIZE) - (imap-body-lines (imap-message-body imap-current-message)) - nil ;; xref - nil))))) ;; extra-headers + (let (headers lines chars uid) + (with-current-buffer nnimap-server-buffer + (setq uid imap-current-message + headers (if (imap-capability 'IMAP4rev1) + ;; xxx don't just use car? alist doesn't contain + ;; anything else now, but it might... + (nth 2 (car (imap-message-get uid 'BODYDETAIL))) + (imap-message-get uid 'RFC822.HEADER)) + lines (imap-body-lines (imap-message-body imap-current-message)) + chars (imap-message-get imap-current-message 'RFC822.SIZE))) + (nnheader-insert-nov + (with-temp-buffer + (buffer-disable-undo) + (insert headers) + (nnheader-ms-strip-cr) + (let ((head (nnheader-parse-head 'naked))) + (mail-header-set-number head uid) + (mail-header-set-chars head chars) + (mail-header-set-lines head lines) + head)))))) (defun nnimap-retrieve-which-headers (articles fetch-old) "Get a range of articles to fetch based on ARTICLES and FETCH-OLD." @@ -461,10 +441,15 @@ If EXAMINE is non-nil the group is selected read-only." (nnimap-length (gnus-range-length articles)) (nnimap-counter 0)) (imap-fetch (nnimap-range-to-string articles) - (concat "(UID RFC822.SIZE ENVELOPE BODY " - (if (imap-capability 'IMAP4rev1) - "BODY.PEEK[HEADER.FIELDS (References)])" - "RFC822.HEADER.LINES (References))"))) + (concat "(UID RFC822.SIZE BODY " + (let ((headers + (append '(Subject From Date Message-Id + References In-Reply-To Xref) + (copy-sequence + nnmail-extra-headers)))) + (if (imap-capability 'IMAP4rev1) + (format "BODY.PEEK[HEADER.FIELDS %s])" headers) + (format "RFC822.HEADER.LINES %s)" headers))))) (and (numberp nnmail-large-newsgroup) (> nnimap-length nnmail-large-newsgroup) (nnheader-message 6 "nnimap: Retrieving headers...done"))))) @@ -563,8 +548,9 @@ If EXAMINE is non-nil the group is selected read-only." (nnimap-open-connection server)))) (deffoo nnimap-server-opened (&optional server) - "If SERVER is the current virtual server, and the connection to the -physical server is alive, this function return a non-nil value. If + "Whether SERVER is opened. +If SERVER is the current virtual server, and the connection to the +physical server is alive, this function return a non-nil value. If SERVER is nil, it is treated as the current server." ;; clean up autologouts?? (and (or server nnimap-current-server) @@ -572,8 +558,8 @@ SERVER is nil, it is treated as the current server." (imap-opened (nnimap-get-server-buffer server)))) (deffoo nnimap-close-server (&optional server) - "Close connection to server and free all resources connected to -it. Return nil if the server couldn't be closed for some reason." + "Close connection to server and free all resources connected to it. +Return nil if the server couldn't be closed for some reason." (let ((server (or server nnimap-current-server))) (when (or (nnimap-server-opened server) (imap-opened (nnimap-get-server-buffer server))) @@ -586,9 +572,9 @@ it. Return nil if the server couldn't be closed for some reason." (nnoo-close-server 'nnimap server))) (deffoo nnimap-request-close () - "Close connection to all servers and free all resources that the -backend have reserved. All buffers that have been created by that -backend should be killed. (Not the nntp-server-buffer, though.) This + "Close connection to all servers and free all resources that the backend have reserved. +All buffers that have been created by that +backend should be killed. (Not the nntp-server-buffer, though.) This function is generally only called when Gnus is shutting down." (mapcar (lambda (server) (nnimap-close-server (car server))) nnimap-server-buffer-alist) @@ -715,12 +701,10 @@ function is generally only called when Gnus is shutting down." (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx)) (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info - ;; Escape SPC in mailboxes xxx relies on gnus internals (with-current-buffer nntp-server-buffer - (insert (format "%s %d %d y\n" - (nnimap-replace-in-string mbx " " "\\ ") - (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) + (insert (format "\"%s\" %d %d y\n" + mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))))) (gnus-message 5 "nnimap: Generating active list%s...done" (if (> (length server) 0) (concat " for " server) "")) t)) @@ -755,17 +739,15 @@ function is generally only called when Gnus is shutting down." (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group nnimap-server-buffer)) (let ((info (nnimap-find-minmax-uid group 'examine))) - ;; Escape SPC in mailboxes xxx relies on gnus internals - (insert (format "211 %d %d %d %s\n" (or (nth 0 info) 0) - (max 1 (or (nth 1 info) 1)) + (insert (format "\"%s\" %d %d y\n" group (or (nth 2 info) 0) - (nnimap-replace-in-string group " " "\\ "))))))) + (max 1 (or (nth 1 info) 1)))))))) (gnus-message 5 "nnimap: Checking mailboxes...done") - 'groups)) + 'active)) (deffoo nnimap-request-update-info-internal (group info &optional server) (when (nnimap-possibly-change-group group server) - (when info ;; xxx what does this mean? should we create a info? + (when info;; xxx what does this mean? should we create a info? (with-current-buffer nnimap-server-buffer (gnus-message 5 "nnimap: Updating info for %s..." (gnus-info-group info)) @@ -792,19 +774,19 @@ function is generally only called when Gnus is shutting down." seen)) (gnus-info-set-read info seen))) - (mapc (lambda (pred) - (when (and (nnimap-mark-permanent-p (cdr pred)) - (member (nnimap-mark-to-flag (cdr pred)) - (imap-mailbox-get 'flags))) - (gnus-info-set-marks - info - (nnimap-update-alist-soft - (cdr pred) - (gnus-compress-sequence - (imap-search (nnimap-mark-to-predicate (cdr pred)))) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) + (mapcar (lambda (pred) + (when (and (nnimap-mark-permanent-p (cdr pred)) + (member (nnimap-mark-to-flag (cdr pred)) + (imap-mailbox-get 'flags))) + (gnus-info-set-marks + info + (nnimap-update-alist-soft + (cdr pred) + (gnus-compress-sequence + (imap-search (nnimap-mark-to-predicate (cdr pred)))) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) (gnus-message 5 "nnimap: Updating info for %s...done" (gnus-info-group info)) @@ -853,6 +835,11 @@ function is generally only called when Gnus is shutting down." (gnus-message 7 "nnimap: Setting marks in %s...done" group)))) nil) +(defun nnimap-split-fancy () + "Like nnmail-split-fancy, but uses nnimap-split-fancy." + (let ((nnmail-split-fancy nnimap-split-fancy)) + (nnmail-split-fancy))) + (defun nnimap-split-to-groups (rules) ;; tries to match all rules in nnimap-split-rule against content of ;; nntp-server-buffer, returns a list of groups that matched. @@ -897,7 +884,7 @@ function is generally only called when Gnus is shutting down." (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server))) ;; iterate over inboxes (while (and (setq inbox (pop inboxes)) - (nnimap-possibly-change-group inbox)) ;; SELECT + (nnimap-possibly-change-group inbox));; SELECT ;; find split rule for this server / inbox (when (setq rule (nnimap-split-find-rule server inbox)) ;; iterate over articles @@ -920,7 +907,7 @@ function is generally only called when Gnus is shutting down." (and removeorig (imap-message-flags-add (format "%d" article) "\\Seen \\Deleted"))))) - (when (imap-mailbox-select inbox) ;; just in case + (when (imap-mailbox-select inbox);; just in case ;; todo: UID EXPUNGE (if available) to remove splitted articles (imap-mailbox-expunge) (imap-mailbox-close))) @@ -943,12 +930,10 @@ function is generally only called when Gnus is shutting down." (string= (downcase mailbox) "\\noselect")) (imap-mailbox-get 'list-flags mbx nnimap-server-buffer)) - ;; Escape SPC in mailboxes xxx relies on gnus internals (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info - (insert (format "%s %d %d y\n" - (nnimap-replace-in-string mbx " " "\\ ") - (or (nth 2 info) 0) + (insert (format "\"%s\" %d %d y\n" + mbx (or (nth 2 info) 0) (max 1 (or (nth 1 info) 1))))))))) (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done" (if (> (length server) 0) " on " "") server)) @@ -1087,18 +1072,18 @@ function is generally only called when Gnus is shutting down." ;; delete all removed identifiers (mapcar (lambda (old-acl) (unless (assoc (car old-acl) new-acls) - (or (imap-mailbox-acl-delete (car old-acl) mailbox) - (error "Can't delete ACL for %s" (car old-acl))))) + (or (imap-mailbox-acl-delete (car old-acl) mailbox) + (error "Can't delete ACL for %s" (car old-acl))))) old-acls) ;; set all changed acl's (mapcar (lambda (new-acl) (let ((new-rights (cdr new-acl)) (old-rights (cdr (assoc (car new-acl) old-acls)))) - (unless (and old-rights new-rights - (string= old-rights new-rights)) - (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox) - (error "Can't set ACL for %s to %s" (car new-acl) - new-rights))))) + (unless (and old-rights new-rights + (string= old-rights new-rights)) + (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox) + (error "Can't set ACL for %s to %s" (car new-acl) + new-rights))))) new-acls) t))) @@ -1113,12 +1098,12 @@ function is generally only called when Gnus is shutting down." ;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc ;; ;; Mark should not really contain 'read since it's not a "mark" in the Gnus -;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read). +;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read). ;; (defconst nnimap-mark-to-predicate-alist (mapcar - (lambda (pair) ; cdr is the mark + (lambda (pair) ; cdr is the mark (or (assoc (cdr pair) '((read . "SEEN") (tick . "FLAGGED") @@ -1129,9 +1114,9 @@ function is generally only called when Gnus is shutting down." (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-predicate (pred) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP -predicate (a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD -gnus-expire\") to be used within a IMAP SEARCH query." + "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate. +This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\", +to be used within a IMAP SEARCH query." (cdr (assq pred nnimap-mark-to-predicate-alist))) (defconst nnimap-mark-to-flag-alist @@ -1153,8 +1138,8 @@ gnus-expire\") to be used within a IMAP SEARCH query." (cdr (assoc preds nnimap-mark-to-flag-alist)))) (defun nnimap-mark-to-flag (preds &optional always-list make-string) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP -flag (a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\") to + "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag. +This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to be used in a STORE FLAGS command." (let ((result (nnimap-mark-to-flag-1 preds))) (setq result (if (and (or make-string always-list) @@ -1170,13 +1155,12 @@ be used in a STORE FLAGS command." result))) (defun nnimap-mark-permanent-p (mark &optional group) - "Return t iff MARK can be permanently (between IMAP sessions) saved -on articles, in GROUP." + "Return t iff MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) (defun nnimap-remassoc (key alist) - "Delete by side effect any elements of LIST whose car is -`equal' to KEY. The modified LIST is returned. If the first member + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member of LIST has a car that is `equal' to KEY, there is no way to remove it by side effect; therefore, write `(setq foo (remassoc key foo))' to be sure of changing the value of `foo'." @@ -1199,73 +1183,72 @@ sure of changing the value of `foo'." (car item) (cdr item)) (format "%d" item))) (if (and (listp range) (not (listp (cdr range)))) - (list range) ;; make (1 . 2) into ((1 . 2)) + (list range);; make (1 . 2) into ((1 . 2)) range) ",")) (when nnimap-debug (require 'trace) (buffer-disable-undo (get-buffer-create nnimap-debug)) - (mapc (lambda (f) (trace-function-background f nnimap-debug)) + (mapcar (lambda (f) (trace-function-background f nnimap-debug)) '( -nnimap-replace-in-string -nnimap-possibly-change-server -nnimap-verify-uidvalidity -nnimap-find-minmax-uid -nnimap-possibly-change-group -;nnimap-replace-whitespace -nnimap-retrieve-headers-progress -nnimap-retrieve-which-headers -nnimap-group-overview-filename -nnimap-retrieve-headers-from-file -nnimap-retrieve-headers-from-server -nnimap-retrieve-headers -nnimap-open-connection -nnimap-open-server -nnimap-server-opened -nnimap-close-server -nnimap-request-close -nnimap-status-message -;nnimap-demule -nnimap-request-article-part -nnimap-request-article -nnimap-request-head -nnimap-request-body -nnimap-request-group -nnimap-close-group -nnimap-pattern-to-list-arguments -nnimap-request-list -nnimap-request-post -nnimap-retrieve-groups -nnimap-request-update-info-internal -nnimap-request-type -nnimap-request-set-mark -nnimap-split-to-groups -nnimap-split-find-rule -nnimap-split-find-inbox -nnimap-split-articles -nnimap-request-scan -nnimap-request-newgroups -nnimap-request-create-group -nnimap-time-substract -nnimap-date-days-ago -nnimap-request-expire-articles-progress -nnimap-request-expire-articles -nnimap-request-move-article -nnimap-request-accept-article -nnimap-request-delete-group -nnimap-request-rename-group -gnus-group-nnimap-expunge -gnus-group-nnimap-edit-acl -gnus-group-nnimap-edit-acl-done -nnimap-group-mode-hook -nnimap-mark-to-predicate -nnimap-mark-to-flag-1 -nnimap-mark-to-flag -nnimap-mark-permanent-p -nnimap-remassoc -nnimap-update-alist-soft -nnimap-range-to-string + nnimap-possibly-change-server + nnimap-verify-uidvalidity + nnimap-find-minmax-uid + nnimap-possibly-change-group + ;;nnimap-replace-whitespace + nnimap-retrieve-headers-progress + nnimap-retrieve-which-headers + nnimap-group-overview-filename + nnimap-retrieve-headers-from-file + nnimap-retrieve-headers-from-server + nnimap-retrieve-headers + nnimap-open-connection + nnimap-open-server + nnimap-server-opened + nnimap-close-server + nnimap-request-close + nnimap-status-message + ;;nnimap-demule + nnimap-request-article-part + nnimap-request-article + nnimap-request-head + nnimap-request-body + nnimap-request-group + nnimap-close-group + nnimap-pattern-to-list-arguments + nnimap-request-list + nnimap-request-post + nnimap-retrieve-groups + nnimap-request-update-info-internal + nnimap-request-type + nnimap-request-set-mark + nnimap-split-to-groups + nnimap-split-find-rule + nnimap-split-find-inbox + nnimap-split-articles + nnimap-request-scan + nnimap-request-newgroups + nnimap-request-create-group + nnimap-time-substract + nnimap-date-days-ago + nnimap-request-expire-articles-progress + nnimap-request-expire-articles + nnimap-request-move-article + nnimap-request-accept-article + nnimap-request-delete-group + nnimap-request-rename-group + gnus-group-nnimap-expunge + gnus-group-nnimap-edit-acl + gnus-group-nnimap-edit-acl-done + nnimap-group-mode-hook + nnimap-mark-to-predicate + nnimap-mark-to-flag-1 + nnimap-mark-to-flag + nnimap-mark-permanent-p + nnimap-remassoc + nnimap-update-alist-soft + nnimap-range-to-string ))) (provide 'nnimap) diff --git a/lisp/nnkiboze.el b/lisp/nnkiboze.el index e6d7ff0..a253608 100644 --- a/lisp/nnkiboze.el +++ b/lisp/nnkiboze.el @@ -155,15 +155,15 @@ (deffoo nnkiboze-request-delete-group (group &optional force server) (nnkiboze-possibly-change-group group) (when force - (let ((files (nconc - (nnkiboze-score-file group) - (list (nnkiboze-nov-file-name) - (nnkiboze-nov-file-name ".newsrc"))))) - (while files - (and (file-exists-p (car files)) - (file-writable-p (car files)) - (delete-file (car files))) - (setq files (cdr files))))) + (let ((files (nconc + (nnkiboze-score-file group) + (list (nnkiboze-nov-file-name) + (nnkiboze-nov-file-name ".newsrc"))))) + (while files + (and (file-exists-p (car files)) + (file-writable-p (car files)) + (delete-file (car files))) + (setq files (cdr files))))) (setq nnkiboze-current-group nil) t) diff --git a/lisp/nnlistserv.el b/lisp/nnlistserv.el index a226328..79b08b8 100644 --- a/lisp/nnlistserv.el +++ b/lisp/nnlistserv.el @@ -29,6 +29,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnoo) (require 'nnweb) @@ -44,15 +45,15 @@ nnweb-type) (defvoo nnlistserv-type-definition - '((kk - (article . nnlistserv-kk-wash-article) - (map . nnlistserv-kk-create-mapping) - (search . nnlistserv-kk-search) - (address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/") - (pages "fra160396" "fra160796" "fra061196" "fra160197" - "fra090997" "fra040797" "fra130397" "nye") - (index . "date.html") - (identifier . nnlistserv-kk-identity))) + '((kk + (article . nnlistserv-kk-wash-article) + (map . nnlistserv-kk-create-mapping) + (search . nnlistserv-kk-search) + (address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/") + (pages "fra160396" "fra160796" "fra061196" "fra160197" + "fra090997" "fra040797" "fra130397" "nye") + (index . "date.html") + (identifier . nnlistserv-kk-identity))) "Type-definition alist." nnweb-type-definition) @@ -110,8 +111,7 @@ nil 0 0 url)) map) (nnweb-set-hashtb (cadar map) (car map)) - (nnheader-message 5 "%s %s %s" (cdr active) (point) pages) - )))) + (nnheader-message 5 "%s %s %s" (cdr active) (point) pages))))) ;; Return the articles in the right order. (setq nnweb-articles (sort (nconc nnweb-articles map) 'car-less-than-car))))) diff --git a/lisp/nnmail.el b/lisp/nnmail.el index baa18b1..35ca394 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'message) (require 'custom) @@ -934,7 +935,7 @@ FUNC will be called with the group name to determine the article number." '("bogus")) (error (nnheader-message 5 - "Error in `nnmail-split-methods'; using `bogus' mail group") + "Error in `nnmail-split-methods'; using `bogus' mail group") (sit-for 1) '("bogus"))))) (setq split (gnus-remove-duplicates split)) @@ -1400,6 +1401,7 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (let* ((sources (or mail-sources (if (listp nnmail-spool-file) nnmail-spool-file (list nnmail-spool-file)))) + fetching-sources (group-in group) (i 0) (new 0) @@ -1407,14 +1409,6 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." incoming incomings source) (when (and (nnmail-get-value "%s-get-new-mail" method) nnmail-spool-file) - ;; We first activate all the groups. - (nnmail-activate method) - ;; Allow the user to hook. - (run-hooks 'nnmail-pre-get-new-mail-hook) - ;; Open the message-id cache. - (nnmail-cache-open) - ;; The we go through all the existing mail source specification - ;; and fetch the mail from each. (while (setq source (pop sources)) ;; Be compatible with old values. (cond @@ -1446,21 +1440,31 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (when nnmail-fetched-sources (if (member source nnmail-fetched-sources) (setq source nil) - (push source nnmail-fetched-sources))) - (when source - (nnheader-message 4 "%s: Reading incoming mail from %s..." - method (car source)) - (when (setq new - (mail-source-fetch - source - `(lambda (file orig-file) - (nnmail-split-incoming - file ',(intern (format "%s-save-mail" method)) - ',spool-func - (nnmail-get-split-group orig-file source) - ',(intern (format "%s-active-number" method)))))) - (incf total new) - (incf i)))) + (push source nnmail-fetched-sources) + (push source fetching-sources))))) + (when fetching-sources + ;; We first activate all the groups. + (nnmail-activate method) + ;; Allow the user to hook. + (run-hooks 'nnmail-pre-get-new-mail-hook) + ;; Open the message-id cache. + (nnmail-cache-open) + ;; The we go through all the existing mail source specification + ;; and fetch the mail from each. + (while (setq source (pop fetching-sources)) + (nnheader-message 4 "%s: Reading incoming mail from %s..." + method (car source)) + (when (setq new + (mail-source-fetch + source + `(lambda (file orig-file) + (nnmail-split-incoming + file ',(intern (format "%s-save-mail" method)) + ',spool-func + (nnmail-get-split-group orig-file source) + ',(intern (format "%s-active-number" method)))))) + (incf total new) + (incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" diff --git a/lisp/nnmbox.el b/lisp/nnmbox.el index 2dd8311..4eae3b8 100644 --- a/lisp/nnmbox.el +++ b/lisp/nnmbox.el @@ -26,6 +26,7 @@ (eval-when-compile (require 'cl)) (eval-when-compile (require 'static)) + (require 'nnheader) (require 'message) (require 'nnmail) @@ -253,7 +254,7 @@ (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented.")) (deffoo nnmbox-request-expire-articles - (articles newsgroup &optional server force) + (articles newsgroup &optional server force) (nnmbox-possibly-change-newsgroup newsgroup server) (let* ((is-old t) rest) @@ -288,7 +289,7 @@ (nconc rest articles)))) (deffoo nnmbox-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last) (let ((buf (get-buffer-create " *nnmbox move*")) result) (and @@ -558,26 +559,31 @@ (when (and (re-search-backward (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " (caar alist)) nil t) - (>= (setq number - (string-to-number - (buffer-substring - (match-beginning 1) (match-end 1)))) - (cdadar alist))) - (setcdr (cadar alist) (1+ number))) + (> (setq number + (string-to-number + (buffer-substring + (match-beginning 1) (match-end 1)))) + (cdadar alist))) + (setcdr (cadar alist) number)) (setq alist (cdr alist))) (goto-char (point-min)) (while (re-search-forward delim nil t) (setq start (match-beginning 0)) - (when (not (search-forward "\nX-Gnus-Newsgroup: " - (save-excursion - (setq end - (or - (and - (re-search-forward delim nil t) - (match-beginning 0)) - (point-max)))) - t)) + (unless (search-forward + "\nX-Gnus-Newsgroup: " + (save-excursion + (setq end + (or + (and + ;; skip to end of headers first, since mail + ;; which has been respooled has additional + ;; "From nobody" lines. + (search-forward "\n\n" nil t) + (re-search-forward delim nil t) + (match-beginning 0)) + (point-max)))) + t) (save-excursion (save-restriction (narrow-to-region start end) diff --git a/lisp/nnmh.el b/lisp/nnmh.el index 1199d22..98e56a4 100644 --- a/lisp/nnmh.el +++ b/lisp/nnmh.el @@ -32,6 +32,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nnmail) (require 'gnus-start) @@ -49,7 +50,10 @@ "*Hook run narrowed to an article before saving.") (defvoo nnmh-be-safe nil - "*If non-nil, nnmh will check all articles to make sure whether they are new or not.") + "*If non-nil, nnmh will check all articles to make sure whether they are new or not. +Go through the .nnmh-articles file and compare with the actual +articles in this folder. The articles that are \"new\" will be marked +as unread by Gnus.") @@ -61,6 +65,9 @@ (defvoo nnmh-status-string "") (defvoo nnmh-group-alist nil) +;; Don't even think about setting this variable. It does not exist. +;; Forget about it. Uh-huh. Nope. Nobody here. It's only bound +;; dynamically by certain functions in nndraft. (defvar nnmh-allow-delete-final nil) @@ -106,7 +113,7 @@ (and large (zerop (% count 20)) (nnheader-message 5 "nnmh: Receiving headers... %d%%" - (/ (* count 100) number)))) + (/ (* count 100) number)))) (when large (nnheader-message 5 "nnmh: Receiving headers...done")) @@ -196,19 +203,19 @@ (mapcar (lambda (name) (string-to-int name)) (directory-files pathname nil "^[0-9]+$" t)) '<)) - (cond - (dir - (setq nnmh-group-alist - (delq (assoc group nnmh-group-alist) nnmh-group-alist)) - (push (list group (cons (car dir) (car (last dir)))) - nnmh-group-alist) - (nnheader-report 'nnmh "Selected group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (length dir) (car dir) - (car (last dir)) group)) - (t - (nnheader-report 'nnmh "Empty group %s" group) - (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) + (cond + (dir + (setq nnmh-group-alist + (delq (assoc group nnmh-group-alist) nnmh-group-alist)) + (push (list group (cons (car dir) (car (last dir)))) + nnmh-group-alist) + (nnheader-report 'nnmh "Selected group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (length dir) (car dir) + (car (last dir)) group)) + (t + (nnheader-report 'nnmh "Empty group %s" group) + (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) (deffoo nnmh-request-scan (&optional group server) (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) @@ -299,7 +306,7 @@ t) (deffoo nnmh-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last) (let ((buf (get-buffer-create " *nnmh move*")) result) (and diff --git a/lisp/nnml.el b/lisp/nnml.el index 23b1401..124d870 100644 --- a/lisp/nnml.el +++ b/lisp/nnml.el @@ -31,6 +31,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nnmail) (require 'nnoo) @@ -41,11 +42,11 @@ "Spool directory for the nnml mail backend.") (defvoo nnml-active-file - (concat (file-name-as-directory nnml-directory) "active") + (concat (file-name-as-directory nnml-directory) "active") "Mail active file.") (defvoo nnml-newsgroups-file - (concat (file-name-as-directory nnml-directory) "newsgroups") + (concat (file-name-as-directory nnml-directory) "newsgroups") "Mail newsgroups description file.") (defvoo nnml-get-new-mail t @@ -304,7 +305,7 @@ all. This may very well take some time.") (nconc rest articles))) (deffoo nnml-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last) (let ((buf (get-buffer-create " *nnml move*")) result) (nnml-possibly-change-directory group server) @@ -312,12 +313,15 @@ all. This may very well take some time.") (and (nnml-deletable-article-p group article) (nnml-request-article article group server) - (save-excursion - (set-buffer buf) - (insert-buffer-substring nntp-server-buffer) - (setq result (eval accept-form)) - (kill-buffer (current-buffer)) - result) + (let (nnml-current-directory + nnml-current-group + nnml-article-file-alist) + (save-excursion + (set-buffer buf) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result)) (progn (nnml-possibly-change-directory group server) (condition-case () diff --git a/lisp/nnslashdot.el b/lisp/nnslashdot.el index fbf1509..23dae0d 100644 --- a/lisp/nnslashdot.el +++ b/lisp/nnslashdot.el @@ -36,17 +36,11 @@ (require 'gnus) (require 'nnmail) (require 'mm-util) -(require 'nnweb) (eval-when-compile (ignore-errors - (require 'w3) - (require 'url) - (require 'w3-forms))) + (require 'nnweb))) ;; Report failure to find w3 at load time if appropriate. -(eval '(progn - (require 'w3) - (require 'url) - (require 'w3-forms))) +(eval '(require 'nnweb)) (nnoo-declare nnslashdot) @@ -110,11 +104,11 @@ (let ((case-fold-search t)) (erase-buffer) (when (= start 1) - (nnweb-insert (format nnslashdot-article-url sid)) + (nnweb-insert (format nnslashdot-article-url sid) t) (goto-char (point-min)) (search-forward "Posted by ") (when (looking-at "]+>\\([^<]+\\)") - (setq from (match-string 1))) + (setq from (nnweb-decode-entities-string (match-string 1)))) (search-forward " on ") (setq date (nnslashdot-date-to-date (buffer-substring (point) (1- (search-forward "<"))))) @@ -122,7 +116,7 @@ (setq lines (count-lines (point) (search-forward - "A href=http://slashdot.org/article.pl"))) + "A href=http://slashdot.org/article" nil t))) (push (cons 1 @@ -134,7 +128,8 @@ (< start last)) (setq point (goto-char (point-max))) (nnweb-insert - (format nnslashdot-comments-url sid nnslashdot-threshold 0 start)) + (format nnslashdot-comments-url sid nnslashdot-threshold 0 start) + t) (when first-comments (setq first-comments nil) (goto-char (point-max)) @@ -145,20 +140,21 @@ (setq startats (sort startats '<))) (goto-char point) (while (re-search-forward - "\\([^<]+\\).*score:\\([^)]+\\))" + "<\\(b\\|H4\\)>\\([^<]+\\).*score:\\([^)]+\\))" nil t) (setq article (string-to-number (match-string 1)) - subject (match-string 2) - score (match-string 3)) + subject (match-string 3) + score (match-string 5)) (when (string-match "^Re: *" subject) (setq subject (concat "Re: " (substring subject (match-end 0))))) + (setq subject (nnweb-decode-entities-string subject)) (forward-line 1) (if (looking-at "by ]+>\\([^<]+\\)[ \t\n]*.*(\\([^)]+\\))") - (setq from (concat (match-string 1) + (setq from (concat (nnweb-decode-entities-string (match-string 1)) " <" (match-string 2) ">")) (looking-at "by \\(.+\\) on ") - (setq from (match-string 1))) + (setq from (nnweb-decode-entities-string (match-string 1)))) (goto-char (- (match-end 0) 5)) (search-forward " on ") (setq date @@ -208,18 +204,18 @@ (set-buffer nnslashdot-buffer) (erase-buffer) (when (= start 1) - (nnweb-insert (format nnslashdot-article-url sid)) + (nnweb-insert (format nnslashdot-article-url sid) t) (goto-char (point-min)) (search-forward "Posted by ") (when (looking-at "]+>\\([^<]+\\)") - (setq from (match-string 1))) + (setq from (nnweb-decode-entities-string (match-string 1)))) (search-forward " on ") (setq date (nnslashdot-date-to-date (buffer-substring (point) (1- (search-forward "<"))))) (forward-line 2) (setq lines (count-lines (point) (search-forward - "A href=http://slashdot.org/article.pl"))) + "A href=http://slashdot.org/article"))) (push (cons 1 @@ -234,22 +230,25 @@ (setq start (1+ article))) (setq point (goto-char (point-max))) (nnweb-insert - (format nnslashdot-comments-url sid nnslashdot-threshold 4 start)) + (format nnslashdot-comments-url sid nnslashdot-threshold 4 start) + t) (goto-char point) (while (re-search-forward - "\\([^<]+\\).*score:\\([^)]+\\))" + "<\\(b\\|H4\\)>\\([^<]+\\).*score:\\([^)]+\\))" nil t) (setq article (string-to-number (match-string 1)) - subject (match-string 2) - score (match-string 3)) + subject (match-string 3) + score (match-string 5)) (when (string-match "^Re: *" subject) (setq subject (concat "Re: " (substring subject (match-end 0))))) + (setq subject (nnweb-decode-entities-string subject)) (forward-line 1) (if (looking-at "by ]+>\\([^<]+\\)[ \t\n]*.*(\\([^)]+\\))") - (setq from (concat (match-string 1) " <" (match-string 2) ">")) + (setq from (concat (nnweb-decode-entities-string (match-string 1)) + " <" (match-string 2) ">")) (looking-at "by \\(.+\\) on ") - (setq from (match-string 1))) + (setq from (nnweb-decode-entities-string (match-string 1)))) (goto-char (- (match-end 0) 5)) (search-forward " on ") (setq date @@ -323,14 +322,14 @@ (when (numberp article) (if (= article 1) (progn - (re-search-forward "Posted by .* on ") - (forward-line 1) + (re-search-forward "Posted by *<[^>]+>[^>]*<[^>]+> *on ") + (search-forward "
") (setq contents (buffer-substring (point) (progn (re-search-forward - "

.*A href=http://slashdot.org/article.pl") + "

.*A href=http://slashdot\\.org/article") (match-beginning 0))))) (search-forward (format "" (1- article))) (setq contents @@ -345,7 +344,7 @@ (erase-buffer) (insert contents) (goto-char (point-min)) - (while (search-forward "

" nil t) + (while (re-search-forward "\\(
\r?\\)+" nil t) (replace-match "

" t t)) (goto-char (point-min)) (insert "Content-Type: text/html\nMIME-Version: 1.0\n") @@ -370,44 +369,45 @@ sid elem description articles gname) (condition-case why ;; First we do the Ultramode to get info on all the latest groups. - (mm-with-unibyte-buffer - (nnweb-insert "http://slashdot.org/slashdot.xml") - (goto-char (point-min)) - (while (search-forward "" nil t) - (narrow-to-region (point) (search-forward "")) - (goto-char (point-min)) - (re-search-forward "\\([^<]+\\)") - (setq description (match-string 1)) - (re-search-forward "\\([^<]+\\)") - (setq sid (match-string 1)) - (string-match "/\\([0-9/]+\\).shtml" sid) - (setq sid (match-string 1 sid)) - (re-search-forward "\\([^<]+\\)") - (setq articles (string-to-number (match-string 1))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid) nnslashdot-groups)) - (goto-char (point-max)) - (widen))) - ;; Then do the older groups. - (while (> (- nnslashdot-group-number number) 0) - (mm-with-unibyte-buffer - (let ((case-fold-search t)) - (nnweb-insert (format nnslashdot-active-url number)) - (goto-char (point-min)) - (while (re-search-forward - "article.pl\\?sid=\\([^&]+\\).*\\([^<]+\\)" nil t) - (setq sid (match-string 1) - description (match-string 2)) - (forward-line 1) - (when (re-search-forward "\\([0-9]+\\)" nil t) - (setq articles (string-to-number (match-string 1)))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid) nnslashdot-groups))))) - (incf number 30)) + (progn + (mm-with-unibyte-buffer + (nnweb-insert "http://slashdot.org/slashdot.xml" t) + (goto-char (point-min)) + (while (search-forward "" nil t) + (narrow-to-region (point) (search-forward "")) + (goto-char (point-min)) + (re-search-forward "\\([^<]+\\)") + (setq description (nnweb-decode-entities-string (match-string 1))) + (re-search-forward "\\([^<]+\\)") + (setq sid (match-string 1)) + (string-match "/\\([0-9/]+\\).shtml" sid) + (setq sid (match-string 1 sid)) + (re-search-forward "\\([^<]+\\)") + (setq articles (string-to-number (match-string 1))) + (setq gname (concat description " (" sid ")")) + (if (setq elem (assoc gname nnslashdot-groups)) + (setcar (cdr elem) articles) + (push (list gname articles sid) nnslashdot-groups)) + (goto-char (point-max)) + (widen))) + ;; Then do the older groups. + (while (> (- nnslashdot-group-number number) 0) + (mm-with-unibyte-buffer + (let ((case-fold-search t)) + (nnweb-insert (format nnslashdot-active-url number) t) + (goto-char (point-min)) + (while (re-search-forward + "article.pl\\?sid=\\([^&]+\\).*\\([^<]+\\)" nil t) + (setq sid (match-string 1) + description (nnweb-decode-entities-string (match-string 2))) + (forward-line 1) + (when (re-search-forward "\\([0-9]+\\)" nil t) + (setq articles (string-to-number (match-string 1)))) + (setq gname (concat description " (" sid ")")) + (if (setq elem (assoc gname nnslashdot-groups)) + (setcar (cdr elem) articles) + (push (list gname articles sid) nnslashdot-groups))))) + (incf number 30))) (search-failed (nnslashdot-lose why))) (nnslashdot-write-groups) (nnslashdot-generate-active) @@ -467,6 +467,12 @@ ("postercomment" . ,body) ("posttype" . "html"))))) +(deffoo nnslashdot-request-delete-group (group &optional force server) + (nnslashdot-possibly-change-server group server) + (setq nnslashdot-groups (delq (assoc group nnslashdot-groups) + nnslashdot-groups)) + (nnslashdot-write-groups)) + (nnoo-define-skeleton nnslashdot) ;;; Internal functions @@ -502,13 +508,15 @@ (format " *nnslashdot %s*" server)))))) (defun nnslashdot-date-to-date (sdate) - (let ((elem (delete "" (split-string sdate)))) - (concat (substring (nth 0 elem) 0 3) " " - (substring (nth 1 elem) 0 3) " " - (substring (nth 2 elem) 0 2) " " - (substring (nth 3 elem) 1 6) " " - (format-time-string "%Y") " " - (nth 4 elem)))) + (condition-case err + (let ((elem (delete "" (split-string sdate)))) + (concat (substring (nth 0 elem) 0 3) " " + (substring (nth 1 elem) 0 3) " " + (substring (nth 2 elem) 0 2) " " + (substring (nth 3 elem) 1 6) " " + (format-time-string "%Y") " " + (nth 4 elem))) + (error ""))) (defun nnslashdot-generate-active () (save-excursion diff --git a/lisp/nnsoup.el b/lisp/nnsoup.el index ace0c9a..c21851b 100644 --- a/lisp/nnsoup.el +++ b/lisp/nnsoup.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nnmail) (require 'gnus-soup) @@ -313,7 +314,7 @@ backend for the messages.") (setq info (pop infolist) range-list (gnus-uncompress-range (car info)) prefix (gnus-soup-area-prefix (nth 1 info))) - (when ;; All the articles in this file are marked for expiry. + (when;; All the articles in this file are marked for expiry. (and (or (setq mod-time (nth 5 (file-attributes (nnsoup-file prefix)))) (setq mod-time (nth 5 (file-attributes diff --git a/lisp/nnspool.el b/lisp/nnspool.el index 07b0b80..b22e202 100644 --- a/lisp/nnspool.el +++ b/lisp/nnspool.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nntp) (require 'nnoo) @@ -148,7 +149,7 @@ there.") (and do-message (zerop (% (incf count) 20)) (nnheader-message 5 "nnspool: Receiving headers... %d%%" - (/ (* count 100) number)))) + (/ (* count 100) number)))) (when do-message (nnheader-message 5 "nnspool: Receiving headers...done")) @@ -298,8 +299,8 @@ there.") (read (current-buffer))) seconds)) (push (buffer-substring - (match-beginning 1) (match-end 1)) - groups) + (match-beginning 1) (match-end 1)) + groups) (zerop (forward-line -1)))) (erase-buffer) (while groups diff --git a/lisp/nntp.el b/lisp/nntp.el index adac986..0415872 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -26,6 +26,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nnheader) (require 'nnoo) (require 'gnus-util) @@ -48,10 +49,10 @@ server spawn an nnrpd server.") It is called with no parameters.") (defvoo nntp-server-action-alist - '(("nntpd 1\\.5\\.11t" - (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) - ("NNRP server Netscape" - (setq nntp-server-list-active-group nil))) + '(("nntpd 1\\.5\\.11t" + (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) + ("NNRP server Netscape" + (setq nntp-server-list-active-group nil))) "Alist of regexps to match on server types and actions to be taken. For instance, if you want Gnus to beep every time you connect to innd, you could say something like: @@ -439,36 +440,36 @@ noticing asynchronous data.") (nntp-inhibit-erase t) article) ;; Send HEAD commands. - (while (setq article (pop articles)) - (nntp-send-command - nil - "HEAD" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (setq last-point (point)) - (incf received)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (nnheader-message 6 "NNTP: Receiving headers... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) + (while (setq article (pop articles)) + (nntp-send-command + nil + "HEAD" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving headers... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (nnheader-message 6 "NNTP: Receiving headers...done")) @@ -485,7 +486,7 @@ noticing asynchronous data.") (nntp-possibly-change-group nil server) (when (nntp-find-connection-buffer nntp-server-buffer) (save-excursion - ;; Erase nntp-sever-buffer before nntp-inhibit-erase. + ;; Erase nntp-server-buffer before nntp-inhibit-erase. (set-buffer nntp-server-buffer) (erase-buffer) (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) @@ -807,13 +808,13 @@ If SEND-IF-FORCE, only send authinfo to the server if the (unless (member user '(nil "")) (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) (when t ;???Should check if AUTHINFO succeeded - (nntp-send-command - "^2.*\r?\n" "AUTHINFO PASS" - (or passwd - nntp-authinfo-password - (setq nntp-authinfo-password + (nntp-send-command + "^2.*\r?\n" "AUTHINFO PASS" + (or passwd + nntp-authinfo-password + (setq nntp-authinfo-password (mail-source-read-passwd (format "NNTP (%s@%s) password: " - user nntp-address)))))))))) + user nntp-address)))))))))) (defun nntp-send-nosy-authinfo () "Send the AUTHINFO to the nntp server." @@ -823,7 +824,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (when t ;???Should check if AUTHINFO succeeded (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" (mail-source-read-passwd "NNTP (%s@%s) password: " - user nntp-address)))))) + user nntp-address)))))) (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. @@ -1133,7 +1134,7 @@ password contained in '~/.nntp-authinfo'." (car (last articles)) 'wait) (goto-char (point-min)) - (when (looking-at "[1-5][0-9][0-9] ") + (when (looking-at "[1-5][0-9][0-9] .*\n") (delete-region (point) (progn (forward-line 1) (point)))) (while (search-forward "\r" nil t) (replace-match "" t t)) @@ -1180,16 +1181,16 @@ password contained in '~/.nntp-authinfo'." (zerop (% count nntp-maximum-request))) (nntp-accept-response) - ;; On some Emacs versions the preceding function has - ;; a tendency to change the buffer. Perhaps. It's - ;; quite difficult to reproduce, because it only - ;; seems to happen once in a blue moon. + ;; On some Emacs versions the preceding function has a + ;; tendency to change the buffer. Perhaps. It's quite + ;; difficult to reproduce, because it only seems to happen + ;; once in a blue moon. (set-buffer process-buffer) (while (progn (goto-char (or last-point (point-min))) ;; Count replies. - (while (re-search-forward "^[0-9][0-9][0-9] " nil t) - (setq received (1+ received))) + (while (re-search-forward "^[0-9][0-9][0-9] .*\n" nil t) + (incf received)) (setq last-point (point)) (< received count)) (nntp-accept-response) @@ -1201,7 +1202,10 @@ password contained in '~/.nntp-authinfo'." (set-buffer process-buffer) ;; Wait for the reply from the final command. (goto-char (point-max)) - (re-search-backward "^[0-9][0-9][0-9] " nil t) + (while (not (re-search-backward "^[0-9][0-9][0-9] " nil t)) + (nntp-accept-response) + (set-buffer process-buffer) + (goto-char (point-max))) (when (looking-at "^[23]") (while (progn (goto-char (point-max)) diff --git a/lisp/nnultimate.el b/lisp/nnultimate.el index b1962ac..d30c1a8 100644 --- a/lisp/nnultimate.el +++ b/lisp/nnultimate.el @@ -36,17 +36,11 @@ (require 'gnus) (require 'nnmail) (require 'mm-util) -(require 'nnweb) (eval-when-compile (ignore-errors - (require 'w3) - (require 'url) - (require 'w3-forms))) + (require 'nnweb))) ;; Report failure to find w3 at load time if appropriate. -(eval '(progn - (require 'w3) - (require 'url) - (require 'w3-forms))) +(eval '(require 'nnweb)) (nnoo-declare nnultimate) @@ -143,7 +137,7 @@ ;;(setq total-contents (nreverse total-contents)) (dolist (art (cdr elem)) (if (not (nth (1- (cdr art)) total-contents)) - ();(debug) + () ;(debug) (push (list (car art) (nth (1- (cdr art)) total-contents) subject) @@ -374,8 +368,8 @@ (nnultimate-open-server server)) (unless nnultimate-groups-alist (nnultimate-read-groups) - (setq nnultimate-groups (cdr (assoc nnultimate-address - nnultimate-groups-alist))))) + (setq nnultimate-groups (cdr (assoc nnultimate-address + nnultimate-groups-alist))))) (deffoo nnultimate-open-server (server &optional defs connectionless) (nnheader-init-server-buffer) @@ -439,9 +433,13 @@ case-fold-search) (when (and href (string-match "postings\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio" - href)) + href)) t)))) (provide 'nnultimate) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; nnultimate.el ends here diff --git a/lisp/nnvirtual.el b/lisp/nnvirtual.el index 8d46ed5..fef53d7 100644 --- a/lisp/nnvirtual.el +++ b/lisp/nnvirtual.el @@ -32,6 +32,7 @@ ;;; Code: (eval-when-compile (require 'cl)) + (require 'nntp) (require 'nnheader) (require 'gnus) @@ -62,8 +63,7 @@ component group will show up when you enter the virtual group.") (defvoo nnvirtual-current-group nil) (defvoo nnvirtual-mapping-table nil - "Table of rules on how to map between component group and article number -to virtual article number.") + "Table of rules on how to map between component group and article number to virtual article number.") (defvoo nnvirtual-mapping-offsets nil "Table indexed by component group to an offset to be applied to article numbers in that group.") @@ -121,47 +121,47 @@ to virtual article number.") (let ((gnus-use-cache t)) (setq result (gnus-retrieve-headers articles cgroup nil)))) - (set-buffer nntp-server-buffer) - ;; If we got HEAD headers, we convert them into NOV - ;; headers. This is slow, inefficient and, come to think - ;; of it, downright evil. So sue me. I couldn't be - ;; bothered to write a header parse routine that could - ;; parse a mixed HEAD/NOV buffer. - (when (eq result 'headers) - (nnvirtual-convert-headers)) - (goto-char (point-min)) - (while (not (eobp)) - (delete-region (point) - (progn - (setq carticle (read nntp-server-buffer)) - (point))) - - ;; We remove this article from the articles list, if - ;; anything is left in the articles list after going through - ;; the entire buffer, then those articles have been - ;; expired or canceled, so we appropriately update the - ;; component group below. They should be coming up - ;; generally in order, so this shouldn't be slow. - (setq articles (delq carticle articles)) - - (setq article (nnvirtual-reverse-map-article cgroup carticle)) - (if (null article) - ;; This line has no reverse mapping, that means it - ;; was an extra article reference returned by nntp. - (progn - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Otherwise insert the virtual article number, - ;; and clean up the xrefs. - (princ article nntp-server-buffer) - (nnvirtual-update-xref-header cgroup carticle - prefix system-name) - (forward-line 1)) - ) - - (set-buffer vbuf) - (goto-char (point-max)) - (insert-buffer-substring nntp-server-buffer)) + (set-buffer nntp-server-buffer) + ;; If we got HEAD headers, we convert them into NOV + ;; headers. This is slow, inefficient and, come to think + ;; of it, downright evil. So sue me. I couldn't be + ;; bothered to write a header parse routine that could + ;; parse a mixed HEAD/NOV buffer. + (when (eq result 'headers) + (nnvirtual-convert-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (delete-region (point) + (progn + (setq carticle (read nntp-server-buffer)) + (point))) + + ;; We remove this article from the articles list, if + ;; anything is left in the articles list after going through + ;; the entire buffer, then those articles have been + ;; expired or canceled, so we appropriately update the + ;; component group below. They should be coming up + ;; generally in order, so this shouldn't be slow. + (setq articles (delq carticle articles)) + + (setq article (nnvirtual-reverse-map-article cgroup carticle)) + (if (null article) + ;; This line has no reverse mapping, that means it + ;; was an extra article reference returned by nntp. + (progn + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Otherwise insert the virtual article number, + ;; and clean up the xrefs. + (princ article nntp-server-buffer) + (nnvirtual-update-xref-header cgroup carticle + prefix system-name) + (forward-line 1)) + ) + + (set-buffer vbuf) + (goto-char (point-max)) + (insert-buffer-substring nntp-server-buffer)) ;; Anything left in articles is expired or canceled. ;; Could be smart and not tell it about articles already known? (when articles @@ -591,7 +591,7 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." (aref entry 1) (cdr (aref nnvirtual-mapping-offsets group-pos))) )) - )) + )) @@ -649,7 +649,7 @@ then it is left out of the result." "Return an association list of component article numbers. These are indexed by elements of nnvirtual-component-groups, based on the sequence ARTICLES of virtual article numbers. ARTICLES should be -sorted, and can be a compressed sequence. If any of the article +sorted, and can be a compressed sequence. If any of the article numbers has no corresponding component article, then it is left out of the result." (when (numberp (cdr-safe articles)) @@ -691,28 +691,28 @@ based on the marks on the component groups." ;; Into all-unreads we put (g unreads). ;; Into all-marks we put (g marks). ;; We also increment cnt and tot here, and compute M (max of sizes). - (mapc (lambda (g) - (setq active (gnus-activate-group g) - min (car active) - max (cdr active)) - (when (and active (>= max min) (not (zerop max))) - ;; store active information - (push (list g (- max min -1) max) actives) - ;; collect unread/mark info for later - (setq unreads (gnus-list-of-unread-articles g)) - (setq marks (gnus-info-marks (gnus-get-info g))) - (when gnus-use-cache - (push (cons 'cache - (gnus-cache-articles-in-group g)) - marks)) - (push (cons g unreads) all-unreads) - (push (cons g marks) all-marks) - ;; count groups, total #articles, and max size - (setq size (- max min -1)) - (setq cnt (1+ cnt) - tot (+ tot size) - M (max M size)))) - nnvirtual-component-groups) + (mapcar (lambda (g) + (setq active (gnus-activate-group g) + min (car active) + max (cdr active)) + (when (and active (>= max min) (not (zerop max))) + ;; store active information + (push (list g (- max min -1) max) actives) + ;; collect unread/mark info for later + (setq unreads (gnus-list-of-unread-articles g)) + (setq marks (gnus-info-marks (gnus-get-info g))) + (when gnus-use-cache + (push (cons 'cache + (gnus-cache-articles-in-group g)) + marks)) + (push (cons g unreads) all-unreads) + (push (cons g marks) all-marks) + ;; count groups, total #articles, and max size + (setq size (- max min -1)) + (setq cnt (1+ cnt) + tot (+ tot size) + M (max M size)))) + nnvirtual-component-groups) ;; Number of articles in the virtual group. (setq nnvirtual-mapping-len tot) diff --git a/lisp/nnwarchive.el b/lisp/nnwarchive.el index 33bd5ea..4057db5 100644 --- a/lisp/nnwarchive.el +++ b/lisp/nnwarchive.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1999 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu -;; Keywords: news +;; Keywords: news egroups mail-archive ;; This file is part of GNU Emacs. @@ -23,16 +23,12 @@ ;;; Commentary: -;; Note: You need to have `url' and `w3' installed for this backend to -;; work. +;; Note: You need to have `url' (w3 0.46) or greater version +;; installed for this backend to work. -;; A lot of codes stolen from mail-source, nnslashdot, nnweb. - -;; Todo: To support more web archives. - -;; Known bugs: in w3 0.44, there are two copies of url-maybe-relative. -;; If it is loaded from w3.el, (load-library "url"). w3 0.45 should -;; work. +;; Todo: +;; 1. To support more web archives. +;; 2. Generalize webmail to other MHonArc archive. ;;; Code: @@ -42,6 +38,7 @@ (require 'message) (require 'gnus-util) (require 'gnus) +(require 'gnus-bcklg) (require 'nnmail) (require 'mm-util) (require 'mail-source) @@ -60,38 +57,57 @@ (nnoo-declare nnwarchive) -(eval-and-compile - (defvar nnwarchive-type-definition - '((egroups - (open-url - "http://www.egroups.com/register?method=loginAction&email=%s&password=%s" - login passwd) - (list-url - "http://www.egroups.com/UserGroupsPage?") - (list-dissect . nnwarchive-egroups-list) - (list-groups . nnwarchive-egroups-list-groups) - (xover-url - "http://www.egroups.com/group/%s/?fetchForward=1&start=%d" group start) - (xover-last-url - "http://www.egroups.com/group/%s/?fetchForward=1" group) - (xover-page-size . 13) - (xover-dissect . nnwarchive-egroups-xover) - (article-url - "http://www.egroups.com/group/%s/%d.html?raw=1" group article) - (article-dissect . nnwarchive-egroups-article))))) - -(eval-and-compile - (defvar nnwarchive-short-names - '(login passwd))) +(defvar nnwarchive-type-definition + '((egroups + (address . "www.egroups.com") + (open-url + "http://www.egroups.com/register?method=loginAction&email=%s&password=%s" + nnwarchive-login nnwarchive-passwd) + (list-url + "http://www.egroups.com/UserGroupsPage?") + (list-dissect . nnwarchive-egroups-list) + (list-groups . nnwarchive-egroups-list-groups) + (xover-url + "http://www.egroups.com/group/%s/?fetchForward=1&start=%d" group aux) + (xover-last-url + "http://www.egroups.com/group/%s/?fetchForward=1" group) + (xover-page-size . 13) + (xover-dissect . nnwarchive-egroups-xover) + (article-url + "http://www.egroups.com/group/%s/%d.html?raw=1" group article) + (article-dissect . nnwarchive-egroups-article) + (authentication . t) + (article-offset . 0) + (xover-files . nnwarchive-egroups-xover-files)) + (mail-archive + (address . "www.mail-archive.com") + (open-url) + (list-url + "http://www.mail-archive.com/lists.html") + (list-dissect . nnwarchive-mail-archive-list) + (list-groups . nnwarchive-mail-archive-list-groups) + (xover-url + "http://www.mail-archive.com/%s/mail%d.html" group aux) + (xover-last-url + "http://www.mail-archive.com/%s/maillist.html" group) + (xover-page-size) + (xover-dissect . nnwarchive-mail-archive-xover) + (article-url + "http://www.mail-archive.com/%s/msg%05d.html" group article1) + (article-dissect . nnwarchive-mail-archive-article) + (xover-files . nnwarchive-mail-archive-xover-files) + (authentication) + (article-offset . 1)))) + +(defvar nnwarchive-default-type 'egroups) (defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/") "Where nnwarchive will save its files.") -(eval-and-compile - (defvoo nnwarchive-type 'egroups - "The type of nnwarchive.")) +(defvoo nnwarchive-type nil + "The type of nnwarchive.") -(defvoo nnwarchive-address "egroups.com" +(defvoo nnwarchive-address "" "The address of nnwarchive.") (defvoo nnwarchive-login nil @@ -104,138 +120,148 @@ (defvoo nnwarchive-headers-cache nil) -(defvoo nnwarchive-opened nil) +(defvoo nnwarchive-authentication nil) + +(defvoo nnwarchive-nov-is-evil nil) (defconst nnwarchive-version "nnwarchive 1.0") ;;; Internal variables -(defvar nnwarchive-open-url nil) -(defvar nnwarchive-open-dissect nil) +(defvoo nnwarchive-open-url nil) +(defvoo nnwarchive-open-dissect nil) + +(defvoo nnwarchive-list-url nil) +(defvoo nnwarchive-list-dissect nil) +(defvoo nnwarchive-list-groups nil) + +(defvoo nnwarchive-xover-files nil) +(defvoo nnwarchive-xover-url nil) +(defvoo nnwarchive-xover-last-url nil) +(defvoo nnwarchive-xover-dissect nil) +(defvoo nnwarchive-xover-page-size nil) -(defvar nnwarchive-list-url nil) -(defvar nnwarchive-list-dissect nil) -(defvar nnwarchive-list-groups nil) +(defvoo nnwarchive-article-url nil) +(defvoo nnwarchive-article-dissect nil) +(defvoo nnwarchive-xover-files nil) +(defvoo nnwarchive-article-offset 0) -(defvar nnwarchive-xover-url nil) -(defvar nnwarchive-xover-last-url nil) -(defvar nnwarchive-xover-dissect nil) -(defvar nnwarchive-xover-page-size nil) +(defvoo nnwarchive-buffer nil) -(defvar nnwarchive-article-url nil) -(defvar nnwarchive-article-dissect nil) +(defvoo nnwarchive-keep-backlog 300) +(defvar nnwarchive-backlog-articles nil) +(defvar nnwarchive-backlog-hashtb nil) -(defvar nnwarchive-buffer nil) +(defvoo nnwarchive-headers nil) -(defvar nnwarchive-headers nil) ;;; Interface functions (nnoo-define-basics nnwarchive) -(eval-and-compile - (defun nnwarchive-bind-1 () - (let ((defaults (cdr (assq nnwarchive-type nnwarchive-type-definition))) - (short-names nnwarchive-short-names) - default bind) - (while (setq default (pop defaults)) - (push (list (intern (concat "nnwarchive-" (symbol-name (car default)))) - (list 'quote (cdr default))) bind)) - (while (setq default (pop short-names)) - (push (list default - (intern (concat "nnwarchive-" - (symbol-name default)))) - bind)) - bind))) - -(defmacro nnwarchive-bind (&rest body) - "Return a `let' form that binds all variables in TYPE. -Read `mail-source-bind' for details." - `(let ,(nnwarchive-bind-1) - ,@body)) - -(put 'nnwarchive-bind 'lisp-indent-function 0) -(put 'nnwarchive-bind 'edebug-form-spec '(form body)) +(defun nnwarchive-set-default (type) + (let ((defs (cdr (assq type nnwarchive-type-definition))) + def) + (dolist (def defs) + (set (intern (concat "nnwarchive-" (symbol-name (car def)))) + (cdr def))))) + +(defmacro nnwarchive-backlog (&rest form) + `(let ((gnus-keep-backlog nnwarchive-keep-backlog) + (gnus-backlog-buffer + (format " *nnwarchive backlog %s*" nnwarchive-address)) + (gnus-backlog-articles nnwarchive-backlog-articles) + (gnus-backlog-hashtb nnwarchive-backlog-hashtb)) + (unwind-protect + (progn ,@form) + (setq nnwarchive-backlog-articles gnus-backlog-articles + nnwarchive-backlog-hashtb gnus-backlog-hashtb)))) +(put 'nnwarchive-backlog 'lisp-indent-function 0) +(put 'nnwarchive-backlog 'edebug-form-spec '(form body)) + +(defun nnwarchive-backlog-enter-article (group number buffer) + (nnwarchive-backlog + (gnus-backlog-enter-article group number buffer))) + +(defun nnwarchive-get-article (article &optional group server buffer) + (if (numberp article) + (if (nnwarchive-backlog + (gnus-backlog-request-article group article + (or buffer nntp-server-buffer))) + (cons group article) + (let (contents) + (save-excursion + (set-buffer nnwarchive-buffer) + (goto-char (point-min)) + (let ((article1 (- article nnwarchive-article-offset))) + (nnwarchive-url nnwarchive-article-url)) + (setq contents (funcall nnwarchive-article-dissect group article))) + (when contents + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (erase-buffer) + (insert contents) + (nnwarchive-backlog-enter-article group article (current-buffer)) + (nnheader-report 'nnwarchive "Fetched article %s" article) + (cons group article))))) + nil)) (deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old) (nnwarchive-possibly-change-server group server) - (nnwarchive-bind + (if (or gnus-nov-is-evil nnwarchive-nov-is-evil) + (with-temp-buffer + (with-current-buffer nntp-server-buffer + (erase-buffer)) + (let ((buf (current-buffer)) b e) + (dolist (art articles) + (nnwarchive-get-article art group server buf) + (setq b (goto-char (point-min))) + (if (search-forward "\n\n" nil t) + (forward-char -1) + (goto-char (point-max))) + (setq e (point)) + (with-current-buffer nntp-server-buffer + (insert (format "221 %d Article retrieved.\n" art)) + (insert-buffer-substring buf b e) + (insert ".\n")))) + 'headers) (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) (save-excursion (set-buffer nnwarchive-buffer) (erase-buffer) - (let (point start starts) - (setq starts (nnwarchive-paged (sort articles '<))) - (while (setq start (pop starts)) - (goto-char (point-max)) - (nnwarchive-url nnwarchive-xover-url)) - (if nnwarchive-xover-dissect - (funcall nnwarchive-xover-dissect)))) + (funcall nnwarchive-xover-files group articles)) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let (header) - (dolist (art articles) - (if (setq header (assq art nnwarchive-headers)) - (nnheader-insert-nov (cdr header)))))) + (dolist (art articles) + (if (setq header (assq art nnwarchive-headers)) + (nnheader-insert-nov (cdr header)))))) (let ((elem (assoc group nnwarchive-headers-cache))) (if elem (setcdr elem nnwarchive-headers) (push (cons group nnwarchive-headers) nnwarchive-headers-cache))) 'nov)) -(deffoo nnwarchive-retrieve-groups (groups &optional server) - "Retrieve group info on GROUPS." - (nnwarchive-possibly-change-server nil server) - (nnwarchive-bind - (if nnwarchive-list-groups - (funcall nnwarchive-list-groups groups)) - (nnwarchive-write-groups) - (nnwarchive-generate-active) - 'active)) - (deffoo nnwarchive-request-group (group &optional server dont-check) (nnwarchive-possibly-change-server nil server) - (nnwarchive-bind - (if nnwarchive-list-groups - (funcall nnwarchive-list-groups (list group))) - (nnwarchive-write-groups) - (let ((elem (assoc group nnwarchive-groups))) - (cond - ((not elem) - (nnheader-report 'nnwarchive "Group does not exist")) - (t - (nnheader-report 'nnwarchive "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0) - (prin1-to-string group)) - t))))) - -(deffoo nnwarchive-close-group (group &optional server) - (nnwarchive-possibly-change-server group server) - (nnwarchive-bind - (when (gnus-buffer-live-p nnwarchive-buffer) - (save-excursion - (set-buffer nnwarchive-buffer) - (kill-buffer nnwarchive-buffer))) - t)) + (when (and (not dont-check) nnwarchive-list-groups) + (funcall nnwarchive-list-groups (list group)) + (nnwarchive-write-groups)) + (let ((elem (assoc group nnwarchive-groups))) + (cond + ((not elem) + (nnheader-report 'nnwarchive "Group does not exist")) + (t + (nnheader-report 'nnwarchive "Opened group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0) + (prin1-to-string group)) + t)))) (deffoo nnwarchive-request-article (article &optional group server buffer) (nnwarchive-possibly-change-server group server) - (nnwarchive-bind - (let (contents) - (save-excursion - (set-buffer nnwarchive-buffer) - (goto-char (point-min)) - (nnwarchive-url nnwarchive-article-url) - (setq contents (funcall nnwarchive-article-dissect))) - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (insert contents) - (nnheader-report 'nnwarchive "Fetched article %s" article) - (cons group article)))))) + (nnwarchive-get-article article group server buffer)) (deffoo nnwarchive-close-server (&optional server) (when (and (nnwarchive-server-opened server) @@ -243,59 +269,48 @@ Read `mail-source-bind' for details." (save-excursion (set-buffer nnwarchive-buffer) (kill-buffer nnwarchive-buffer))) + (nnwarchive-backlog + (gnus-backlog-shutdown)) (nnoo-close-server 'nnwarchive server)) (deffoo nnwarchive-request-list (&optional server) (nnwarchive-possibly-change-server nil server) - (nnwarchive-bind - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (if nnwarchive-list-url - (nnwarchive-url nnwarchive-list-url)) - (if nnwarchive-list-dissect - (funcall nnwarchive-list-dissect)) - (nnwarchive-write-groups) - (nnwarchive-generate-active))) - 'active) - -(deffoo nnwarchive-request-newgroups (date &optional server) - (nnwarchive-possibly-change-server nil server) - (nnwarchive-bind + (save-excursion + (set-buffer nnwarchive-buffer) + (erase-buffer) + (if nnwarchive-list-url + (nnwarchive-url nnwarchive-list-url)) + (if nnwarchive-list-dissect + (funcall nnwarchive-list-dissect)) (nnwarchive-write-groups) (nnwarchive-generate-active)) - 'active) - -(deffoo nnwarchive-asynchronous-p () - nil) - -(deffoo nnwarchive-server-opened (&optional server) - nnwarchive-opened) + t) (deffoo nnwarchive-open-server (server &optional defs connectionless) (nnwarchive-init server) (if (nnwarchive-server-opened server) t - (setq nnwarchive-login - (or nnwarchive-login - (read-string - (format "Login at %s: " server) - user-mail-address))) - (setq nnwarchive-passwd - (or nnwarchive-passwd - (mail-source-read-passwd - (format "Password for %s at %s: " nnwarchive-login server)))) - (nnwarchive-bind - (unless nnwarchive-groups - (nnwarchive-read-groups)) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (if nnwarchive-open-url + (nnoo-change-server 'nnwarchive server defs) + (when nnwarchive-authentication + (setq nnwarchive-login + (or nnwarchive-login + (read-string + (format "Login at %s: " server) + user-mail-address))) + (setq nnwarchive-passwd + (or nnwarchive-passwd + (mail-source-read-passwd + (format "Password for %s at %s: " + nnwarchive-login server))))) + (unless nnwarchive-groups + (nnwarchive-read-groups)) + (save-excursion + (set-buffer nnwarchive-buffer) + (erase-buffer) + (if nnwarchive-open-url (nnwarchive-url nnwarchive-open-url)) - (if nnwarchive-open-dissect - (funcall nnwarchive-open-dissect)) - (setq nnwarchive-opened t))) + (if nnwarchive-open-dissect + (funcall nnwarchive-open-dissect))) t)) (nnoo-define-skeleton nnwarchive) @@ -324,13 +339,28 @@ Read `mail-source-bind' for details." (defun nnwarchive-init (server) "Initialize buffers and such." + (let ((type (intern server)) (defs nnwarchive-type-definition) def) + (cond + ((equal server "") + (setq type nnwarchive-default-type)) + ((assq type nnwarchive-type-definition) t) + (t + (setq type nil) + (while (setq def (pop defs)) + (when (equal (cdr (assq 'address (cdr def))) server) + (setq defs nil) + (setq type (car def)))) + (unless type + (error "Undefined server %s" server)))) + (setq nnwarchive-type type)) (unless (file-exists-p nnwarchive-directory) (gnus-make-directory nnwarchive-directory)) (unless (gnus-buffer-live-p nnwarchive-buffer) (setq nnwarchive-buffer (save-excursion (nnheader-set-temp-buffer - (format " *nnwarchive %s %s*" nnwarchive-type server)))))) + (format " *nnwarchive %s %s*" nnwarchive-type server))))) + (nnwarchive-set-default nnwarchive-type)) (defun nnwarchive-encode-www-form-urlencoded (pairs) "Return PAIRS encoded for forms." @@ -367,42 +397,6 @@ Read `mail-source-bind' for details." (t (nnweb-insert (apply 'format (nnwarchive-eval xurl))))))) -(defun nnwarchive-decode-entities () - (goto-char (point-min)) - (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t) - (replace-match (char-to-string - (if (eq (aref (match-string 1) 0) ?\#) - (string-to-number (substring (match-string 1) 1)) - (or (cdr (assq (intern (match-string 1)) - w3-html-entities)) - ?#))) - t t))) - -(defun nnwarchive-decode-entities-string (str) - (with-temp-buffer - (insert str) - (nnwarchive-decode-entities) - (buffer-substring (point-min) (point-max)))) - -(defun nnwarchive-remove-markup () - (goto-char (point-min)) - (while (search-forward "" nil t) - (point-max)))) - (goto-char (point-min)) - (while (re-search-forward "<[^>]+>" nil t) - (replace-match "" t t))) - -(defun nnwarchive-date-to-date (sdate) - (let ((elem (split-string sdate))) - (concat (substring (nth 0 elem) 0 3) " " - (substring (nth 1 elem) 0 3) " " - (substring (nth 2 elem) 0 2) " " - (substring (nth 3 elem) 1 6) " " - (format-time-string "%Y") " " - (nth 4 elem)))) - (defun nnwarchive-generate-active () (save-excursion (set-buffer nntp-server-buffer) @@ -431,17 +425,17 @@ Read `mail-source-bind' for details." (nnwarchive-url nnwarchive-xover-last-url) (goto-char (point-min)) (when (re-search-forward "of \\([0-9]+\\)" nil t) - (setq articles (string-to-number (match-string 1)))) + (setq articles (string-to-number (match-string 1)))) (let ((elem (assoc group nnwarchive-groups))) - (if elem - (setcar (cdr elem) articles) - (push (list group articles "") nnwarchive-groups))) + (if elem + (setcar (cdr elem) articles) + (push (list group articles "") nnwarchive-groups))) (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (nnwarchive-egroups-xover) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))))) + (nnwarchive-egroups-xover group) + (let ((elem (assoc group nnwarchive-headers-cache))) + (if elem + (setcdr elem nnwarchive-headers) + (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))))) (defun nnwarchive-egroups-list () (let ((case-fold-search t) @@ -458,41 +452,40 @@ Read `mail-source-bind' for details." (setq articles (string-to-number (match-string 1)))) (if (setq elem (assoc group nnwarchive-groups)) (setcar (cdr elem) articles) - (push (list group articles description) nnwarchive-groups))) - (nnwarchive-egroups-list-groups (mapcar 'identity nnwarchive-groups))) + (push (list group articles description) nnwarchive-groups)))) t) -(defun nnwarchive-egroups-xover() - (let (article subject from date group) +(defun nnwarchive-egroups-xover (group) + (let (article subject from date) (goto-char (point-min)) (while (re-search-forward "]+>\\([^<]+\\)<" nil t) - (setq group (match-string 1) - article (string-to-number (match-string 2)) - subject (match-string 3)) - (forward-line 1) - (unless (assq article nnwarchive-headers) - (if (looking-at "]+>]+>\\([^<]+\\)") - (setq from (match-string 1))) - (forward-line 1) - (if (looking-at "]+>]+>\\([^<]+\\)") - (setq date (identity (match-string 1)))) - (push (cons - article - (make-full-mail-header - article - (nnwarchive-decode-entities-string subject) - (nnwarchive-decode-entities-string from) - date - (concat "<" group "%" - (number-to-string article) - "@egroup.com>") - "" - 0 0 "")) nnwarchive-headers)))) + (setq group (match-string 1) + article (string-to-number (match-string 2)) + subject (match-string 3)) + (forward-line 1) + (unless (assq article nnwarchive-headers) + (if (looking-at "]+>]+>\\([^<]+\\)") + (setq from (match-string 1))) + (forward-line 1) + (if (looking-at "]+>]+>\\([^<]+\\)") + (setq date (identity (match-string 1)))) + (push (cons + article + (make-full-mail-header + article + (nnweb-decode-entities-string subject) + (nnweb-decode-entities-string from) + date + (concat "<" group "%" + (number-to-string article) + "@egroup.com>") + "" + 0 0 "")) nnwarchive-headers)))) nnwarchive-headers) -(defun nnwarchive-egroups-article () +(defun nnwarchive-egroups-article (group articles) (goto-char (point-min)) (if (search-forward "

" nil t)
       (delete-region (point-min) (point)))
@@ -502,8 +495,262 @@ Read `mail-source-bind' for details."
   (goto-char (point-min))
   (while (re-search-forward "]+>\\([^<]+\\)" nil t)
     (replace-match "<\\1>"))
-  (nnwarchive-decode-entities)
-  (buffer-substring (point-min) (point-max)))
+  (nnweb-decode-entities)
+  (buffer-string))
+
+(defun nnwarchive-egroups-xover-files (group articles)
+  (let (aux auxs)
+    (setq auxs (nnwarchive-paged (sort articles '<)))
+    (while (setq aux (pop auxs))
+      (goto-char (point-max))
+      (nnwarchive-url nnwarchive-xover-url))
+    (if nnwarchive-xover-dissect
+	(nnwarchive-egroups-xover group))))
+
+;; mail-archive
+
+(defun nnwarchive-mail-archive-list-groups (groups)
+  (save-excursion
+    (let (articles)
+      (set-buffer nnwarchive-buffer)
+      (dolist (group groups)
+	(erase-buffer)
+	(nnwarchive-url nnwarchive-xover-last-url)
+	(goto-char (point-min))
+	(when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t)
+	  (setq articles (1+ (string-to-number (match-string 1)))))
+	(let ((elem (assoc group nnwarchive-groups)))
+	  (if elem
+	      (setcar (cdr elem) articles)
+	    (push (list group articles "") nnwarchive-groups)))
+	(setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
+	(nnwarchive-mail-archive-xover group)
+	(let ((elem (assoc group nnwarchive-headers-cache)))
+	  (if elem
+	      (setcdr elem nnwarchive-headers)
+	    (push (cons group nnwarchive-headers) 
+		  nnwarchive-headers-cache)))))))
+
+(defun nnwarchive-mail-archive-list ()
+  (let ((case-fold-search t)
+	group description elem articles)
+    (goto-char (point-min))
+    (while (re-search-forward "\\([^>]+\\)<" nil t)
+      (setq group (match-string 1)
+	    description (match-string 2))
+      (forward-line 1)
+      (setq articles 0)
+      (if (setq elem (assoc group nnwarchive-groups))
+	  (setcar (cdr elem) articles)
+	(push (list group articles description) nnwarchive-groups))))
+  t)
+
+(defun nnwarchive-mail-archive-xover (group)
+  (let (article subject from date)
+    (goto-char (point-min))
+    (while (re-search-forward
+	    "]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
+	    nil t)
+      (setq article (1+ (string-to-number (match-string 1)))
+	    subject (match-string 2))
+      (forward-line 1)
+      (unless (assq article nnwarchive-headers)
+	(if (looking-at "