From 434915883296be44c9b5efad306b5289472c6a86 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Fri, 21 Feb 2003 14:44:57 +0000 Subject: [PATCH] Synch to Oort Gnus. --- contrib/ChangeLog | 7 ++ contrib/hashcash.el | 16 ++++- lisp/ChangeLog | 11 ++++ lisp/gnus-art.el | 180 +++++++++++++++++++++++++++++++++++++++++---------- 4 files changed, 178 insertions(+), 36 deletions(-) diff --git a/contrib/ChangeLog b/contrib/ChangeLog index f8271d6..da6cafd 100644 --- a/contrib/ChangeLog +++ b/contrib/ChangeLog @@ -1,3 +1,10 @@ +2003-02-21 Simon Josefsson + + * hashcash.el (hashcash-point-at-bol): + (hashcash-point-at-eol): Defalias. + (hashcash-generate-payment): + (mail-check-payment): Use it. + 2002-12-30 Lars Magne Ingebrigtsen * hashcash.el: New version from Paul Foley with new diff --git a/contrib/hashcash.el b/contrib/hashcash.el index 5ec251f..8dbc769 100644 --- a/contrib/hashcash.el +++ b/contrib/hashcash.el @@ -56,6 +56,16 @@ is used instead.") (require 'mail-utils) +(defalias 'hashcash-point-at-bol + (if (fboundp 'point-at-bol) + 'point-at-bol + 'line-beginning-position)) + +(defalias 'hashcash-point-at-eol + (if (fboundp 'point-at-eol) + 'point-at-eol + 'line-end-position)) + (defun hashcash-strip-quoted-names (addr) (setq addr (mail-strip-quoted-names addr)) (if (and addr (string-match "^[^+@]+\\(\\+[^@]*\\)@" addr)) @@ -90,7 +100,7 @@ is used instead.") (call-process hashcash nil t nil (concat "-b " (number-to-string val)) str) (goto-char (point-min)) - (buffer-substring (point-at-bol) (point-at-eol))) + (buffer-substring (hashcash-point-at-bol) (hashcash-point-at-eol))) nil)) (defun hashcash-check-payment (token str val) @@ -170,11 +180,11 @@ Prefix arg sets default accept amount temporarily." (goto-char (point-min)) (while (and (not ok) (search-forward "X-Payment: hashcash 1.1 " end t)) (setq ok (hashcash-verify-payment - (buffer-substring (point) (point-at-eol))))) + (buffer-substring (point) (hashcash-point-at-eol))))) (goto-char (point-min)) (while (and (not ok) (search-forward "X-Hashcash: " end t)) (setq ok (hashcash-verify-payment - (buffer-substring (point) (point-at-eol))))) + (buffer-substring (point) (hashcash-point-at-eol))))) (when ok (message "Payment valid")) ok)))) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 317eef8..9147072 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,14 @@ +2003-02-21 Florian Weimer + From Reiner Steib . + + * gnus-art.el (gnus-button-mid-or-mail-heuristic-alist): New + variable, used in `gnus-button-mid-or-mail-heuristic'. + (gnus-button-mid-or-mail-heuristic): New function derived from + Florian Weimer's Perl script. + (gnus-button-handle-mid-or-mail): Allow a function instead of + 'guess. + (gnus-button-guessed-mid-regexp): Removed. + 2003-02-20 Katsumi Yamaoka * message.el (message-resend): Bind message-setup-hook to nil; diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index b36a471..8df097f 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -5944,57 +5944,171 @@ The function must take one argument, the string naming the URL." :group 'gnus-article-buttons :type 'regexp) -(defcustom gnus-button-prefer-mid-or-mail 'guess - "What to do when the button on a string as \"foo123@bar.com\" is pushed. -Strings like this can be either a message ID or a mail address. If the -variable is set to the symbol `ask', query the user what do do. If it is the -symbol `guess', Gnus will do a guess and query the user what do do if it is -ambiguous. See the variable `gnus-button-guessed-mid-regexp' for details -concerning the guessing. If it is one of the sybols `mid' or `mail', Gnus -will always assume that the string is a message ID or a mail address, -respectivly." - ;; FIXME: doc-string could/should be improved. +(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic + "What to do when the button on a string as \"foo123@bar.invalid\" is pushed. +Strings like this can be either a message ID or a mail address. If it is one +of the symbols `mid' or `mail', Gnus will always assume that the string is a +message ID or a mail address, respectivly. If this variable is set to the +symbol `ask', always query the user what do do. If it is a function, this +function will be called with the string as it's only argument. The function +must return `mid', `mail', `invalid' or `ask'." :group 'gnus-article-buttons - :type '(choice (const ask) - (const guess) + :type '(choice (function-item :tag "Heuristic function" + gnus-button-mid-or-mail-heuristic) + (const ask) (const mid) (const mail))) -(defcustom gnus-button-guessed-mid-regexp - (concat - "^. I.e. translate the - ;; Perl-REs to Elisp-REs. +(defcustom gnus-button-mid-or-mail-heuristic-alist + '((-10.0 . ".+\\$.+@") + (-10.0 . "#") + (-10.0 . "\\*") + (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs + (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i + (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i; + (-1.0 . "^[^a-z]+@") + + (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@" + (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@" + (-3.0 . "[A-Z][A-Z][a-z][a-z].*@") + (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@") + + (-2.0 . "^[0-9]") + (-1.0 . "^[0-9][0-9]") + ;; + ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/; + (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/; + (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; + (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@" + (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@") + ;; "[0-9]{8,}.*\@" + (-3.0 + . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@") + ;; "[0-9]{12,}.*\@" + ;; + (-20.0 . "\\.fsf@") ;; Gnus + (-20.0 . "^slrn") + (-20.0 . "^Pine") + (-20.0 . "_-_") ;; Subject change in thread + ;; + (-20.0 . "\\.ln@") ;; leafnode + (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de") + (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent + ;; + ;; (5.0 . "") ;; $local_part_len <= 7 + (10.0 . "^[^0-9]+@") + (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@") + ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part + (3.0 . "\@stud") + ;; + (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@") + ;; + (0.5 . "^[A-Z][a-z]") + (0.5 . "^[A-Z][a-z][a-z]") + (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3} + (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4} + "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'. + +A negative RATE indicates a message IDs, whereas a positive indicates a mail +address. The REGEXP is processed with `case-fold-search' set to `nil'." :group 'gnus-article-buttons - :type 'regexp) + :type '(repeat (cons (number :tag "Rate") + (regexp :tag "Regexp")))) + +(defun gnus-button-mid-or-mail-heuristic (mid-or-mail) + "Guess whether MID-OR-MAIL is a message ID or a mail address. +Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail +address, `ask' if unsure and `invalid' if the string is invalid." + (let ((case-fold-search nil) + (list gnus-button-mid-or-mail-heuristic-alist) + (result 0) rate regexp lpartlen elem) + (setq lpartlen + (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1"))) + (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen) + ;; Certain special cases... + (when (string-match + (concat + "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$" "\\|" + "^[0-9]+\.[0-9]+\@compuserve") + mid-or-mail) + (gnus-message 8 "`%s' is a known mail address.") + (setq result 'mail)) + (when (string-match "@.*@\\| " mid-or-mail) + (gnus-message 8 "`%s' is invalid.") + (setq result 'invalid)) + ;; Nothing more to do, if result is not a number here... + (when (numberp result) + (while list + (setq elem (car list) + rate (car elem) + regexp (cdr elem) + list (cdr list)) + (when (string-match regexp mid-or-mail) + (setq result (+ result rate)) + (gnus-message + 9 "`%s' matched `%s', rate `%s', result `%s'." + mid-or-mail regexp rate result))) + (when (<= lpartlen 7) + (setq result (+ result 5.0)) + (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'." + mid-or-mail result)) + (when (>= lpartlen 12) + (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail) + (cond + ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail) + ;; Long local part should contain realname if e-mail address, + ;; too many digits: message-id. + ;; $score -= 5.0 + 0.1 * $local_part_len; + (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen)))) + (setq result (+ result rate)) + (gnus-message + 9 "Many digits in `%s', rate `%s', result `%s'." + mid-or-mail rate result)) + ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@" + mid-or-mail) + ;; Too few vowels [^aeiouy]{4,}.*\@ + (setq result (+ result -5.0)) + (gnus-message + 9 "Few vowels in `%s', rate `%s', result `%s'." + mid-or-mail -5.0 result)) + (t + (setq result (+ result 5.0)) + (gnus-message + 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result))))) + (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result) + (cond + ;; Maybe we should make this a customizable alist: (condition . 'result) + ((< result -10.0) 'mid) + ((> result 10.0) 'mail) + (t 'ask)))) (defun gnus-button-handle-mid-or-mail (mid-or-mail) - (let* ((pref gnus-button-prefer-mid-or-mail) + (let* ((pref gnus-button-prefer-mid-or-mail) guessed (url-mid (concat "news" ":" mid-or-mail)) (url-mailto (concat "mailto" ":" mid-or-mail))) (gnus-message 9 "mid-or-mail=%s" mid-or-mail) - ;; If it looks like a MID (well known readers or servers) use 'mid, - ;; otherwise 'ask the user. - (if (eq pref 'guess) - (if (string-match gnus-button-guessed-mid-regexp mid-or-mail) - (setq pref 'mid) - (setq pref 'ask))) + (when (fboundp pref) + (setq guessed + ;; get rid of surrounding angles... + (funcall pref + (gnus-replace-in-string mid-or-mail "^<\\|>$" ""))) + (if (or (eq 'mid guessed) (eq 'mail guessed)) + (setq pref guessed) + (setq pref 'ask))) (if (eq pref 'ask) (save-window-excursion (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? ")) (setq pref 'mail) (setq pref 'mid)))) (cond ((eq pref 'mid) - (gnus-message 9 "calling `gnus-button-handle-news' %s" url-mid) + (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid) (gnus-button-handle-news url-mid)) ((eq pref 'mail) - (gnus-message 9 "calling `gnus-url-mailto' %s" url-mailto) - (gnus-url-mailto url-mailto))))) + (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto) + (gnus-url-mailto url-mailto)) + (t (gnus-message 3 "Invalid string."))))) (defun gnus-button-handle-custom (url) "Follow a Custom URL." -- 1.7.10.4