xemacs-beta: lisp/gnus/gnus-art.el comparison

comparison lisp/gnus/gnus-art.el @ 108:360340f9fd5f r20-1b6

Import from CVS: tag r20-1b6

author	cvs
date	Mon, 13 Aug 2007 09:18:39 +0200
parents	cf808b4c4290
children	fe104dbd9147

comparison

equal deleted inserted replaced

-:523141596bda
+:360340f9fd5f
 (defcustom gnus-ignored-headers
 '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:"
 "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:"
 "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:"
 "^Approved:" "^Sender:" "^Received:" "^Mail-from:")
 "All headers that match this regexp will be hidden.
 This variable can also be a list of regexps of headers to be ignored.
 If `gnus-visible-headers' is non-nil, this variable will be ignored."
 :type '(choice :custom-show nil
 		 regexp
 		 (repeat regexp))
 :group 'gnus-article-hiding)
 (defcustom gnus-visible-headers
 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From"
 "All headers that do not match this regexp will be hidden.
 This variable can also be a list of regexp of headers to remain visible.
 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
 :type '(repeat :value-to-internal (lambda (widget value)
 :type '(choice integer number function regexp)
 :group 'gnus-article-signature)
 (defcustom gnus-hidden-properties '(invisible t intangible t)
 "Property list to use for hiding text."
 :type 'sexp
 :group 'gnus-article-hiding)
 (defcustom gnus-article-x-face-command
 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
 "String or function to be executed to display an X-Face header.
 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
 "Face used for displaying bold italic emphasized text (/*word*/)."
 :group 'gnus-article-emphasis)
 (defface gnus-emphasis-underline-bold-italic
 '((t (:bold t :italic t :underline t)))
 "Face used for displaying underlined bold italic emphasized text.
 Esample: (_/*word*/_)."
 :group 'gnus-article-emphasis)
 (eval-and-compile
 (autoload 'hexl-hex-string-to-integer "hexl")
 (autoload 'timezone-make-date-arpa-standard "timezone")
 (autoload 'mail-extract-address-components "mail-extr"))
-(defcustom gnus-article-save-directory gnus-directory
-"*Name of the directory articles will be saved in (default \"~/News\")."
-:group 'gnus-article-saving
-:type 'directory)
 (defcustom gnus-save-all-headers t
 "*If non-nil, don't remove any headers before saving."
 :group 'gnus-article-saving
 :type 'boolean)
 "Face used for highlighting a signature in the article buffer."
 :type 'face
 :group 'gnus-article-highlight
 :group 'gnus-article-signature)
 (defface gnus-header-from-face
 '((((class color)
 (background dark))
-(:foreground "light blue" :bold t :italic t))
+(:foreground "spring green" :bold t :italic t))
 (((class color)
 (background light))
-(:foreground "MidnightBlue" :bold t :italic t))
+(:foreground "indianred" :bold t :italic t))
 (t
 (:bold t :italic t)))
 "Face used for displaying from headers."
 :group 'gnus-article-headers
 :group 'gnus-article-highlight)
 (defface gnus-header-subject-face
 '((((class color)
 (background dark))
-(:foreground "pink" :bold t :italic t))
+(:foreground "SeaGreen3" :bold t :italic t))
 (((class color)
 (background light))
 (:foreground "firebrick" :bold t :italic t))
 (t
 (:bold t :italic t)))
 "Face used for displaying subject headers."
 :group 'gnus-article-headers
 :group 'gnus-article-highlight)
 (defface gnus-header-newsgroups-face
 '((((class color)
 (background dark))
 (:foreground "yellow" :bold t :italic t))
 (((class color)
 (background light))
-(:foreground "indianred" :bold t :italic t))
+(:foreground "MidnightBlue" :bold t :italic t))
 (t
 (:bold t :italic t)))
 "Face used for displaying newsgroups headers."
 :group 'gnus-article-headers
 :group 'gnus-article-highlight)
 (defface gnus-header-name-face
 '((((class color)
 (background dark))
-(:foreground "cyan" :bold t))
+(:foreground "SeaGreen"))
 (((class color)
 (background light))
-(:foreground "DarkGreen" :bold t))
+(:foreground "maroon"))
 (t
 (:bold t)))
 "Face used for displaying header names."
 :group 'gnus-article-headers
 :group 'gnus-article-highlight)
 '((((class color)
 (background dark))
 (:foreground "forest green" :italic t))
 (((class color)
 (background light))
-(:foreground "DarkGreen" :italic t))
+(:foreground "indianred4" :italic t))
 (t
 (:italic t)))  "Face used for displaying header content."
 :group 'gnus-article-headers
 :group 'gnus-article-highlight)
 (defcustom gnus-header-face-alist
 ("Subject" nil gnus-header-subject-face)
 ("Newsgroups:.*," nil gnus-header-newsgroups-face)
 ("" gnus-header-name-face gnus-header-content-face))
 "Controls highlighting of article header.
 An alist of the form (HEADER NAME CONTENT).
 HEADER is a regular expression which should match the name of an
 header header and NAME and CONTENT are either face names or nil.
 The name of each header field will be displayed using the face
 (defsubst gnus-article-hide-text (b e props)
 "Set text PROPS on the B to E region, extending `intangible' 1 past B."
 (add-text-properties b e props)
 (when (memq 'intangible props)
 (put-text-property
 (max (1- b) (point-min))
 b 'intangible (cddr (memq 'intangible props)))))
 (defsubst gnus-article-unhide-text (b e)
 "Remove hidden text properties from region between B and E."
 	    ;; article buffer.
 	    (goto-char (point-min))
 	    (while (re-search-forward "^[^ \t]*:" nil t)
 	      (beginning-of-line)
 	      ;; Mark the rank of the header.
 	      (put-text-property
 	       (point) (1+ (point)) 'message-rank
 	       (if (or (and visible (looking-at visible))
 		       (and ignored
 			    (not (looking-at ignored))))
 		   (gnus-article-header-rank)
 		 (+ 2 max)))
 	      (forward-line 1))
 	    (message-sort-headers-1)
 	    (when (setq beg (text-property-any
 			     (point-min) (point-max) 'message-rank (+ 2 max)))
 	      ;; We make the unwanted headers invisible.
 	      (if delete
 		  (delete-region beg (point-max))
 		;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
 	     ((eq elem 'empty)
 	      (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
 		(forward-line -1)
 		(gnus-article-hide-text-type
 		 (progn (beginning-of-line) (point))
 		 (progn
 		   (end-of-line)
 		   (if (re-search-forward "^[^ \t]" nil t)
 		       (match-beginning 0)
 		     (point-max)))
 		 'boring-headers)))
 	      (let ((from (message-fetch-field "from"))
 		    (reply-to (message-fetch-field "reply-to")))
 		(when (and
 		       from reply-to
 		       (ignore-errors
 			 (equal
 			  (nth 1 (mail-extract-address-components from))
 			  (nth 1 (mail-extract-address-components reply-to)))))
 		  (gnus-article-hide-header "reply-to"))))
 	     ((eq elem 'date)
 	      (let ((date (message-fetch-field "date")))
 (save-excursion
 (goto-char (point-min))
 (when (re-search-forward (concat "^" header ":") nil t)
 (gnus-article-hide-text-type
 (progn (beginning-of-line) (point))
 (progn
 	 (end-of-line)
 	 (if (re-search-forward "^[^ \t]" nil t)
 	     (match-beginning 0)
 	   (point-max)))
 'boring-headers))))
 	(let ((next (following-char))
 	      (previous (char-after (- (point) 2))))
 	  ;; We do the boldification/underlining by hiding the
 	  ;; overstrikes and putting the proper text property
 	  ;; on the letters.
 	  (cond
 	   ((eq next previous)
 	    (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
 	    (put-text-property (point) (1+ (point)) 'face 'bold))
 	   ((eq next ?_)
 	    (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike)
 (save-restriction
 (narrow-to-region
 (goto-char (point-min))
 (or (search-forward "\n\n" nil t) (point-max)))
 (goto-char (point-min))
 (while (re-search-forward
 	      "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
 	(setq string (match-string 1))
 	(save-restriction
 	  (narrow-to-region (match-beginning 0) (match-end 0))
 	  (delete-region (point-min) (point-max))
 	  (insert string)
 	  (article-mime-decode-quoted-printable
 	   (goto-char (point-min)) (point-max))
 	  (subst-char-in-region (point-min) (point-max) ?_ ? )
 	  (goto-char (point-max)))
 	(goto-char (point-min))))))
 	(article-mime-decode-quoted-printable (point) (point-max))))))
 (defun article-mime-decode-quoted-printable-buffer ()
 "Decode Quoted-Printable in the current buffer."
 (article-mime-decode-quoted-printable (point-min) (point-max)))
 (defun article-mime-decode-quoted-printable (from to)
 "Decode Quoted-Printable in the region between FROM and TO."
 (interactive "r")
 (goto-char from)
 (while (search-forward "=" to t)
 	;; Hide "- " PGP quotation markers.
 	(when (and beg end)
 	  (narrow-to-region beg end)
 	  (goto-char (point-min))
 	  (while (re-search-forward "^- " nil t)
 	    (gnus-article-hide-text-type
 	     (match-beginning 0) (match-end 0) 'pgp))
 	  (widen))))))
 (defun article-hide-pem (&optional arg)
 "Toggle hiding of any PEM headers and signatures in the current article.
 (unless (gnus-article-check-hidden-text 'signature arg)
 (save-excursion
 (save-restriction
 	(let ((buffer-read-only nil))
 	  (when (gnus-article-narrow-to-signature)
 	    (gnus-article-hide-text-type
 	     (point-min) (point-max) 'signature)))))))
 (defun article-strip-leading-blank-lines ()
 "Remove all blank lines from the beginning of the article."
 (interactive)
 (let ((pcinfo (car (last mime::preview/content-list))))
 (ignore-errors
 	(narrow-to-region
 	 (funcall (intern "mime::preview-content-info/point-min") pcinfo)
 	 (point-max)))))
 (when (gnus-article-search-signature)
 (forward-line 1)
 ;; Check whether we have some limits to what we consider
 ;; to be a signature.
 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
 (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."
 (interactive (list 'ut t))
 (let* ((header (or header
 		     (mail-header-date gnus-current-headers)
 		     (message-fetch-field "date")
 		     ""))
 	 (date (if (vectorp header) (mail-header-date header)
 		 header))
 	      ;; It's big enough, so we output it.
 	      (setq sec (- sec (* num (cdr unit))))
 	      (prog1
 		  (concat (if prev ", " "") (int-to-string
 					     (floor num))
 			  " " (symbol-name (car unit))
 			  (if (> num 1) "s" ""))
 		(setq prev t))))
 	  article-time-units "")
 	 ;; If dates are odd, then it might appear like the
 	 ;; article was sent in the future.
 	       (t file)))
 	     (gnus-number-of-articles-to-be-saved
 	      (when (eq gnus-prompt-before-saving t)
 		num)))			; Magic
 	(set-buffer gnus-summary-buffer)
 	(funcall gnus-default-article-saver filename)))))
 (defun gnus-read-save-file-name (prompt default-name &optional filename)
 (cond
 ((eq filename 'default)
 default-name)
 (gnus-set-global-variables)
 (setq command
 	(cond ((eq command 'default)
 	       gnus-last-shell-command)
 	      (command command)
 	      (t (read-string
 		  (format
 		   "Shell command on %s: "
 		   (if (and gnus-number-of-articles-to-be-saved
 			    (> gnus-number-of-articles-to-be-saved 1))
 		       (format "these %d articles"
 (if (consp func)
 	   (setq afunc (car func)
 		 gfunc (cdr func))
 	 (setq afunc func
 	       gfunc (intern (format "gnus-%s" func))))
 (fset gfunc
 	     (if (not (fboundp afunc))
 		 nil
 	       `(lambda (&optional interactive &rest args)
 		  ,(documentation afunc t)
 		  (interactive (list t))
 		     (buffer-name (get-buffer gnus-summary-buffer)))
 	    (save-excursion
 	      (set-buffer gnus-summary-buffer)
 	      (let ((header (gnus-summary-article-header article)))
 		(when (< article 0)
 		  (cond
 		   ((memq article gnus-newsgroup-sparse)
 		    ;; 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 article (mail-header-id header)))
 		   (t
 		    ;; It is an extracted pseudo-article.
 		    (setq article 'pseudo)
 		    (gnus-request-pseudo-article header))))
 		(let ((method (gnus-find-method-for-group
 			       gnus-newsgroup-name)))
 		  (if (not (eq (car method) 'nneething))
 		      ()
 		    (let ((dir (concat (file-name-as-directory (nth 1 method))
 				       (mail-header-subject header))))
 	      (gnus-kill-all-overlays)
 	      (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)))
 	   ;; It was a pseudo.
 	   (t article)))
 	    (gnus-add-current-to-buffer-list))
 	  (let (buffer-read-only)
 	    (erase-buffer)
 	    (insert-buffer-substring gnus-article-buffer))
 	  (setq gnus-original-article (cons group article))))
 ;; Update sparse articles.
 (when (and do-update-line
 		 (or (numberp article)
 		     (stringp article)))
 	(let ((buf (current-buffer)))
 (defvar gnus-article-edit-done-function nil)
 (defvar gnus-article-edit-mode-map nil)
 (unless gnus-article-edit-mode-map
 (setq gnus-article-edit-mode-map (copy-keymap text-mode-map))
 (gnus-define-keys gnus-article-edit-mode-map
 "\C-c\C-c" gnus-article-edit-done
 "\C-c\C-k" gnus-article-edit-exit)
 (insert buf)
 (let ((winconf gnus-prev-winconf))
 (gnus-article-mode)
 ;; The cache and backlog have to be flushed somewhat.
 (when gnus-use-cache
 	(gnus-cache-update-article
 	 (car gnus-article-current) (cdr gnus-article-current)))
 (when gnus-keep-backlog
 	(gnus-backlog-remove-article
 	 (car gnus-article-current) (cdr gnus-article-current)))
 ;; Flush original article as well.
 (save-excursion
 	(when (get-buffer gnus-original-article-buffer)
 	  (set-buffer gnus-original-article-buffer)
 (let ((buf (current-buffer)))
 	(set-buffer curbuf)
 	(set-window-start (get-buffer-window (current-buffer)) window-start)
 	(goto-char p)
 	(set-buffer buf)))))
 (defun gnus-article-edit-full-stops ()
 "Interactively repair spacing at end of sentences."
 (interactive)
 (save-excursion
 (goto-char (point-min))
 (search-forward-regexp "^$" nil t)
 (let ((case-fold-search nil))
 (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
 ;;;
 ;;; Article highlights
 ;;;
 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
 (defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)"
 "Regular expression that matches URLs."
 :group 'gnus-article-buttons
 :type 'regexp)
 (defcustom gnus-button-alist
 `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t
 gnus-button-message-id 2)
 ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*+\\)" 0 t gnus-button-message-id 1)
 ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t
 gnus-button-fetch-group 4)
 ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
 ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
 t gnus-button-message-id 3)
 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 1)
 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2)
 ;; This is how URLs _should_ be embedded in text...
 ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
 REGEXP: is the string matching text around the button,
 BUTTON: is the number of the regexp grouping actually matching the button,
 FORM: is a lisp expression which must eval to true for the button to
 be added,
 CALLBACK: is the function to call when the user push this button, and each
 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
 CALLBACK can also be a variable, in that case the value of that
 variable it the real callback function."
 :group 'gnus-article-buttons
 :type '(repeat (list regexp
 		       (integer :tag "Button")
 		       (sexp :tag "Form")
 		       (function :tag "Callback")
 		       (repeat :tag "Par"
 			       :inline t
 			       (integer :tag "Regexp group")))))
 (defcustom gnus-header-button-alist
 `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
 0 t gnus-button-message-id 0)
 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
 0 t gnus-button-mailto 0)
 ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
 ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
 gnus-button-message-id 3))
 HEADER is a regexp to match a header.  For a fuller explanation, see
 `gnus-button-alist'."
 :group 'gnus-article-buttons
 :group 'gnus-article-headers
 :type '(repeat (list (regexp :tag "Header")
 		       regexp
 		       (integer :tag "Button")
 		       (sexp :tag "Form")
 		       (function :tag "Callback")
 		       (repeat :tag "Par"
 			       :inline t
 n))
 (defun gnus-article-highlight (&optional force)
 "Highlight current article.
 This function calls `gnus-article-highlight-headers',
 `gnus-article-highlight-citation',
 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
 do the highlighting.  See the documentation for those functions."
 (interactive (list 'force))
 (gnus-article-highlight-headers)
 (gnus-article-highlight-citation force)
 (let ((alist gnus-header-face-alist)
 	    (buffer-read-only nil)
 	    (case-fold-search t)
 	    (inhibit-point-motion-hooks t)
 	    entry regexp header-face field-face from hpoints fpoints)
-	(goto-char (point-min))
+	(message-narrow-to-head)
-	(when (search-forward "\n\n" nil t)
+	(while (setq entry (pop alist))
-	  (narrow-to-region (1- (point)) (point-min))
+	  (goto-char (point-min))
-	  (while (setq entry (pop alist))
+	  (setq regexp (concat "^\\("
-	    (goto-char (point-min))
+			       (if (string-equal "" (nth 0 entry))
-	    (setq regexp (concat "^\\("
+				   "[^\t ]"
-				 (if (string-equal "" (nth 0 entry))
+				 (nth 0 entry))
-				     "[^\t ]"
+			       "\\)")
-				   (nth 0 entry))
+		header-face (nth 1 entry)
-				 "\\)")
+		field-face (nth 2 entry))
-		  header-face (nth 1 entry)
+	  (while (and (re-search-forward regexp nil t)
-		  field-face (nth 2 entry))
+		      (not (eobp)))
-	    (while (and (re-search-forward regexp nil t)
+	    (beginning-of-line)
-			(not (eobp)))
+	    (setq from (point))
-	      (beginning-of-line)
+	    (unless (search-forward ":" nil t)
-	      (setq from (point))
+	      (forward-char 1))
-	      (unless (search-forward ":" nil t)
+	    (when (and header-face
-		(forward-char 1))
+		       (not (memq (point) hpoints)))
-	      (when (and header-face
+	      (push (point) hpoints)
-			 (not (memq (point) hpoints)))
+	      (gnus-put-text-property from (point) 'face header-face))
-		(push (point) hpoints)
+	    (when (and field-face
-		(gnus-put-text-property from (point) 'face header-face))
+		       (not (memq (setq from (point)) fpoints)))
-	      (when (and field-face
+	      (push from fpoints)
-			 (not (memq (setq from (point)) fpoints)))
+	      (if (re-search-forward "^[^ \t]" nil t)
-		(push from fpoints)
+		  (forward-char -2)
-		(if (re-search-forward "^[^ \t]" nil t)
+		(goto-char (point-max)))
-		    (forward-char -2)
+	      (gnus-put-text-property from (point) 'face field-face))))))))
-		  (goto-char (point-max)))
-		(gnus-put-text-property from (point) 'face field-face)))))))))
 (defun gnus-article-highlight-signature ()
 "Highlight the signature in an article.
 It does this by highlighting everything after
 `gnus-signature-separator' using `gnus-signature-face'."
 (interactive)
 (save-excursion
 (set-buffer gnus-article-buffer)
 (let ((buffer-read-only nil)
 	  (inhibit-point-motion-hooks t))
 \"External references\" are things like Message-IDs and URLs, as
 specified by `gnus-button-alist'."
 (interactive (list 'force))
 (save-excursion
 (set-buffer gnus-article-buffer)
-;; Remove all old markers.
-(let (marker entry)
-(while (setq marker (pop gnus-button-marker-list))
-	(goto-char marker)
-	(when (setq entry (gnus-button-entry))
-	  (put-text-property (match-beginning (nth 1 entry))
-			     (match-end (nth 1 entry))
-			     'gnus-callback nil))
-	(set-marker marker nil)))
 (let ((buffer-read-only nil)
 	  (inhibit-point-motion-hooks t)
 	  (case-fold-search t)
 	  (alist gnus-button-alist)
 	  beg entry regexp)
+;; Remove all old markers.
+(let (marker entry)
+	(while (setq marker (pop gnus-button-marker-list))
+	  (goto-char marker)
+	  (when (setq entry (gnus-button-entry))
+	    (put-text-property (match-beginning (nth 1 entry))
+			       (match-end (nth 1 entry))
+			       'gnus-callback nil))
+	  (set-marker marker nil)))
+;; We skip the headers.
 (goto-char (point-min))
-;; We skip the headers.
 (unless (search-forward "\n\n" nil t)
 	(goto-char (point-max)))
 (setq beg (point))
 (while (setq entry (pop alist))
 	(setq regexp (car entry))
 			   (eval (nth 1 entry)))
 		       (not (gnus-button-in-region-p
 			     start end 'gnus-callback)))
 	      ;; That optional form returned non-nil, so we add the
 	      ;; button.
 	      (gnus-article-add-button
 	       start end 'gnus-button-push
 	       (car (push (set-marker (make-marker) from)
 			  gnus-button-marker-list))))))))))
 ;; Add buttons to the head of an article.
 (defun gnus-article-add-buttons-to-head ()
 		   (start (match-beginning (nth 1 entry)))
 		   (end (match-end (nth 1 entry)))
 		   (form (nth 2 entry)))
 	      (goto-char (match-end 0))
 	      (when (eval form)
 		(gnus-article-add-button
 		 start end (nth 3 entry)
 		 (buffer-substring (match-beginning (nth 4 entry))
 				   (match-end (nth 4 entry)))))))
 	  (goto-char end))))
 (widen)))
 (defun gnus-article-add-button (from to fun &optional data)
 "Create a button between FROM and TO with callback FUN and data DATA."
 (when gnus-article-button-face
 (gnus-overlay-put (gnus-make-overlay from to)
 		      'face gnus-article-button-face))
 (gnus-add-text-properties
 from to
 (nconc (and gnus-article-mouse-face
 	       (list gnus-mouse-face-prop gnus-article-mouse-face))
 	  (list 'gnus-callback fun)
 	  (and data (list 'gnus-data data)))))
 (let (parts (start 0))
 (while (string-match pattern string start)
 (setq parts (cons (substring string start (match-beginning 0)) parts)
 	    start (match-end 0)))
 (nreverse (cons (substring string start) parts))))
 (defun gnus-url-parse-query-string (query &optional downcase)
 (let (retval pairs cur key val)
 (setq pairs (gnus-split-string query "&"))
 (while pairs
 (setq cur (car pairs)
 (setq cur (assoc key retval))
 (if cur
 (setcdr cur (cons val (cdr cur)))
 (setq retval (cons (list key val) retval)))))
 retval))
 (defun gnus-url-unhex (x)
 (if (> x ?9)
 (if (>= x ?a)
 (+ 10 (- x ?a))
 (+ 10 (- x ?A)))
 (- x ?0)))
 (defun gnus-url-unhex-string (str &optional allow-newlines)
 "Remove %XXX embedded spaces, etc in a url.
 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
 decoding of carriage returns and line feeds in the string, which is normally
 forbidden in URL encoding."
 (while (string-match "%[0-9a-f][0-9a-f]" str)
 (let* ((start (match-beginning 0))
 (ch1 (gnus-url-unhex (elt str (+ start 1))))
 (code (+ (* 16 ch1)
 (gnus-url-unhex (elt str (+ start 2))))))
 (setq tmp (concat
 tmp (substring str 0 start)
 (cond
 (allow-newlines
 (char-to-string code))
 ((or (= code ?\n) (= code ?\r))
 " ")
 (t (char-to-string code))))
 str (substring str (match-end 0)))))
 (setq tmp (concat tmp str))
 tmp))
 (defun gnus-url-mailto (url)
 ;; Send mail to someone
 (when (string-match "mailto:/*\\(.*\\)" url)
 (setq url (substring url (match-beginning 1) nil)))
 (let (to args source-url subject func)
 (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
 (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
 (defun gnus-insert-prev-page-button ()
 (let ((buffer-read-only nil))
 (gnus-eval-format
 gnus-prev-page-line-format nil
 `(gnus-prev t local-map ,gnus-prev-page-map
 		 gnus-callback gnus-article-button-prev-page))))
 (defvar gnus-next-page-map nil)
 (defun gnus-insert-next-page-button ()
 (let ((buffer-read-only nil))
 (gnus-eval-format gnus-next-page-line-format nil
 		      `(gnus-next t local-map ,gnus-next-page-map
 				  gnus-callback
 				  gnus-article-button-next-page))))
 (defun gnus-article-button-next-page (arg)
 "Go to the next page."
 (interactive "P")
 "Go to the prev page."
 (interactive "P")
 (let ((win (selected-window)))
 (select-window (get-buffer-window gnus-article-buffer t))
 (gnus-article-prev-page)
 (select-window win)))
 (gnus-ems-redefine)
 (provide 'gnus-art)

Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-art.el @ 108:360340f9fd5f r20-1b6