cgit.sxemacs.org Git - gnus/blob - lisp/gnus-msg.el

   1 ;;; gnus-message --- mail and post interface for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   3
   4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus)
  29 (require 'sendmail)
  30
  31 \f
  32 ;;;
  33 ;;; Gnus Posting Functions
  34 ;;;
  35
  36 (defvar gnus-organization-file "/usr/lib/news/organization"
  37   "*Local news organization file.")
  38
  39 (defvar gnus-post-news-buffer "*post-news*")
  40 (defvar gnus-winconf-post-news nil)
  41
  42 (defvar gnus-summary-send-map nil)
  43
  44   (define-prefix-command 'gnus-summary-send-map)
  45   (define-key gnus-summary-mode-map "S" 'gnus-summary-send-map)
  46   (define-key gnus-summary-send-map "p" 'gnus-summary-post-news)
  47   (define-key gnus-summary-send-map "f" 'gnus-summary-followup)
  48   (define-key gnus-summary-send-map "F" 'gnus-summary-followup-with-original)
  49   (define-key gnus-summary-send-map "b" 'gnus-summary-followup-and-reply)
  50   (define-key gnus-summary-send-map "B" 'gnus-summary-followup-and-reply-with-original)
  51   (define-key gnus-summary-send-map "c" 'gnus-summary-cancel-article)
  52   (define-key gnus-summary-send-map "s" 'gnus-summary-supersede-article)
  53   (define-key gnus-summary-send-map "r" 'gnus-summary-reply)
  54   (define-key gnus-summary-send-map "R" 'gnus-summary-reply-with-original)
  55   (define-key gnus-summary-send-map "m" 'gnus-summary-mail-other-window)
  56   (define-key gnus-summary-send-map "u" 'gnus-uu-post-news)
  57   (define-key gnus-summary-send-map "om" 'gnus-summary-mail-forward)
  58   (define-key gnus-summary-send-map "op" 'gnus-summary-post-forward)
  59   (define-key gnus-summary-send-map "Om" 'gnus-uu-digest-mail-forward)
  60   (define-key gnus-summary-send-map "Op" 'gnus-uu-digest-post-forward)
  61
  62 ;;; Internal functions.
  63
  64 ;; Return NUM konverted to a key of exactly LEN chars.  Requires NUM>=0.
  65 ;; If LEN=-1, return 0 or more chars as necessary.
  66 (defun gnus-number-base31 (num len)
  67   (if (if (< len 0) (<= num 0) (= len 0))
  68       ""
  69     (concat (gnus-number-base31 (/ num 31) (1- len))
  70             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
  71                                   (% num 31))))))
  72
  73 (defun gnus-number-base36 (num len)
  74   (if (if (< len 0) (<= num 0) (= len 0))
  75       ""
  76     (concat (gnus-number-base36 (/ num 36) (1- len))
  77             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
  78                                   (% num 36))))))
  79
  80 ;;; Post news commands of Gnus group mode and summary mode
  81
  82 (defun gnus-group-post-news ()
  83   "Post an article."
  84   (interactive)
  85   (gnus-set-global-variables)
  86   ;; Save window configuration.
  87   (setq gnus-winconf-post-news (current-window-configuration))
  88   (let ((gnus-newsgroup-name nil))
  89     (unwind-protect
  90         (if gnus-split-window
  91             (progn
  92               (pop-to-buffer gnus-article-buffer)
  93               (widen)
  94               (split-window-vertically)
  95               (gnus-post-news 'post))
  96           (progn
  97             (pop-to-buffer gnus-article-buffer)
  98             (widen)
  99             (delete-other-windows)
 100             (gnus-post-news 'post)))
 101       (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
 102                (not (zerop (buffer-size))))
 103           ;; Restore last window configuration.
 104           (and gnus-winconf-post-news
 105                (set-window-configuration gnus-winconf-post-news)))))
 106   ;; We don't want to return to summary buffer nor article buffer later.
 107   (setq gnus-winconf-post-news nil)
 108   (if (get-buffer gnus-summary-buffer)
 109       (bury-buffer gnus-summary-buffer))
 110   (if (get-buffer gnus-article-buffer)
 111       (bury-buffer gnus-article-buffer)))
 112
 113 (defun gnus-summary-post-news ()
 114   "Post an article."
 115   (interactive)
 116   (gnus-set-global-variables)
 117   ;; Save window configuration.
 118   (setq gnus-winconf-post-news (current-window-configuration))
 119   (unwind-protect
 120       (gnus-post-news 'post gnus-newsgroup-name)
 121     (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
 122              (not (zerop (buffer-size))))
 123         ;; Restore last window configuration.
 124         (and gnus-winconf-post-news
 125              (set-window-configuration gnus-winconf-post-news))))
 126   ;; We don't want to return to article buffer later.
 127   (if (get-buffer gnus-article-buffer)
 128       (bury-buffer gnus-article-buffer)))
 129
 130 (defun gnus-summary-followup (yank)
 131   "Compose a followup to an article.
 132 If prefix argument YANK is non-nil, original article is yanked automatically."
 133   (interactive "P")
 134   (gnus-set-global-variables)
 135   (save-window-excursion
 136     (gnus-summary-select-article t))
 137   (let ((headers gnus-current-headers)
 138         (gnus-newsgroup-name gnus-newsgroup-name))
 139     ;; Check Followup-To: poster.
 140     (set-buffer gnus-article-buffer)
 141     (if (and gnus-use-followup-to
 142              (string-equal "poster" (gnus-fetch-field "followup-to"))
 143              (or (not (eq gnus-use-followup-to t))
 144                  (not (gnus-y-or-n-p
 145                        "Do you want to ignore `Followup-To: poster'? "))))
 146         ;; Mail to the poster.  Gnus is now RFC1036 compliant.
 147         (gnus-summary-reply yank)
 148       ;; Save window configuration.
 149       (setq gnus-winconf-post-news (current-window-configuration))
 150       (unwind-protect
 151           (gnus-post-news nil gnus-newsgroup-name
 152                           headers gnus-article-buffer yank)
 153         (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
 154                  (not (zerop (buffer-size))))
 155             ;; Restore last window configuration.
 156             (and gnus-winconf-post-news
 157                  (set-window-configuration gnus-winconf-post-news))))
 158       ;; We don't want to return to article buffer later.
 159       (bury-buffer gnus-article-buffer)))
 160   (gnus-article-hide-headers-if-wanted))
 161
 162 (defun gnus-summary-followup-with-original ()
 163   "Compose a followup to an article and include the original article."
 164   (interactive)
 165   (gnus-summary-followup t))
 166
 167 ;; Suggested by Daniel Quinlan <quinlan@best.com>.
 168 (defun gnus-summary-followup-and-reply (yank)
 169   "Compose a followup and do an auto mail to author."
 170   (interactive "P")
 171   (let ((gnus-auto-mail-to-author t))
 172     (gnus-summary-followup yank)))
 173
 174 (defun gnus-summary-followup-and-reply-with-original ()
 175   "Compose a followup, include the original, and do an auto mail to author."
 176   (interactive)
 177   (gnus-summary-followup-and-reply t))
 178
 179 (defun gnus-summary-cancel-article ()
 180   "Cancel an article you posted."
 181   (interactive)
 182   (gnus-set-global-variables)
 183   (gnus-summary-select-article t)
 184   (gnus-eval-in-buffer-window gnus-article-buffer (gnus-cancel-news))
 185   (gnus-article-hide-headers-if-wanted))
 186
 187 (defun gnus-summary-supersede-article ()
 188   "Compose an article that will supersede a previous article.
 189 This is done simply by taking the old article and adding a Supersedes
 190 header line with the old Message-ID."
 191   (interactive)
 192   (gnus-set-global-variables)
 193   (if (not
 194        (string-equal
 195         (downcase (mail-strip-quoted-names
 196                    (header-from gnus-current-headers)))
 197         (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
 198       (error "This article is not yours."))
 199   (gnus-summary-select-article t)
 200   (save-excursion
 201     (set-buffer gnus-article-buffer)
 202     (let ((buffer-read-only nil))
 203       (goto-char (point-min))
 204       (search-forward "\n\n" nil t)
 205       (if (not (re-search-backward "^Message-ID: " nil t))
 206           (error "No Message-ID in this article"))))
 207   (if (gnus-post-news 'post gnus-newsgroup-name)
 208       (progn
 209         (erase-buffer)
 210         (insert-buffer gnus-article-buffer)
 211         (goto-char (point-min))
 212         (search-forward "\n\n" nil t)
 213         (if (not (re-search-backward "^Message-ID: " nil t))
 214             (error "No Message-ID in this article")
 215           (replace-match "Supersedes: " t t))
 216         (search-forward "\n\n")
 217         (forward-line -1)
 218         (insert mail-header-separator))))
 219
 220 \f
 221 ;;;###autoload
 222 (fset 'sendnews 'gnus-post-news)
 223
 224 ;;;###autoload
 225 (fset 'postnews 'gnus-post-news)
 226
 227 (defun gnus-post-news (post &optional group header article-buffer yank subject)
 228   "Begin editing a new USENET news article to be posted.
 229 Type \\[describe-mode] in the buffer to get a list of commands."
 230   (interactive (list t))
 231   (if (or (not gnus-novice-user)
 232           gnus-expert-user
 233           (not (eq 'post
 234                    (nth 1 (assoc
 235                            (format "%s" (car (gnus-find-method-for-group
 236                                               gnus-newsgroup-name)))
 237                            gnus-valid-select-methods))))
 238           (and group
 239                (assq 'to-address
 240                      (nth 5 (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))))
 241           (gnus-y-or-n-p "Are you sure you want to post to all of USENET? "))
 242       (let ((sumart (if (not post)
 243                         (save-excursion
 244                           (set-buffer gnus-summary-buffer)
 245                           (cons (current-buffer) gnus-current-article))))
 246             (from (and header (header-from header)))
 247             follow-to real-group)
 248         (and gnus-interactive-post
 249              (not gnus-expert-user)
 250              post (not group)
 251              (progn
 252                (setq group
 253                      (completing-read "Group: " gnus-active-hashtb))
 254                (or subject
 255                    (setq subject (read-string "Subject: ")))))
 256         (setq mail-reply-buffer article-buffer)
 257
 258         (let ((gnus-newsgroup-name (or group gnus-newsgroup-name "")))
 259           (setq real-group (and group (gnus-group-real-name group)))
 260           (setq gnus-post-news-buffer
 261                 (gnus-request-post-buffer
 262                  post real-group subject header article-buffer
 263                  (nth 2 (and group (gnus-gethash group gnus-newsrc-hashtb)))
 264                  (or (cdr (assq 'to-group
 265                                 (nth 5 (nth 2 (gnus-gethash
 266                                                gnus-newsgroup-name
 267                                                gnus-newsrc-hashtb)))))
 268                      (if (and (boundp 'gnus-followup-to-function)
 269                               gnus-followup-to-function
 270                               article-buffer)
 271                          (setq follow-to
 272                                (save-excursion
 273                                  (set-buffer article-buffer)
 274                                  (funcall gnus-followup-to-function group)))))
 275                  gnus-use-followup-to))
 276           (if post
 277               (progn
 278                 (gnus-configure-windows '(1 0 0))
 279                 (switch-to-buffer gnus-post-news-buffer))
 280             (gnus-configure-windows '(0 1 0))
 281             (if (not yank)
 282                 (progn
 283                   (switch-to-buffer article-buffer)
 284                   (pop-to-buffer gnus-post-news-buffer))
 285               (switch-to-buffer gnus-post-news-buffer)))
 286           (gnus-overload-functions)
 287           (make-local-variable 'gnus-article-reply)
 288           (make-local-variable 'gnus-article-check-size)
 289           (setq gnus-article-reply sumart)
 290           ;; Handle `gnus-auto-mail-to-author'.
 291           ;; Suggested by Daniel Quinlan <quinlan@best.com>.
 292           (let ((to (if (eq gnus-auto-mail-to-author 'ask)
 293                         (and (y-or-n-p "Also send mail to author? ") from)
 294                       (and gnus-auto-mail-to-author from))))
 295             (if to
 296                 (progn
 297                   (if (mail-fetch-field "To")
 298                       (progn
 299                         (beginning-of-line)
 300                         (insert "Cc: " to "\n"))
 301                     (mail-position-on-field "To")
 302                     (insert to)))))
 303           ;; Handle author copy using BCC field.
 304           (if (and gnus-mail-self-blind
 305                    (not (mail-fetch-field "bcc")))
 306               (progn
 307                 (mail-position-on-field "Bcc")
 308                 (insert (if (stringp gnus-mail-self-blind)
 309                             gnus-mail-self-blind
 310                           (user-login-name)))))
 311           ;; Handle author copy using FCC field.
 312           (if gnus-author-copy
 313               (progn
 314                 (mail-position-on-field "Fcc")
 315                 (insert gnus-author-copy)))
 316           (goto-char (point-min))
 317           (if post
 318               (cond ((not group)
 319                      (re-search-forward "^Newsgroup:" nil t)
 320                      (end-of-line))
 321                     ((not subject)
 322                      (re-search-forward "^Subject:" nil t)
 323                      (end-of-line))
 324                     (t
 325                      (re-search-forward
 326                       (concat "^" (regexp-quote mail-header-separator) "$"))
 327                      (forward-line 1)))
 328             (re-search-forward
 329              (concat "^" (regexp-quote mail-header-separator) "$"))
 330             (forward-line 1)
 331             (and yank (save-excursion (news-reply-yank-original nil)))
 332             (if gnus-post-prepare-function
 333                 (funcall gnus-post-prepare-function group))))))
 334   (setq gnus-article-check-size (cons (buffer-size) (gnus-article-checksum)))
 335   (message "")
 336   t)
 337
 338 (defun gnus-inews-news (&optional use-group-method)
 339   "Send a news message.
 340 If given a prefix, and the group is a foreign group, this function
 341 will attempt to use the foreign server to post the article."
 342   (interactive "P")
 343   (let* ((case-fold-search nil)
 344          (server-running (gnus-server-opened gnus-select-method))
 345          (reply gnus-article-reply))
 346     (save-excursion
 347       ;; Connect to default NNTP server if necessary.
 348       ;; Suggested by yuki@flab.fujitsu.junet.
 349       (gnus-start-news-server)          ;Use default server.
 350       ;; NNTP server must be opened before current buffer is modified.
 351       (widen)
 352       (goto-char (point-min))
 353       (run-hooks 'news-inews-hook)
 354       (save-restriction
 355         (narrow-to-region
 356          (point-min)
 357          (progn
 358            (goto-char (point-min))
 359            (re-search-forward
 360             (concat "^" (regexp-quote mail-header-separator) "$"))))
 361
 362         ;; Correct newsgroups field: change sequence of spaces to comma and
 363         ;; eliminate spaces around commas.  Eliminate imbedded line breaks.
 364         (goto-char (point-min))
 365         (if (search-forward-regexp "^Newsgroups: +" nil t)
 366             (save-restriction
 367               (narrow-to-region
 368                (point)
 369                (if (re-search-forward "^[^ \t]" nil 'end)
 370                    (match-beginning 0)
 371                  (point-max)))
 372               (goto-char (point-min))
 373               (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing)
 374               (goto-char (point-min))
 375               (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")))
 376
 377         ;; Added by Per Abrahamsen <abraham@iesd.auc.dk>.
 378         ;; Help save the the world!
 379         (or
 380          gnus-expert-user
 381          (let ((newsgroups (mail-fetch-field "newsgroups"))
 382                (followup-to (mail-fetch-field "followup-to"))
 383                groups to)
 384            (if (and (string-match "," newsgroups) (not followup-to))
 385                (progn
 386                  (while (string-match "," newsgroups)
 387                    (setq groups
 388                          (cons (list (substring newsgroups
 389                                                 0 (match-beginning 0)))
 390                                groups))
 391                    (setq newsgroups (substring newsgroups (match-end 0))))
 392                  (setq groups (nreverse (cons (list newsgroups) groups)))
 393
 394                  (setq to
 395                        (completing-read "Followups to: (default all groups) "
 396                                         groups))
 397                  (if (> (length to) 0)
 398                      (progn
 399                        (goto-char (point-min))
 400                        (insert "Followup-To: " to "\n")))))))
 401
 402         ;; Cleanup Followup-To.
 403         (goto-char (point-min))
 404         (if (search-forward-regexp "^Followup-To: +" nil t)
 405             (save-restriction
 406               (narrow-to-region
 407                (point)
 408                (if (re-search-forward "^[^ \t]" nil 'end)
 409                    (match-beginning 0)
 410                  (point-max)))
 411               (goto-char (point-min))
 412               (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing)
 413               (goto-char (point-min))
 414               (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")))
 415
 416         ;; Mail the message too if To:, Bcc:. or Cc: exists.
 417         (if (or (mail-fetch-field "to" nil t)
 418                 (mail-fetch-field "bcc" nil t)
 419                 (mail-fetch-field "cc" nil t))
 420             (if gnus-mail-send-method
 421                 (save-excursion
 422                   (save-restriction
 423                     (widen)
 424                     (message "Sending via mail...")
 425
 426                     (if gnus-mail-courtesy-message
 427                         (progn
 428                           ;; Insert "courtesy" mail message.
 429                           (goto-char 1)
 430                           (re-search-forward
 431                            (concat "^" (regexp-quote
 432                                         mail-header-separator) "$"))
 433                           (forward-line 1)
 434                           (insert gnus-mail-courtesy-message)
 435                           (funcall gnus-mail-send-method)
 436                           (goto-char 1)
 437                           (search-forward gnus-mail-courtesy-message)
 438                           (replace-match "" t t))
 439                       (funcall gnus-mail-send-method))
 440
 441                     (message "Sending via mail... done")
 442
 443                     (goto-char 1)
 444                     (narrow-to-region
 445                      1 (re-search-forward
 446                         (concat "^" (regexp-quote
 447                                      mail-header-separator) "$")))
 448                     (goto-char 1)
 449                     (delete-matching-lines "BCC:.*")))
 450               (ding)
 451               (message "No mailer defined.  To: and/or Cc: fields ignored.")
 452               (sit-for 1))))
 453
 454       ;; Send to NNTP server.
 455       (message "Posting to USENET...")
 456       (if (gnus-inews-article use-group-method)
 457           (progn
 458             (message "Posting to USENET... done")
 459             (if (gnus-buffer-exists-p (car-safe reply))
 460                 (progn
 461                   (save-excursion
 462                     (set-buffer gnus-summary-buffer)
 463                     (gnus-summary-mark-article-as-replied
 464                      (cdr reply))))))
 465         ;; We cannot signal an error.
 466         (ding) (message "Article rejected: %s"
 467                         (gnus-status-message gnus-select-method)))
 468       (set-buffer-modified-p nil))
 469     ;; If NNTP server is opened by gnus-inews-news, close it by myself.
 470     (or server-running
 471         (gnus-close-server (gnus-find-method-for-group gnus-newsgroup-name)))
 472     (and (fboundp 'bury-buffer) (bury-buffer))
 473     ;; Restore last window configuration.
 474     (and gnus-winconf-post-news
 475          (set-window-configuration gnus-winconf-post-news))
 476     (setq gnus-winconf-post-news nil)))
 477
 478 (defun gnus-inews-check-post ()
 479   "Check whether the post looks ok."
 480   (or
 481    (not gnus-check-before-posting)
 482    (and
 483     ;; We narrow to the headers and check them first.
 484     (save-excursion
 485       (save-restriction
 486         (goto-char (point-min))
 487         (narrow-to-region
 488          (point)
 489          (re-search-forward
 490           (concat "^" (regexp-quote mail-header-separator) "$")))
 491         (goto-char (point-min))
 492         (and
 493          ;; Check for commands in Subject.
 494          (save-excursion
 495            (if (string-match "^cmsg " (mail-fetch-field "subject"))
 496                (gnus-y-or-n-p
 497                 "The control code \"cmsg \" is in the subject. Really post? ")
 498              t))
 499          ;; Check for multiple identical headers.
 500          (save-excursion
 501            (let (found)
 502              (while (and (not found) (re-search-forward "^[^ \t:]+: " nil t))
 503                (save-excursion
 504                  (or (re-search-forward
 505                       (concat "^" (setq found
 506                                         (buffer-substring
 507                                          (match-beginning 0)
 508                                          (- (match-end 0) 2))))
 509                       nil t)
 510                      (setq found nil))))
 511              (if found
 512                  (gnus-y-or-n-p
 513                   (format "Multiple %s headers. Really post? " found))
 514                t)))
 515          ;; Check for version and sendsys.
 516          (save-excursion
 517            (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
 518                (gnus-yes-or-no-p
 519                 (format "The article contains a %s command. Really post? "
 520                         (buffer-substring (match-beginning 0)
 521                                           (1- (match-end 0)))))
 522              t))
 523          ;; Check the Message-Id header.
 524          (save-excursion
 525            (let* ((case-fold-search t)
 526                   (message-id (mail-fetch-field "message-id")))
 527              (or (not message-id)
 528                  (and (string-match "@" message-id)
 529                       (string-match "@[^\\.]*\\." message-id))
 530                  (gnus-yes-or-no-p
 531                   (format "The Message-ID looks strange: \"%s\". Really post? "
 532                           message-id)))))
 533          ;; Check the From header.
 534          (save-excursion
 535            (let* ((case-fold-search t)
 536                   (from (mail-fetch-field "from")))
 537              (or (not from)
 538                  (and (string-match "@" from)
 539                       (string-match "@[^\\.]*\\." from))
 540                  (gnus-yes-or-no-p
 541                   (format "The From looks strange: \"%s\". Really post? "
 542                           from))))))))
 543     ;; Check for long lines.
 544     (save-excursion
 545       (goto-char (point-min))
 546       (re-search-forward
 547        (concat "^" (regexp-quote mail-header-separator) "$"))
 548       (while (and
 549               (progn
 550                 (end-of-line)
 551                 (< (current-column) 80))
 552               (zerop (forward-line 1))))
 553       (or (bolp)
 554           (eobp)
 555           (gnus-yes-or-no-p
 556            (format
 557             "You have lines longer than 79 characters.  Really post? "))))
 558     ;; Check for control characters.
 559     (save-excursion
 560       (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
 561           (gnus-y-or-n-p
 562            "The article contains control characters. Really post? ")
 563         t))
 564     ;; Check excessive size.
 565     (if (> (buffer-size) 60000)
 566         (gnus-y-or-n-p (format "The article is %d octets long. Really post? "
 567                                (buffer-size)))
 568       t)
 569     ;; Use the (size . checksum) variable to see whether the
 570     ;; article is empty or has only quoted text.
 571     (if (and (= (buffer-size) (car gnus-article-check-size))
 572              (= (gnus-article-checksum) (cdr gnus-article-check-size)))
 573         (gnus-yes-or-no-p
 574          "It looks like there's no new text in your article. Really post? ")
 575       t))))
 576
 577 (defun gnus-article-checksum ()
 578   (let ((sum 0))
 579     (save-excursion
 580       (while (not (eobp))
 581         (setq sum (logxor sum (following-char)))
 582         (forward-char 1)))
 583     sum))
 584
 585 (defun gnus-cancel-news ()
 586   "Cancel an article you posted."
 587   (interactive)
 588   (if (or gnus-expert-user
 589           (gnus-yes-or-no-p "Do you really want to cancel this article? "))
 590       (let ((from nil)
 591             (newsgroups nil)
 592             (message-id nil)
 593             (distribution nil))
 594         (save-excursion
 595           ;; Get header info. from original article.
 596           (save-restriction
 597             (gnus-article-show-all-headers)
 598             (goto-char (point-min))
 599             (search-forward "\n\n" nil 'move)
 600             (narrow-to-region (point-min) (point))
 601             (setq from (mail-fetch-field "from"))
 602             (setq newsgroups (mail-fetch-field "newsgroups"))
 603             (setq message-id (mail-fetch-field "message-id"))
 604             (setq distribution (mail-fetch-field "distribution")))
 605           ;; Verify if the article is absolutely user's by comparing
 606           ;; user id with value of its From: field.
 607           (if (not
 608                (string-equal
 609                 (downcase (mail-strip-quoted-names from))
 610                 (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
 611               (progn
 612                 (ding) (message "This article is not yours."))
 613             ;; Make control article.
 614             (set-buffer (get-buffer-create " *Gnus-canceling*"))
 615             (buffer-disable-undo (current-buffer))
 616             (erase-buffer)
 617             (insert "Newsgroups: " newsgroups "\n"
 618                     "Subject: cancel " message-id "\n"
 619                     "Control: cancel " message-id "\n"
 620                     mail-header-separator "\n"
 621                     "This is a cancel message from " from ".\n")
 622             ;; Send the control article to NNTP server.
 623             (message "Canceling your article...")
 624             (if (gnus-inews-article)
 625                 (message "Canceling your article... done")
 626               (ding)
 627               (message "Cancel failed; %s"
 628                        (gnus-status-message gnus-newsgroup-name)))
 629             ;; Kill the article buffer.
 630             (kill-buffer (current-buffer)))))))
 631
 632 \f
 633 ;;; Lowlevel inews interface
 634
 635 (defun gnus-inews-article (&optional use-group-method)
 636   "Post an article in current buffer using NNTP protocol."
 637   ;; Check whether the article is a good Net Citizen.
 638   (if (and gnus-article-check-size (not (gnus-inews-check-post)))
 639       ;; Aber nein!
 640       ()
 641     ;; Looks ok, so we do the nasty.
 642     (let ((artbuf (current-buffer))
 643           (tmpbuf (get-buffer-create " *Gnus-posting*")))
 644       (widen)
 645       (goto-char (point-max))
 646       ;; require a newline at the end for inews to append .signature to
 647       (or (= (preceding-char) ?\n)
 648           (insert ?\n))
 649       ;; Prepare article headers.  All message body such as signature
 650       ;; must be inserted before Lines: field is prepared.
 651       (save-restriction
 652         (goto-char (point-min))
 653         (narrow-to-region
 654          (point-min)
 655          (save-excursion
 656            (re-search-forward
 657             (concat "^" (regexp-quote mail-header-separator) "$"))
 658            (match-beginning 0)))
 659         (gnus-inews-remove-headers)
 660         (gnus-inews-insert-headers)
 661         (run-hooks gnus-inews-article-header-hook)
 662         (widen))
 663       (save-excursion
 664         (set-buffer tmpbuf)
 665         (buffer-disable-undo (current-buffer))
 666         (erase-buffer)
 667         (insert-buffer-substring artbuf)
 668         ;; Remove the header separator.
 669         (goto-char (point-min))
 670         (re-search-forward
 671          (concat "^" (regexp-quote mail-header-separator) "$"))
 672         (replace-match "" t t)
 673         ;; This hook may insert a signature.
 674         (run-hooks 'gnus-prepare-article-hook)
 675         ;; Run final inews hooks.  This hook may do FCC.
 676         ;; The article must be saved before being posted because
 677         ;; `gnus-request-post' modifies the buffer.
 678         (run-hooks 'gnus-inews-article-hook)
 679         ;; Post an article to NNTP server.
 680         ;; Return NIL if post failed.
 681         (prog1
 682             (gnus-request-post
 683              (if use-group-method
 684                  (gnus-find-method-for-group gnus-newsgroup-name)
 685                gnus-select-method) use-group-method)
 686           (kill-buffer (current-buffer)))))))
 687
 688 (defun gnus-inews-remove-headers ()
 689   (let ((case-fold-search t))
 690     ;; Remove NNTP-posting-host.
 691     (goto-char (point-min))
 692     (and (re-search-forward "^nntp-posting-host:" nil t)
 693          (delete-region (progn (beginning-of-line) (point))
 694                         (progn (forward-line 1) (point))))
 695     ;; Remove Bcc.
 696     (goto-char (point-min))
 697     (and (re-search-forward "^bcc:" nil t)
 698          (delete-region (progn (beginning-of-line) (point))
 699                         (progn (forward-line 1) (point))))))
 700
 701 (defun gnus-inews-insert-headers ()
 702   "Prepare article headers.
 703 Headers already prepared in the buffer are not modified.
 704 Headers in `gnus-required-headers' will be generated."
 705   (let ((Date (gnus-inews-date))
 706         (Message-ID (gnus-inews-message-id))
 707         (Organization (gnus-inews-organization))
 708         (From (gnus-inews-user-name))
 709         (Path (gnus-inews-path))
 710         (Subject nil)
 711         (Newsgroups nil)
 712         (Distribution nil)
 713         (Lines (gnus-inews-lines))
 714         (X-Newsreader gnus-version)
 715         (headers gnus-required-headers)
 716         (case-fold-search t)
 717         header value elem)
 718     ;; First we remove any old Message-IDs. This might be slightly
 719     ;; fascist, but if the user really wants to generate Message-IDs
 720     ;; by herself, she should remove it from the `gnus-required-list'.
 721     (goto-char (point-min))
 722     (and (memq 'Message-ID headers)
 723          (re-search-forward "^Message-ID:" nil t)
 724          (delete-region (progn (beginning-of-line) (point))
 725                         (progn (forward-line 1) (point))))
 726     ;; Insert new Sender if the From is strange.
 727     (let ((from (mail-fetch-field "from")))
 728       (if (and from (not (string= (downcase from) (downcase From))))
 729           (progn
 730             (goto-char (point-min))
 731             (and (re-search-forward "^Sender:" nil t)
 732                  (delete-region (progn (beginning-of-line) (point))
 733                                 (progn (forward-line 1) (point))))
 734             (insert "Sender: " From "\n"))))
 735     ;; If there are References, and no "Re: ", then the thread has
 736     ;; changed name. See Son-of-1036.
 737     (if (and (mail-fetch-field "references")
 738              (get-buffer gnus-article-buffer))
 739         (let ((psubject (gnus-simplify-subject-re
 740                          (mail-fetch-field "subject")))
 741               subject)
 742           (save-excursion
 743             (set-buffer gnus-article-buffer)
 744             (save-restriction
 745               (gnus-narrow-to-headers)
 746               (if (setq subject (mail-fetch-field "subject"))
 747                   (progn
 748                     (and gnus-summary-gather-subject-limit
 749                          (numberp gnus-summary-gather-subject-limit)
 750                          (> (length subject) gnus-summary-gather-subject-limit)
 751                          (setq subject
 752                                (substring subject 0
 753                                           gnus-summary-gather-subject-limit)))
 754                     (setq subject (gnus-simplify-subject-re subject))))))
 755           (or (and psubject subject (string= subject psubject))
 756               (progn
 757                 (string-match "@" Message-ID)
 758                 (setq Message-ID
 759                       (concat (substring Message-ID 0 (match-beginning 0))
 760                               "_-_"
 761                               (substring Message-ID (match-beginning 0))))))))
 762     ;; Go through all the required headers and see if they are in the
 763     ;; articles already. If they are not, or are empty, they are
 764     ;; inserted automatically - except for Subject, Newsgroups and
 765     ;; Distribution.
 766     (while headers
 767       (goto-char (point-min))
 768       (setq elem (car headers))
 769       (if (consp elem)
 770           (setq header (car elem))
 771         (setq header elem))
 772       (if (or (not (re-search-forward
 773                     (concat "^" (downcase (symbol-name header)) ":") nil t))
 774               (progn
 775                 (if (= (following-char) ? ) (forward-char 1) (insert " "))
 776                 (looking-at "[ \t]*$")))
 777           (progn
 778             (setq value
 779                   (or (if (consp elem)
 780                           ;; The element is a cons.  Either the cdr is
 781                           ;; a string to be inserted verbatim, or it
 782                           ;; is a function, and we insert the value
 783                           ;; returned from this function.
 784                           (or (and (stringp (cdr elem)) (cdr elem))
 785                               (and (fboundp (cdr elem)) (funcall (cdr elem))))
 786                         ;; The element is a symbol.  We insert the
 787                         ;; value of this symbol, if any.
 788                         (and (boundp header) (symbol-value header)))
 789                       ;; We couldn't generate a value for this header,
 790                       ;; so we just ask the user.
 791                       (read-from-minibuffer
 792                        (format "Empty header for %s; enter value: " header))))
 793             (if (bolp)
 794                 (save-excursion
 795                   (goto-char (point-max))
 796                   (insert (symbol-name header) ": " value "\n"))
 797               (replace-match value t t))))
 798       (setq headers (cdr headers)))))
 799
 800 (defun gnus-inews-insert-signature ()
 801   "Insert a signature file.
 802 If `gnus-signature-function' is bound and returns a string, this
 803 string is used instead of the variable `gnus-signature-file'.
 804 In either case, if the string is a file name, this file is
 805 inserted. If the string is not a file name, the string itself is
 806 inserted.
 807 If you never want any signature inserted, set both those variables to
 808 nil."
 809   (save-excursion
 810     (let ((signature
 811            (or (and gnus-signature-function
 812                     (fboundp gnus-signature-function)
 813                     (funcall gnus-signature-function gnus-newsgroup-name))
 814                gnus-signature-file))
 815           b)
 816       (if (and signature
 817                (or (file-exists-p signature)
 818                    (string-match " " signature)
 819                    (not (string-match
 820                          "^/[^/]+/" (expand-file-name signature)))))
 821           (progn
 822             (goto-char (point-max))
 823             ;; Delete any previous signatures.
 824             (if (and mail-signature (search-backward "\n-- \n" nil t))
 825                 (delete-region (1+ (point)) (point-max)))
 826             (insert "\n-- \n")
 827             (and (< 4 (setq b (count-lines
 828                                (point)
 829                                (progn
 830                                  (if (file-exists-p signature)
 831                                      (insert-file-contents signature)
 832                                    (insert signature))
 833                                  (goto-char (point-max))
 834                                  (or (bolp) (insert "\n"))
 835                                  (point)))))
 836                  (not gnus-expert-user)
 837                  (not
 838                   (gnus-y-or-n-p
 839                    (format
 840                     "Your .sig is %d lines; it should be max 4.  Really post? "
 841                     b)))
 842                  (if (file-exists-p signature)
 843                      (error (format "Edit %s." signature))
 844                    (error "Trim your signature."))))))))
 845
 846 (defun gnus-inews-do-fcc ()
 847   "Process FCC: fields in current article buffer.
 848 Unless the first character of the field is `|', the article is saved
 849 to the specified file using the function specified by the variable
 850 gnus-author-copy-saver.  The default function rmail-output saves in
 851 Unix mailbox format.
 852 If the first character is `|', the contents of the article is send to
 853 a program specified by the rest of the value."
 854   (let ((fcc-list nil)
 855         (fcc-file nil)
 856         (case-fold-search t))           ;Should ignore case.
 857     (save-excursion
 858       (save-restriction
 859         (goto-char (point-min))
 860         (search-forward "\n\n")
 861         (narrow-to-region (point-min) (point))
 862         (goto-char (point-min))
 863         (while (re-search-forward "^FCC:[ \t]*" nil t)
 864           (setq fcc-list
 865                 (cons (buffer-substring
 866                        (point)
 867                        (progn
 868                          (end-of-line)
 869                          (skip-chars-backward " \t")
 870                          (point)))
 871                       fcc-list))
 872           (delete-region (match-beginning 0)
 873                          (progn (forward-line 1) (point))))
 874         ;; Process FCC operations.
 875         (widen)
 876         (while fcc-list
 877           (setq fcc-file (car fcc-list))
 878           (setq fcc-list (cdr fcc-list))
 879           (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file)
 880                  (let ((program (substring fcc-file
 881                                            (match-beginning 1) (match-end 1))))
 882                    ;; Suggested by yuki@flab.fujitsu.junet.
 883                    ;; Send article to named program.
 884                    (call-process-region (point-min) (point-max) shell-file-name
 885                                         nil nil nil "-c" program)))
 886                 (t
 887                  ;; Suggested by hyoko@flab.fujitsu.junet.
 888                  ;; Save article in Unix mail format by default.
 889                  (if (and gnus-author-copy-saver
 890                           (not (eq gnus-author-copy-saver 'rmail-output)))
 891                      (funcall gnus-author-copy-saver fcc-file)
 892                    (if (and (file-readable-p fcc-file) (rmail-file-p fcc-file))
 893                        (gnus-output-to-rmail fcc-file)
 894                      (rmail-output fcc-file 1 t t))))))))))
 895
 896 (defun gnus-inews-path ()
 897   "Return uucp path."
 898   (let ((login-name (gnus-inews-login-name)))
 899     (cond ((null gnus-use-generic-path)
 900            (concat (nth 1 gnus-select-method) "!" login-name))
 901           ((stringp gnus-use-generic-path)
 902            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
 903            (concat gnus-use-generic-path "!" login-name))
 904           (t login-name))))
 905
 906 (defun gnus-inews-user-name ()
 907   "Return user's network address as \"NAME@DOMAIN (FULL-NAME)\"."
 908   (let ((full-name (gnus-inews-full-name)))
 909     (or gnus-user-from-line
 910         (concat (if (or gnus-user-login-name gnus-use-generic-from
 911                         gnus-local-domain (getenv "DOMAINNAME"))
 912                     (concat (gnus-inews-login-name) "@"
 913                             (gnus-inews-domain-name gnus-use-generic-from))
 914                   user-mail-address)
 915                 ;; User's full name.
 916                 (cond ((string-equal full-name "") "")
 917                       ((string-equal full-name "&") ;Unix hack.
 918                        (concat " (" (user-login-name) ")"))
 919                       (t
 920                        (concat " (" full-name ")")))))))
 921
 922 (defun gnus-inews-login-name ()
 923   "Return login name."
 924   (or gnus-user-login-name (getenv "LOGNAME") (user-login-name)))
 925
 926 (defun gnus-inews-full-name ()
 927   "Return full user name."
 928   (or gnus-user-full-name (getenv "NAME") (user-full-name)))
 929
 930 (defun gnus-inews-domain-name (&optional genericfrom)
 931   "Return user's domain name.
 932 If optional argument GENERICFROM is a string, use it as the domain
 933 name; if it is non-nil, strip off local host name from the domain name.
 934 If the function `system-name' returns full internet name and the
 935 domain is undefined, the domain name is got from it."
 936   (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME"))
 937       (let* ((system-name (system-name))
 938              (domain
 939               (or (if (stringp genericfrom) genericfrom)
 940                   (getenv "DOMAINNAME")
 941                   gnus-local-domain
 942                   ;; Function `system-name' may return full internet name.
 943                   ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>.
 944                   (if (string-match "\\." system-name)
 945                       (substring system-name (match-end 0)))
 946                   (read-string "Domain name (no host): ")))
 947              (host (or (if (string-match "\\." system-name)
 948                            (substring system-name 0 (match-beginning 0)))
 949                        system-name)))
 950         (if (string-equal "." (substring domain 0 1))
 951             (setq domain (substring domain 1)))
 952         ;; Support GENERICFROM as same as standard Bnews system.
 953         ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
 954         (cond ((null genericfrom)
 955                (concat host "." domain))
 956               ;;((stringp genericfrom) genericfrom)
 957               (t domain)))
 958     (if (string-match "\\." (system-name))
 959         (system-name)
 960       (substring user-mail-address
 961                  (1+ (string-match "@" user-mail-address))))))
 962
 963 (defun gnus-inews-full-address ()
 964   (let ((domain (gnus-inews-domain-name))
 965         (system (system-name))
 966         (case-fold-search t))
 967     (if (string-match "\\." system) system
 968       (if (string-match (concat "^" (regexp-quote system)) domain) domain
 969         (concat system "." domain)))))
 970
 971 (defun gnus-inews-message-id ()
 972   "Generate unique Message-ID for user."
 973   ;; Message-ID should not contain a slash and should be terminated by
 974   ;; a number.  I don't know the reason why it is so.
 975   (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-full-address) ">"))
 976
 977 (defun gnus-inews-unique-id ()
 978   "Generate unique ID from user name and current time."
 979   (concat (downcase (gnus-inews-login-name))
 980           (mapconcat
 981            (lambda (num) (gnus-number-base31 num 3))
 982            (current-time) "")))
 983
 984
 985 (defvar gnus-unique-id-char nil)
 986
 987 ;; If you ever change this function, make sure the new version
 988 ;; cannot generate IDs that the old version could.
 989 ;; You might for example insert a "." somewhere (not next to another dot
 990 ;; or string boundary), or modify the newsreader name to "Ding".
 991 (defun gnus-inews-unique-id-new ()
 992   ;; Dont use microseconds from (current-time), they may be unsupported.
 993   ;; Instead we use this randomly inited counter.
 994   (setq gnus-unique-id-char
 995         (% (1+ (or gnus-unique-id-char (logand (random t) (1- (lsh 1 20)))))
 996            ;; (current-time) returns 16-bit ints,
 997            ;; and 2^16*25 just fits into 4 digits i base 36.
 998            (* 25 25)))
 999   (let ((tm (if (fboundp 'current-time)
1000                 (current-time) '(12191 46742 287898))))
1001     (concat
1002      (if (memq system-type '(ms-dos emx vax-vms))
1003          (let ((user (downcase (gnus-inews-login-name))))
1004            (while (string-match "[^a-z0-9_]" user)
1005              (aset user (match-beginning 0) ?_))
1006            user)
1007        (gnus-number-base36 (user-uid) -1))
1008      (gnus-number-base36 (+ (car   tm) (lsh (% gnus-unique-id-char 25) 16)) 4)
1009      (gnus-number-base36 (+ (nth 1 tm) (lsh (/ gnus-unique-id-char 25) 16)) 4)
1010      ;; Append the newsreader name, because while the generated
1011      ;; ID is unique to this newsreader, other newsreaders might
1012      ;; otherwise generate the same ID via another algorithm.
1013      ".DING")))
1014
1015
1016 (defun gnus-inews-date ()
1017   "Current time string."
1018   (timezone-make-date-arpa-standard
1019    (current-time-string) (current-time-zone)))
1020
1021 (defun gnus-inews-organization ()
1022   "Return user's organization.
1023 The ORGANIZATION environment variable is used if defined.
1024 If not, the variable `gnus-local-organization' is used instead.
1025 If it is a function, the function will be called with the current
1026 newsgroup name as the argument.
1027 If this is a file name, the contents of this file will be used as the
1028 organization."
1029   (let* ((organization
1030           (or (getenv "ORGANIZATION")
1031               (if gnus-local-organization
1032                   (if (and (symbolp gnus-local-organization)
1033                            (fboundp gnus-local-organization))
1034                       (funcall gnus-local-organization gnus-newsgroup-name)
1035                     gnus-local-organization))
1036               gnus-organization-file
1037               "~/.organization")))
1038     (and (stringp organization)
1039          (> (length organization) 0)
1040          (or (file-exists-p organization)
1041              (string-match " " organization)
1042              (not (string-match  "^/[^/]+/" (expand-file-name organization))))
1043          (save-excursion
1044            (gnus-set-work-buffer)
1045            (if (file-exists-p organization)
1046                (insert-file-contents organization)
1047              (insert organization))
1048            (goto-char (point-min))
1049            (while (re-search-forward " *\n *" nil t)
1050              (replace-match " " t t))
1051            (buffer-substring (point-min) (point-max))))))
1052
1053 (defun gnus-inews-lines ()
1054   "Count the number of lines and return numeric string."
1055   (save-excursion
1056     (save-restriction
1057       (widen)
1058       (goto-char (point-min))
1059       (re-search-forward
1060        (concat "^" (regexp-quote mail-header-separator) "$"))
1061       (forward-line 1)
1062       (int-to-string (count-lines (point) (point-max))))))
1063
1064 \f
1065 ;;;
1066 ;;; Gnus Mail Functions
1067 ;;;
1068
1069 ;;; Mail reply commands of Gnus summary mode
1070
1071 (defun gnus-summary-reply (yank)
1072   "Reply mail to news author.
1073 If prefix argument YANK is non-nil, original article is yanked automatically.
1074 Customize the variable gnus-mail-reply-method to use another mailer."
1075   (interactive "P")
1076   ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
1077   ;; Stripping headers should be specified with mail-yank-ignored-headers.
1078   (gnus-set-global-variables)
1079   (setq gnus-winconf-post-news (current-window-configuration))
1080   (gnus-summary-select-article t)
1081   (let ((gnus-newsgroup-name gnus-newsgroup-name))
1082     (bury-buffer gnus-article-buffer)
1083     (funcall gnus-mail-reply-method yank))
1084   (gnus-article-hide-headers-if-wanted))
1085
1086 (defun gnus-summary-reply-with-original ()
1087   "Reply mail to news author with original article.
1088 Customize the variable gnus-mail-reply-method to use another mailer."
1089   (interactive)
1090   (gnus-summary-reply t))
1091
1092 (defun gnus-summary-mail-forward (post)
1093   "Forward the current message to another user.
1094 Customize the variable gnus-mail-forward-method to use another mailer."
1095   (interactive "P")
1096   (gnus-summary-select-article t)
1097   (setq gnus-winconf-post-news (current-window-configuration))
1098   (if gnus-split-window
1099       (widen)
1100     (switch-to-buffer gnus-article-buffer)
1101     (widen)
1102     (delete-other-windows)
1103     (bury-buffer gnus-article-buffer))
1104   (let ((gnus-newsgroup-name gnus-newsgroup-name))
1105     (if post
1106         (gnus-forward-using-post)
1107       (funcall gnus-mail-forward-method)))
1108   (gnus-article-hide-headers-if-wanted))
1109
1110 (defun gnus-summary-post-forward ()
1111   "Forward the current article to a newsgroup."
1112   (interactive)
1113   (gnus-summary-mail-forward t))
1114
1115 (defun gnus-summary-mail-other-window ()
1116   "Compose mail in other window.
1117 Customize the variable `gnus-mail-other-window-method' to use another
1118 mailer."
1119   (interactive)
1120   (setq gnus-winconf-post-news (current-window-configuration))
1121   (let ((gnus-newsgroup-name gnus-newsgroup-name))
1122     (funcall gnus-mail-other-window-method)))
1123
1124 (defun gnus-mail-reply-using-mail (&optional yank to-address)
1125   (save-excursion
1126     (set-buffer gnus-summary-buffer)
1127     (let ((info (nth 2 (gnus-gethash gnus-newsgroup-name gnus-newsrc-hashtb)))
1128           (group (gnus-group-real-name gnus-newsgroup-name))
1129           (cur (cons (current-buffer) (cdr gnus-article-current)))
1130           from subject date to reply-to message-of
1131           references message-id sender follow-to cc sendto elt)
1132       (set-buffer (get-buffer-create "*mail*"))
1133       (mail-mode)
1134       (make-local-variable 'gnus-article-reply)
1135       (setq gnus-article-reply cur)
1136       (use-local-map (copy-keymap mail-mode-map))
1137       (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
1138       (if (and (buffer-modified-p)
1139                (> (buffer-size) 0)
1140                (not (gnus-y-or-n-p
1141                      "Unsent article being composed; erase it? ")))
1142           ()
1143         (erase-buffer)
1144         (save-excursion
1145           (set-buffer gnus-article-buffer)
1146           (let ((buffer-read-only nil))
1147             (goto-char (point-min))
1148             (narrow-to-region (point-min)
1149                               (progn (search-forward "\n\n") (point)))
1150             (add-text-properties (point-min) (point-max) '(invisible nil)))
1151           (if (and (boundp 'gnus-reply-to-function)
1152                    gnus-reply-to-function)
1153               (save-excursion
1154                 (save-restriction
1155                   (gnus-narrow-to-headers)
1156                   (setq follow-to (funcall gnus-reply-to-function group)))))
1157           (setq from (mail-fetch-field "from"))
1158           (setq date (mail-fetch-field "date"))
1159           (and from
1160                (let ((stop-pos
1161                       (string-match "  *at \\|  *@ \\| *(\\| *<" from)))
1162                  (setq message-of
1163                        (concat (if stop-pos (substring from 0 stop-pos) from)
1164                                "'s message of " date))))
1165           (setq sender (mail-fetch-field "sender"))
1166           (setq subject (or (mail-fetch-field "subject")
1167                             "Re: none"))
1168           (or (string-match "^[Rr][Ee]:" subject)
1169               (setq subject (concat "Re: " subject)))
1170           (setq cc (mail-fetch-field "cc"))
1171           (setq reply-to (mail-fetch-field "reply-to"))
1172           (setq references (mail-fetch-field "references"))
1173           (setq message-id (mail-fetch-field "message-id"))
1174           (widen))
1175         (setq news-reply-yank-from from)
1176         (setq news-reply-yank-message-id message-id)
1177
1178         ;; Gather the "to" addresses out of the follow-to list and remove
1179         ;; them as we go.
1180         (if (and follow-to (listp follow-to))
1181             (while (setq elt (assoc "To" follow-to))
1182               (setq sendto (concat sendto (and sendto ", ") (cdr elt)))
1183               (setq follow-to (delq elt follow-to))))
1184
1185         (mail-setup (or to-address
1186                         (if (and follow-to (not (stringp follow-to))) sendto
1187                           (or follow-to reply-to from sender "")))
1188                     subject message-of nil gnus-article-buffer nil)
1189
1190         (if (and follow-to (listp follow-to))
1191             (progn
1192               (goto-char (point-min))
1193               (re-search-forward "^To:" nil t)
1194               (beginning-of-line)
1195               (forward-line 1)
1196               (while follow-to
1197                 (insert (car (car follow-to)) ": " (cdr (car follow-to)) "\n")
1198                 (setq follow-to (cdr follow-to)))))
1199         ;; Fold long references line to follow RFC1036.
1200         (mail-position-on-field "References")
1201         (let ((begin (- (point) (length "References: ")))
1202               (fill-column 78)
1203               (fill-prefix "\t"))
1204           (if references (insert references))
1205           (if (and references message-id) (insert " "))
1206           (if message-id (insert message-id))
1207           ;; The region must end with a newline to fill the region
1208           ;; without inserting extra newline.
1209           (fill-region-as-paragraph begin (1+ (point))))
1210         (goto-char (point-min))
1211         (re-search-forward
1212          (concat "^" (regexp-quote mail-header-separator) "$"))
1213         (forward-line 1)
1214         (if yank
1215             (let ((last (point)))
1216               (save-excursion
1217                 (mail-yank-original nil))
1218               (run-hooks 'news-reply-header-hook)
1219               (goto-char last))))
1220       (let ((mail (current-buffer)))
1221         (if yank
1222             (progn
1223               (gnus-configure-windows '(0 1 0))
1224               (switch-to-buffer mail))
1225           (gnus-configure-windows '(0 0 1))
1226           (switch-to-buffer-other-window mail))))))
1227
1228 (defun gnus-mail-yank-original ()
1229   (interactive)
1230   (save-excursion
1231    (mail-yank-original nil))
1232   (run-hooks 'news-reply-header-hook))
1233
1234 (defun gnus-mail-send-and-exit ()
1235   (interactive)
1236   (let ((cbuf (current-buffer)))
1237     (mail-send-and-exit nil)
1238     (if (get-buffer gnus-group-buffer)
1239         (progn
1240           (save-excursion
1241             (set-buffer cbuf)
1242             (let ((reply gnus-article-reply))
1243               (if (gnus-buffer-exists-p (car-safe reply))
1244                   (progn
1245                     (set-buffer (car reply))
1246                     (and (cdr reply)
1247                          (gnus-summary-mark-article-as-replied
1248                           (cdr reply)))))))
1249           (and gnus-winconf-post-news
1250                (set-window-configuration gnus-winconf-post-news))
1251           (setq gnus-winconf-post-news nil)))))
1252
1253 (defun gnus-forward-make-subject ()
1254   (concat "[" (if (memq 'mail (assoc (symbol-name
1255                                       (car (gnus-find-method-for-group
1256                                             gnus-newsgroup-name)))
1257                                      gnus-valid-select-methods))
1258                   (gnus-fetch-field "From")
1259                 gnus-newsgroup-name)
1260           "] " (or (gnus-fetch-field "Subject") "")))
1261
1262 (defun gnus-forward-insert-buffer (buffer)
1263   (let ((beg (goto-char (point-max))))
1264     (insert "------- Start of forwarded message -------\n")
1265     (insert-buffer buffer)
1266     (goto-char (point-max))
1267     (insert "------- End of forwarded message -------\n")
1268     ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
1269     (goto-char beg)
1270     (while (setq beg (next-single-property-change (point) 'invisible))
1271       (goto-char beg)
1272       (delete-region beg (or (next-single-property-change
1273                               (point) 'invisible)
1274                              (point-max))))))
1275
1276 (defun gnus-mail-forward-using-mail ()
1277   "Forward the current message to another user using mail."
1278   ;; This is almost a carbon copy of rmail-forward in rmail.el.
1279   (let ((forward-buffer (current-buffer))
1280         (subject (gnus-forward-make-subject)))
1281     ;; If only one window, use it for the mail buffer.  Otherwise, use
1282     ;; another window for the mail buffer so that the Rmail buffer
1283     ;; remains visible and sending the mail will get back to it.
1284     (if (if (one-window-p t)
1285             (mail nil nil subject)
1286           (mail-other-window nil nil subject))
1287         (save-excursion
1288           (use-local-map (copy-keymap (current-local-map)))
1289           (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
1290           (gnus-forward-insert-buffer forward-buffer)
1291           ;; You have a chance to arrange the message.
1292           (run-hooks 'gnus-mail-forward-hook)))))
1293
1294 (defun gnus-forward-using-post ()
1295   (let ((forward-buffer (current-buffer))
1296         (subject (gnus-forward-make-subject)))
1297     (gnus-post-news 'post nil nil nil nil subject)
1298     (save-excursion
1299       (gnus-forward-insert-buffer forward-buffer)
1300       ;; You have a chance to arrange the message.
1301       (run-hooks 'gnus-mail-forward-hook))))
1302
1303 (defun gnus-mail-other-window-using-mail ()
1304   "Compose mail other window using mail."
1305   (mail-other-window nil nil nil nil nil (get-buffer gnus-article-buffer))
1306   (use-local-map (copy-keymap (current-local-map)))
1307   (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit))
1308
1309 (provide 'gnus-msg)
1310
1311 ;;; gnus-message.el ends here