X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fhashcash.el;h=cc3af11a47d860760e807c06136df16b780cd6ce;hb=0f63151c0cfcb3498678c203edb84e6a1d2b57e0;hp=94b140dc5acd2f51fb82223447746b4ac647ef79;hpb=fee1f282c0975f6e020aa285d44c5b20b417b8bc;p=gnus diff --git a/lisp/hashcash.el b/lisp/hashcash.el index 94b140dc5..cc3af11a4 100644 --- a/lisp/hashcash.el +++ b/lisp/hashcash.el @@ -1,6 +1,7 @@ ;;; hashcash.el --- Add hashcash payments to email -;; Copyright (C) 2003, 2004, 2005 Free Software Foundation +;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009, 2010 +;; Free Software Foundation ;; Written by: Paul Foley (1997-2002) ;; Maintainer: Paul Foley @@ -8,20 +9,18 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, 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 +;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -50,13 +49,20 @@ ;;; Code: (eval-and-compile - (autoload 'executable-find "executable")) + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + +(eval-when-compile (require 'cl)) ; for case + +(defgroup hashcash nil + "Hashcash configuration." + :group 'mail) (defcustom hashcash-default-payment 20 "*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) + :type 'integer + :group 'hashcash) (defcustom hashcash-payment-alist '() "*An association list mapping email addresses to payment amounts. @@ -70,32 +76,39 @@ present, is the string to be hashed; if not present ADDR will be used." (list :tag "Replace hash input" (string :name "Address") (string :name "Hash input") - (integer :name "Amount"))))) + (integer :name "Amount")))) + :group 'hashcash) (defcustom hashcash-default-accept-payment 20 "*The default minimum number of bits to accept on incoming payments." - :type 'integer) + :type 'integer + :group 'hashcash) (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.") +is used instead." + :group 'hashcash) (defcustom hashcash-path (executable-find "hashcash") - "*The path to the hashcash binary.") + "*The path to the hashcash binary." + :group 'hashcash) (defcustom hashcash-extra-generate-parameters nil "*A list of parameter strings passed to `hashcash-path' when minting. For example, you may want to set this to '(\"-Z2\") to reduce header length." - :type '(repeat string)) + :type '(repeat string) + :group 'hashcash) (defcustom hashcash-double-spend-database "hashcash.db" - "*The path to the double-spending database.") + "*The path to the double-spending database." + :group 'hashcash) (defcustom hashcash-in-news nil "*Specifies whether or not hashcash payments should be made to newsgroups." - :type 'boolean) + :type 'boolean + :group 'hashcash) (defvar hashcash-process-alist nil "Alist of asynchronous hashcash processes and buffers.") @@ -103,13 +116,13 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length." (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-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))) + (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)) @@ -117,6 +130,11 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length." (concat (match-string 1 addr) (match-string 2 addr)) addr)) +(declare-function message-narrow-to-headers-or-head "message" ()) +(declare-function message-fetch-field "message" (header &optional not-all)) +(declare-function message-goto-eoh "message" ()) +(declare-function message-narrow-to-headers "message" ()) + (defun hashcash-token-substring () (save-excursion (let ((token "")) @@ -142,8 +160,7 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length." "Generate a hashcash payment by finding a VAL-bit collison on STR." (if (and (> val 0) hashcash-path) - (save-excursion - (set-buffer (get-buffer-create " *hashcash*")) + (with-current-buffer (get-buffer-create " *hashcash*") (erase-buffer) (apply 'call-process hashcash-path nil t nil "-m" "-q" "-b" (number-to-string val) str @@ -155,7 +172,8 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length." (defun hashcash-generate-payment-async (str val callback) "Generate a hashcash payment by finding a VAL-bit collison on STR. Return immediately. Call CALLBACK with process and result when ready." - (if (> val 0) + (if (and (> val 0) + hashcash-path) (let ((process (apply 'start-process "hashcash" nil hashcash-path "-m" "-q" "-b" (number-to-string val) str @@ -165,7 +183,7 @@ Return immediately. Call CALLBACK with process and result when ready." hashcash-process-alist)) (set-process-filter process `(lambda (process output) (funcall ,callback process output)))) - (funcall callback nil))) + (funcall callback nil nil))) (defun hashcash-check-payment (token str val) "Check the validity of a hashcash payment." @@ -201,7 +219,8 @@ Return immediately. Call CALLBACK with process and result when ready." (save-excursion (save-restriction (message-narrow-to-headers-or-head) - (let ((token (message-fetch-field "x-hashcash"))) + (let ((token (message-fetch-field "x-hashcash")) + (case-fold-search t)) (and (stringp token) (string-match (regexp-quote recipient) token)))))) @@ -213,9 +232,6 @@ Return immediately. Call CALLBACK with process and result when ready." (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 @@ -224,26 +240,23 @@ Return immediately. Call CALLBACK with process and result when ready." Only start calculation. Results are inserted when ready." (interactive "sPay to: ") (unless (hashcash-already-paid-p arg) - (hashcash-generate-payment-async (hashcash-payment-to arg) - (hashcash-payment-required arg) - `(lambda (process payment) - (hashcash-insert-payment-async-2 ,(current-buffer) process payment))))) + (hashcash-generate-payment-async + (hashcash-payment-to arg) + (hashcash-payment-required arg) + `(lambda (process payment) + (hashcash-insert-payment-async-2 ,(current-buffer) process payment))))) (defun hashcash-insert-payment-async-2 (buffer process pay) - (with-current-buffer buffer - (save-excursion - (save-restriction - (setq hashcash-process-alist (delq - (assq process hashcash-process-alist) - hashcash-process-alist)) - (goto-char (point-min)) - (search-forward mail-header-separator) - (beginning-of-line) - (when pay -;; (insert-before-markers "X-Payment: hashcash " -;; (number-to-string (hashcash-version pay)) " " -;; pay "\n") - (insert-before-markers "X-Hashcash: " pay)))))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (save-restriction + (setq hashcash-process-alist (delq + (assq process hashcash-process-alist) + hashcash-process-alist)) + (message-goto-eoh) + (when pay + (insert-before-markers "X-Hashcash: " pay))))))) (defun hashcash-cancel-async (&optional buffer) "Delete any hashcash processes associated with BUFFER. @@ -263,7 +276,7 @@ BUFFER defaults to the current buffer." (unless buffer (setq buffer (current-buffer))) (let (entry) (while (setq entry (rassq buffer hashcash-process-alist)) - (accept-process-output (car entry))))) + (accept-process-output (car entry) 1)))) (defun hashcash-processes-running-p (buffer) "Return non-nil if hashcash processes in BUFFER are still running." @@ -273,7 +286,7 @@ BUFFER defaults to the current buffer." "Ask user whether to wait for hashcash processes to finish." (interactive) (when (hashcash-processes-running-p (current-buffer)) - (if (y-or-n-p + (if (y-or-n-p "Hashcash process(es) still running; wait for them to finish? ") (hashcash-wait-async) (hashcash-cancel-async)))) @@ -308,10 +321,7 @@ Set ASYNC to t to start asynchronous calculation. (See (addrlist nil)) (save-excursion (save-restriction - (goto-char (point-min)) - (search-forward mail-header-separator) - (beginning-of-line) - (narrow-to-region (point-min) (point)) + (message-narrow-to-headers) (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" @@ -323,10 +333,10 @@ Set ASYNC to t to start asynchronous calculation. (See (when (and hashcash-in-news ng) (setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*"))))) (when addrlist - (mapcar (if async - #'hashcash-insert-payment-async - #'hashcash-insert-payment) - addrlist))))) ; mapc + (mapc (if async + #'hashcash-insert-payment-async + #'hashcash-insert-payment) + addrlist))))) t) ;;;###autoload @@ -365,4 +375,4 @@ Prefix arg sets default accept amount temporarily." (provide 'hashcash) -;;; arch-tag: 0e7fe983-a124-4392-9788-0dbcbd2c4d62 +;;; hashcash.el ends here