From 3645f727c877da6b3f8a46dbc476dc000b9ac75d Mon Sep 17 00:00:00 2001 From: yamaoka Date: Mon, 27 Sep 2004 22:13:48 +0000 Subject: [PATCH] Synch to No Gnus 200409271949. --- contrib/ChangeLog | 4 + contrib/hashcash.el | 207 --------------------------------------------- lisp/ChangeLog | 20 +++++ lisp/gnus-art.el | 29 +++---- lisp/gnus-async.el | 12 ++- lisp/gnus-cache.el | 65 +++++++-------- lisp/hashcash.el | 232 +++++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 300 insertions(+), 269 deletions(-) delete mode 100644 contrib/hashcash.el create mode 100644 lisp/hashcash.el diff --git a/contrib/ChangeLog b/contrib/ChangeLog index d386d84..fed0626 100644 --- a/contrib/ChangeLog +++ b/contrib/ChangeLog @@ -1,3 +1,7 @@ +2004-09-27 Simon Josefsson + + * hashcash.el: Move to ../lisp/. + 2004-07-30 TSUCHIYA Masatoshi * gnus-namazu.el (gnus-namazu/make-directory-table): Treat drive diff --git a/contrib/hashcash.el b/contrib/hashcash.el deleted file mode 100644 index 84dfcae..0000000 --- a/contrib/hashcash.el +++ /dev/null @@ -1,207 +0,0 @@ -;;; hashcash.el --- Add hashcash payments to email - -;; Copyright (C) 2003 Free Software Foundation -;; Copyright (C) 1997--2002 Paul E. Foley - -;; Maintainer: Paul Foley -;; Keywords: mail, hashcash - -;; Released under the GNU General Public License -;; (http://www.gnu.org/licenses/gpl.html) - -;;; Commentary: - -;; The hashcash binary is at http://www.cypherspace.org/hashcash/ -;; -;; Call mail-add-payment to add a hashcash payment to a mail message -;; in the current buffer. -;; -;; To automatically add payments to all outgoing mail: -;; (add-hook 'message-send-hook 'mail-add-payment) - -;;; Code: - -(eval-and-compile - (autoload 'executable-find "executable")) - -(defcustom hashcash-default-payment 0 - "*The default number of bits to pay to unknown users. -If this is zero, no payment header will be generated. -See `hashcash-payment-alist'." - :type 'integer) - -(defcustom hashcash-payment-alist '() - "*An association list mapping email addresses to payment amounts. -Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where -ADDR is the email address of the intended recipient and AMOUNT is -the value of hashcash payment to be made to that user. STRING, if -present, is the string to be hashed; if not present ADDR will be used.") - -(defcustom hashcash-default-accept-payment 10 - "*The default minimum number of bits to accept on incoming payments." - :type 'integer) - -(defcustom hashcash-accept-resources `((,user-mail-address nil)) - "*An association list mapping hashcash resources to payment amounts. -Resources named here are to be accepted in incoming payments. If the -corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment' -is used instead.") - -(defcustom hashcash-path (executable-find "hashcash") - "*The path to the hashcash binary.") - -(defcustom hashcash-double-spend-database "hashcash.db" - "*The path to the double-spending database.") - -(defcustom hashcash-in-news nil - "*Specifies whether or not hashcash payments should be made to newsgroups." - :type 'boolean) - -(require 'mail-utils) - -(eval-and-compile - (if (fboundp 'point-at-bol) - (defalias 'hashcash-point-at-bol 'point-at-bol) - (defalias 'hashcash-point-at-bol 'line-beginning-position)) - - (if (fboundp 'point-at-eol) - (defalias 'hashcash-point-at-eol 'point-at-eol) - (defalias 'hashcash-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)) - (concat (match-string 1 addr) (match-string 2 addr)) - addr)) - -(defun hashcash-payment-required (addr) - "Return the hashcash payment value required for the given address." - (let ((val (assoc addr hashcash-payment-alist))) - (or (nth 2 val) (nth 1 val) hashcash-default-payment))) - -(defun hashcash-payment-to (addr) - "Return the string with which hashcash payments should collide." - (let ((val (assoc addr hashcash-payment-alist))) - (or (nth 1 val) (nth 0 val) addr))) - -(defun hashcash-generate-payment (str val) - "Generate a hashcash payment by finding a VAL-bit collison on STR." - (if (> val 0) - (save-excursion - (set-buffer (get-buffer-create " *hashcash*")) - (erase-buffer) - (call-process hashcash-path nil t nil - "-m" "-q" "-b" (number-to-string val) str) - (goto-char (point-min)) - (buffer-substring (hashcash-point-at-bol) (hashcash-point-at-eol))) - nil)) - -(defun hashcash-check-payment (token str val) - "Check the validity of a hashcash payment." - (zerop (call-process hashcash-path nil nil nil "-c" - "-d" "-f" hashcash-double-spend-database - "-b" (number-to-string val) - "-r" str - token))) - -(defun hashcash-version (token) - "Find the format version of a hashcash token." - ;; Version 1.2 looks like n:yymmdd:rrrrr:xxxxxxxxxxxxxxxx - ;; This carries its own version number embedded in the token, - ;; so no further format number changes should be necessary - ;; in the X-Payment header. - ;; - ;; Version 1.1 looks like yymmdd:rrrrr:xxxxxxxxxxxxxxxx - ;; You need to upgrade your hashcash binary. - ;; - ;; Version 1.0 looked like nnnnnrrrrrxxxxxxxxxxxxxxxx - ;; This is no longer supported. - (cond ((equal (aref token 1) ?:) 1.2) - ((equal (aref token 6) ?:) 1.1) - (t (error "Unknown hashcash format version")))) - -;;;###autoload -(defun hashcash-insert-payment (arg) - "Insert X-Payment and X-Hashcash headers with a payment for ARG" - (interactive "sPay to: ") - (let ((pay (hashcash-generate-payment (hashcash-payment-to arg) - (hashcash-payment-required arg)))) - (when pay -; (insert-before-markers "X-Payment: hashcash " -; (number-to-string (hashcash-version pay)) " " -; pay "\n") - (insert-before-markers "X-Hashcash: " pay "\n")))) - -;;;###autoload -(defun hashcash-verify-payment (token &optional resource amount) - "Verify a hashcash payment" - (let ((key (if (< (hashcash-version token) 1.2) - (nth 1 (split-string token ":")) - (nth 2 (split-string token ":"))))) - (cond ((null resource) - (let ((elt (assoc key hashcash-accept-resources))) - (and elt (hashcash-check-payment token (car elt) - (or (cadr elt) hashcash-default-accept-payment))))) - ((equal token key) - (hashcash-check-payment token resource - (or amount hashcash-default-accept-payment))) - (t nil)))) - -;;;###autoload -(defun mail-add-payment (&optional arg) - "Add X-Payment: and X-Hashcash: headers with a hashcash payment -for each recipient address. Prefix arg sets default payment temporarily." - (interactive "P") - (let ((hashcash-default-payment (if arg (prefix-numeric-value arg) - hashcash-default-payment)) - (addrlist nil)) - (save-excursion - (save-restriction - (goto-char (point-min)) - (search-forward mail-header-separator) - (beginning-of-line) - (narrow-to-region (point-min) (point)) - (let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t))) - (cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t))) - (ng (hashcash-strip-quoted-names (mail-fetch-field "Newsgroups" - nil t)))) - (when to - (setq addrlist (split-string to ",[ \t\n]*"))) - (when cc - (setq addrlist (nconc addrlist (split-string cc ",[ \t\n]*")))) - (when (and hashcash-in-news ng) - (setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*"))))) - (when addrlist - (mapcar #'hashcash-insert-payment addrlist))))) ; mapc - t) - -;;;###autoload -(defun mail-check-payment (&optional arg) - "Look for a valid X-Payment: or X-Hashcash: header. -Prefix arg sets default accept amount temporarily." - (interactive "P") - (let ((hashcash-default-accept-payment (if arg (prefix-numeric-value arg) - hashcash-default-accept-payment)) - (version (hashcash-version (hashcash-generate-payment "x" 1)))) - (save-excursion - (goto-char (point-min)) - (search-forward "\n\n") - (beginning-of-line) - (let ((end (point)) - (ok nil)) - (goto-char (point-min)) - (while (and (not ok) (search-forward "X-Payment: hashcash " end t)) - (let ((value (split-string - (buffer-substring (point) (hashcash-point-at-eol)) - " "))) - (when (equal (car value) (number-to-string version)) - (setq ok (hashcash-verify-payment (cadr value)))))) - (goto-char (point-min)) - (while (and (not ok) (search-forward "X-Hashcash: " end t)) - (setq ok (hashcash-verify-payment - (buffer-substring (point) (hashcash-point-at-eol))))) - (when ok - (message "Payment valid")) - ok)))) - -(provide 'hashcash) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d73e732..eefaeb5 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,23 @@ +2004-09-27 Jesper Harder + + * gnus-cache.el (gnus-cache-possibly-remove-articles-1) + (gnus-cache-enter-article, gnus-cache-remove-article) + (gnus-cache-braid-heads, gnus-cache-generate-active): Use dolist. + + * gnus-async.el (gnus-async-prefetch-remove-group): do. + + * gnus-art.el (article-hide-boring-headers) + (article-translate-strings, article-display-face) + (gnus-article-mime-match-handle-first) + (gnus-article-highlight-headers) + (gnus-article-add-buttons-to-head): do. + +2004-09-27 Simon Josefsson + + * hashcash.el: New version, from + http://users.actrix.co.nz/mycroft/hashcash.el. Previously in + ../contrib/. + 2004-09-27 Katsumi Yamaoka * mm-decode.el (mm-copy-to-buffer): Don't use set-buffer-multibyte. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 174c983..55e12a2 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1775,12 +1775,9 @@ always hide." (save-excursion (save-restriction (let ((inhibit-read-only t) - (list gnus-boring-article-headers) - (inhibit-point-motion-hooks t) - elem) + (inhibit-point-motion-hooks t)) (article-narrow-to-head) - (while list - (setq elem (pop list)) + (dolist (elem gnus-boring-article-headers) (goto-char (point-min)) (cond ;; Hide empty headers. @@ -1988,9 +1985,8 @@ characters to translate to." MAP is an alist where the elements are on the form (\"from\" \"to\")." (save-excursion (when (article-goto-body) - (let ((inhibit-read-only t) - elem) - (while (setq elem (pop map)) + (let ((inhibit-read-only t)) + (dolist (elem map) (save-excursion (while (search-forward (car elem) nil t) (replace-match (cadr elem))))))))) @@ -2214,7 +2210,7 @@ unfolded." (mail-narrow-to-head) (while (gnus-article-goto-header "Face") (setq faces (nconc faces (list (mail-header-field-value))))))) - (while (setq face (pop faces)) + (dolist (face faces) (let ((png (gnus-convert-face-to-png face)) image) (when png @@ -4743,8 +4739,8 @@ N is the numerical prefix." (defun gnus-article-mime-match-handle-first (condition) (if condition - (let ((alist gnus-article-mime-handle-alist) ihandle n) - (while (setq ihandle (pop alist)) + (let (n) + (dolist (ihandle gnus-article-mime-handle-alist) (if (and (cond ((functionp condition) (funcall condition (cdr ihandle))) @@ -6827,9 +6823,8 @@ do the highlighting. See the documentation for those functions." "Highlight article headers as specified by `gnus-header-face-alist'." (interactive) (gnus-with-article-headers - (let ((alist gnus-header-face-alist) - entry regexp header-face field-face from hpoints fpoints) - (while (setq entry (pop alist)) + (let (regexp header-face field-face from hpoints fpoints) + (dolist (entry gnus-header-face-alist) (goto-char (point-min)) (setq regexp (concat "^\\(" (if (string-equal "" (nth 0 entry)) @@ -6934,11 +6929,9 @@ specified by `gnus-button-alist'." "Add buttons to the head of the article." (interactive) (gnus-with-article-headers - (let ((alist gnus-header-button-alist) - entry beg end) - (while alist + (let (beg end) + (dolist (entry gnus-header-button-alist) ;; Each alist entry. - (setq entry (pop alist)) (goto-char (point-min)) (while (re-search-forward (car entry) nil t) ;; Each header matching the entry. diff --git a/lisp/gnus-async.el b/lisp/gnus-async.el index f3a43c9..86086a2 100644 --- a/lisp/gnus-async.el +++ b/lisp/gnus-async.el @@ -306,13 +306,11 @@ It should return non-nil if the article is to be prefetched." "Remove all articles belonging to GROUP from the prefetch buffer." (when (and (gnus-group-asynchronous-p group) (memq 'exit gnus-prefetched-article-deletion-strategy)) - (let ((alist gnus-async-article-alist)) - (save-excursion - (gnus-async-set-buffer) - (while alist - (when (equal group (nth 3 (car alist))) - (gnus-async-delete-prefetched-entry (car alist))) - (pop alist)))))) + (save-excursion + (gnus-async-set-buffer) + (dolist (entry gnus-async-article-alist) + (when (equal group (nth 3 entry)) + (gnus-async-delete-prefetched-entry entry)))))) (defun gnus-async-prefetched-article-entry (group article) "Return the entry for ARTICLE in GROUP iff it has been prefetched." diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index 1054b3f..8fad811 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -245,12 +245,10 @@ it's not cached." (defun gnus-cache-possibly-remove-articles-1 () "Possibly remove some of the removable articles." (when (gnus-cache-fully-p gnus-newsgroup-name) - (let ((articles gnus-cache-removable-articles) - (cache-articles gnus-newsgroup-cached) - article) + (let ((cache-articles gnus-newsgroup-cached)) (gnus-cache-change-buffer gnus-newsgroup-name) - (while articles - (when (memq (setq article (pop articles)) cache-articles) + (dolist (article gnus-cache-removable-articles) + (when (memq article cache-articles) ;; The article was in the cache, so we see whether we are ;; supposed to remove it from the cache. (gnus-cache-possibly-remove-article @@ -334,9 +332,8 @@ it's not cached." If not given a prefix, use the process marked articles instead. Returns the list of articles entered." (interactive "P") - (let ((articles (gnus-summary-work-articles n)) - article out) - (while (setq article (pop articles)) + (let (out) + (dolist (article (gnus-summary-work-articles n)) (gnus-summary-remove-process-mark article) (if (natnump article) (when (gnus-cache-possibly-enter-article @@ -358,10 +355,8 @@ If not given a prefix, use the process marked articles instead. Returns the list of articles removed." (interactive "P") (gnus-cache-change-buffer gnus-newsgroup-name) - (let ((articles (gnus-summary-work-articles n)) - article out) - (while articles - (setq article (pop articles)) + (let (out) + (dolist (article (gnus-summary-work-articles n)) (gnus-summary-remove-process-mark article) (when (gnus-cache-possibly-remove-article article nil nil nil t) (when gnus-newsgroup-agentized @@ -547,35 +542,32 @@ Returns the list of articles removed." (defun gnus-cache-braid-heads (group cached) (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) - (save-excursion - (set-buffer cache-buf) + (with-current-buffer cache-buf (erase-buffer)) (set-buffer nntp-server-buffer) (goto-char (point-min)) - (while cached + (dolist (entry cached) (while (and (not (eobp)) (looking-at "2.. +\\([0-9]+\\) ") (< (progn (goto-char (match-beginning 1)) (read (current-buffer))) - (car cached))) + entry)) (search-forward "\n.\n" nil 'move)) (beginning-of-line) - (save-excursion - (set-buffer cache-buf) - (erase-buffer) - (let ((nnheader-file-coding-system gnus-cache-coding-system)) - (nnheader-insert-file-contents - (gnus-cache-file-name group (car cached)))) - (goto-char (point-min)) - (insert "220 ") - (princ (car cached) (current-buffer)) - (insert " Article retrieved.\n") - (search-forward "\n\n" nil 'move) - (delete-region (point) (point-max)) - (forward-char -1) - (insert ".")) - (insert-buffer-substring cache-buf) - (setq cached (cdr cached))) + (set-buffer cache-buf) + (erase-buffer) + (let ((nnheader-file-coding-system gnus-cache-coding-system)) + (nnheader-insert-file-contents (gnus-cache-file-name group entry))) + (goto-char (point-min)) + (insert "220 ") + (princ (car cached) (current-buffer)) + (insert " Article retrieved.\n") + (search-forward "\n\n" nil 'move) + (delete-region (point) (point-max)) + (forward-char -1) + (insert ".") + (set-buffer nntp-server-buffer) + (insert-buffer-substring cache-buf)) (kill-buffer cache-buf))) ;;;###autoload @@ -699,13 +691,12 @@ If LOW, update the lower bound instead." (gnus-sethash group (cons (car nums) (gnus-last-element nums)) gnus-cache-active-hashtb)) ;; Go through all the other files. - (while alphs - (when (and (file-directory-p (car alphs)) + (dolist (file alphs) + (when (and (file-directory-p file) (not (string-match "^\\." - (file-name-nondirectory (car alphs))))) + (file-name-nondirectory file)))) ;; We descend directories. - (gnus-cache-generate-active (car alphs))) - (setq alphs (cdr alphs))) + (gnus-cache-generate-active file))) ;; Write the new active file. (when top (gnus-cache-write-active t) diff --git a/lisp/hashcash.el b/lisp/hashcash.el new file mode 100644 index 0000000..15383a0 --- /dev/null +++ b/lisp/hashcash.el @@ -0,0 +1,232 @@ +;;; hashcash.el --- Add hashcash payments to email + +;; Copyright (C) 1997--2002 Paul E. Foley +;; Copyright (C) 2003 Free Software Foundation + +;; Maintainer: Paul Foley +;; Keywords: mail, hashcash + +;; 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The hashcash binary is at http://www.cypherspace.org/hashcash/ +;; +;; Call mail-add-payment to add a hashcash payment to a mail message +;; in the current buffer. +;; +;; To automatically add payments to all outgoing mail: +;; (add-hook 'message-send-hook 'mail-add-payment) + +;;; Code: + +(eval-and-compile + (autoload 'executable-find "executable")) + +(defcustom hashcash-default-payment 10 + "*The default number of bits to pay to unknown users. +If this is zero, no payment header will be generated. +See `hashcash-payment-alist'." + :type 'integer) + +(defcustom hashcash-payment-alist '() + "*An association list mapping email addresses to payment amounts. +Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where +ADDR is the email address of the intended recipient and AMOUNT is +the value of hashcash payment to be made to that user. STRING, if +present, is the string to be hashed; if not present ADDR will be used.") + +(defcustom hashcash-default-accept-payment 10 + "*The default minimum number of bits to accept on incoming payments." + :type 'integer) + +(defcustom hashcash-accept-resources `((,user-mail-address nil)) + "*An association list mapping hashcash resources to payment amounts. +Resources named here are to be accepted in incoming payments. If the +corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment' +is used instead.") + +(defcustom hashcash-path (executable-find "hashcash") + "*The path to the hashcash binary.") + +(defcustom hashcash-double-spend-database "hashcash.db" + "*The path to the double-spending database.") + +(defcustom hashcash-in-news nil + "*Specifies whether or not hashcash payments should be made to newsgroups." + :type 'boolean) + +(require 'mail-utils) + +(eval-and-compile + (if (fboundp 'point-at-bol) + (defalias 'hashcash-point-at-bol 'point-at-bol) + (defalias 'hashcash-point-at-bol 'line-beginning-position)) + + (if (fboundp 'point-at-eol) + (defalias 'hashcash-point-at-eol 'point-at-eol) + (defalias 'hashcash-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)) + (concat (match-string 1 addr) (match-string 2 addr)) + addr)) + +(defun hashcash-token-substring () + (save-excursion + (let ((token "")) + (loop + (setq token + (concat token (buffer-substring (point) (hashcash-point-at-eol)))) + (goto-char (hashcash-point-at-eol)) + (forward-char 1) + (unless (looking-at "[ \t]") (return token)) + (while (looking-at "[ \t]") (forward-char 1)))))) + +(defun hashcash-payment-required (addr) + "Return the hashcash payment value required for the given address." + (let ((val (assoc addr hashcash-payment-alist))) + (or (nth 2 val) (nth 1 val) hashcash-default-payment))) + +(defun hashcash-payment-to (addr) + "Return the string with which hashcash payments should collide." + (let ((val (assoc addr hashcash-payment-alist))) + (or (nth 1 val) (nth 0 val) addr))) + +(defun hashcash-generate-payment (str val) + "Generate a hashcash payment by finding a VAL-bit collison on STR." + (if (> val 0) + (save-excursion + (set-buffer (get-buffer-create " *hashcash*")) + (erase-buffer) + (call-process hashcash-path nil t nil + "-m" "-q" "-b" (number-to-string val) str) + (goto-char (point-min)) + (hashcash-token-substring)) + nil)) + +(defun hashcash-check-payment (token str val) + "Check the validity of a hashcash payment." + (zerop (call-process hashcash-path nil nil nil "-c" + "-d" "-f" hashcash-double-spend-database + "-b" (number-to-string val) + "-r" str + token))) + +(defun hashcash-version (token) + "Find the format version of a hashcash token." + ;; Version 1.2 looks like n:yymmdd:rrrrr:xxxxxxxxxxxxxxxx + ;; This carries its own version number embedded in the token, + ;; so no further format number changes should be necessary + ;; in the X-Payment header. + ;; + ;; Version 1.1 looks like yymmdd:rrrrr:xxxxxxxxxxxxxxxx + ;; You need to upgrade your hashcash binary. + ;; + ;; Version 1.0 looked like nnnnnrrrrrxxxxxxxxxxxxxxxx + ;; This is no longer supported. + (cond ((equal (aref token 1) ?:) 1.2) + ((equal (aref token 6) ?:) 1.1) + (t (error "Unknown hashcash format version")))) + +;;;###autoload +(defun hashcash-insert-payment (arg) + "Insert X-Payment and X-Hashcash headers with a payment for ARG" + (interactive "sPay to: ") + (let ((pay (hashcash-generate-payment (hashcash-payment-to arg) + (hashcash-payment-required arg)))) + (when pay +;; (insert-before-markers "X-Payment: hashcash " +;; (number-to-string (hashcash-version pay)) " " +;; pay "\n") + (insert-before-markers "X-Hashcash: " pay "\n")))) + +;;;###autoload +(defun hashcash-verify-payment (token &optional resource amount) + "Verify a hashcash payment" + (let* ((split (split-string token ":")) + (key (if (< (hashcash-version token) 1.2) + (nth 1 split) + (case (string-to-number (nth 0 split)) + (0 (nth 2 split)) + (1 (nth 3 split)))))) + (cond ((null resource) + (let ((elt (assoc key hashcash-accept-resources))) + (and elt (hashcash-check-payment token (car elt) + (or (cadr elt) hashcash-default-accept-payment))))) + ((equal token key) + (hashcash-check-payment token resource + (or amount hashcash-default-accept-payment))) + (t nil)))) + +;;;###autoload +(defun mail-add-payment (&optional arg) + "Add X-Payment: and X-Hashcash: headers with a hashcash payment +for each recipient address. Prefix arg sets default payment temporarily." + (interactive "P") + (let ((hashcash-default-payment (if arg (prefix-numeric-value arg) + hashcash-default-payment)) + (addrlist nil)) + (save-excursion + (save-restriction + (goto-char (point-min)) + (search-forward mail-header-separator) + (beginning-of-line) + (narrow-to-region (point-min) (point)) + (let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t))) + (cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t))) + (ng (hashcash-strip-quoted-names (mail-fetch-field "Newsgroups" + nil t)))) + (when to + (setq addrlist (split-string to ",[ \t\n]*"))) + (when cc + (setq addrlist (nconc addrlist (split-string cc ",[ \t\n]*")))) + (when (and hashcash-in-news ng) + (setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*"))))) + (when addrlist + (mapcar #'hashcash-insert-payment addrlist))))) ; mapc + t) + +;;;###autoload +(defun mail-check-payment (&optional arg) + "Look for a valid X-Payment: or X-Hashcash: header. +Prefix arg sets default accept amount temporarily." + (interactive "P") + (let ((hashcash-default-accept-payment (if arg (prefix-numeric-value arg) + hashcash-default-accept-payment)) + (version (hashcash-version (hashcash-generate-payment "x" 1)))) + (save-excursion + (goto-char (point-min)) + (search-forward "\n\n") + (beginning-of-line) + (let ((end (point)) + (ok nil)) + (goto-char (point-min)) + (while (and (not ok) (search-forward "X-Payment: hashcash " end t)) + (let ((value (split-string (hashcash-token-substring) " "))) + (when (equal (car value) (number-to-string version)) + (setq ok (hashcash-verify-payment (cadr value)))))) + (goto-char (point-min)) + (while (and (not ok) (search-forward "X-Hashcash: " end t)) + (setq ok (hashcash-verify-payment (hashcash-token-substring)))) + (when ok + (message "Payment valid")) + ok)))) + +(provide 'hashcash) -- 1.7.10.4