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

   1 ;;; gnus-msg.el --- 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 (require 'gnus-ems)
  31
  32 (defvar gnus-organization-file "/usr/lib/news/organization"
  33   "*Local news organization file.")
  34
  35 (defvar gnus-post-prepare-function nil
  36   "*Function that is run after a post buffer has been prepared.
  37 It is called with the name of the newsgroup that is posted to. It
  38 might be used, for instance, for inserting signatures based on the
  39 newsgroup name. (In that case, `gnus-signature-file' and
  40 `mail-signature' should both be set to nil).")
  41
  42 (defvar gnus-post-prepare-hook nil
  43   "*Hook that is run after a post buffer has been prepared.
  44 If you want to insert the signature, you might put
  45 `gnus-inews-insert-signature' in this hook.")
  46
  47 (defvar gnus-use-followup-to 'use
  48   "*Specifies what to do with Followup-To header.
  49 If nil, ignore the header. If it is t, use its value, but ignore
  50 `poster'. If it is neither nil nor t, which is the default, always use
  51 the value.")
  52
  53 (defvar gnus-followup-to-function nil
  54   "*A variable that contains a function that returns a followup address.
  55 The function will be called in the buffer of the article that is being
  56 followed up. The buffer will be narrowed to the headers of the
  57 article. To pick header headers, one might use `mail-fetch-field'.  The
  58 function will be called with the name of the current newsgroup as the
  59 argument.
  60
  61 Here's an example `gnus-followup-to-function':
  62
  63 (setq gnus-followup-to-function
  64       (lambda (group)
  65         (cond ((string= group \"mail.list\")
  66                (or (mail-fetch-field \"sender\")
  67                    (mail-fetch-field \"from\")))
  68               (t
  69                (or (mail-fetch-field \"reply-to\")
  70                    (mail-fetch-field \"from\"))))))")
  71
  72 (defvar gnus-reply-to-function nil
  73   "*A variable that contains a function that returns a reply address.
  74 See the `gnus-followup-to-function' variable for an explanation of how
  75 this variable is used.
  76
  77 This function should return a string that will be used to fill in the
  78 header.  This function may also return a list.  In that case, every
  79 list element should be a cons where the first car should be a string
  80 with the header name, and the cdr should be a string with the header
  81 value.")
  82
  83 (defvar gnus-author-copy (getenv "AUTHORCOPY")
  84   "*Save outgoing articles in this file.
  85 Initialized from the AUTHORCOPY environment variable.
  86
  87 If this variable begins with the character \"|\", outgoing articles
  88 will be piped to the named program. It is possible to save an article
  89 in an MH folder as follows:
  90
  91 \(setq gnus-author-copy \"|/usr/local/lib/mh/rcvstore +Article\")
  92
  93 If the first character is not a pipe, articles are saved using the
  94 function specified by the `gnus-author-copy-saver' variable.")
  95
  96 (defvar gnus-mail-self-blind nil
  97   "*Non-nil means insert a BCC header in all outgoing articles.
  98 This will result in having a copy of the article mailed to yourself.
  99 The BCC header is inserted when the post buffer is initialized, so you
 100 can remove or alter the BCC header to override the default.")
 101
 102 (defvar gnus-author-copy-saver (function rmail-output)
 103   "*A function called to save outgoing articles.
 104 This function will be called with the same of the file to store the
 105 article in. The default function is `rmail-output' which saves in Unix
 106 mailbox format.")
 107
 108 (defvar gnus-user-login-name nil
 109   "*The login name of the user.
 110 Got from the function `user-login-name' if undefined.")
 111
 112 (defvar gnus-user-full-name nil
 113   "*The full name of the user.
 114 Got from the NAME environment variable if undefined.")
 115
 116 (defvar gnus-user-from-line nil
 117   "*Your full, complete e-mail address.
 118 Overrides the other Gnus variables if it is non-nil.
 119
 120 Here are two example values of this variable:
 121
 122  \"Lars Magne Ingebrigtsen <larsi@ifi.uio.no>\"
 123
 124 and
 125
 126  \"larsi@ifi.uio.no (Lars Magne Ingebrigtsen)\"
 127
 128 The first version is recommended, but the name has to be quoted if it
 129 contains non-alphanumerical characters.")
 130
 131 (defvar gnus-signature-file "~/.signature"
 132   "*Your signature file.
 133 If the variable is a string that doesn't correspond to a file, the
 134 string itself is inserted.")
 135
 136 (defvar gnus-signature-function nil
 137   "*A function that should return a signature file name.
 138 The function will be called with the name of the newsgroup being
 139 posted to.
 140 If the function returns a string that doesn't correspond to a file, the
 141 string itself is inserted.
 142 If the function returns nil, the `gnus-signature-file' variable will
 143 be used instead.")
 144
 145 (defvar gnus-required-headers
 146   '(From Date Newsgroups Subject Message-ID Organization Lines X-Newsreader)
 147   "*Headers to be generated or prompted for when posting an article.
 148 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
 149 Message-ID.  Organization, Lines and X-Newsreader are optional.  If
 150 you want Gnus not to insert some header, remove it from this list.")
 151
 152 (defvar gnus-deletable-headers '(Message-ID)
 153   "*Headers to be deleted if they already exists.")
 154
 155 (defvar gnus-check-before-posting
 156   '(subject-cmsg multiple-headers sendsys message-id from
 157                  long-lines control-chars size new-text
 158                  signature)
 159   "In non-nil, Gnus will attempt to run some checks on outgoing posts.
 160 If this variable is t, Gnus will check everything it can.  If it is a
 161 list, then those elements in that list will be checked.")
 162
 163 (defvar gnus-delete-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:"
 164   "*Header lines matching this regexp will be deleted before posting.
 165 It's best to delete old Path and Date headers before psoting to avoid
 166 any confusion.")
 167
 168 (defvar gnus-auto-mail-to-author nil
 169   "*If non-nil, mail the authors of articles a copy of your follow-ups.
 170 If this variable is `ask', the user will be prompted for whether to
 171 mail a copy.  The string given by `gnus-mail-courtesy-message' will be
 172 inserted at the beginning of the mail copy.
 173
 174 Mail is sent using the function specified by the
 175 `gnus-mail-send-method' variable.")
 176
 177 ;; Added by Ethan Bradford <ethanb@ptolemy.astro.washington.edu>.
 178 (defvar gnus-mail-courtesy-message
 179   "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
 180   "*This is inserted at the start of a mailed copy of a posted message.
 181 If this variable is nil, no such courtesy message will be added.")
 182
 183 (defvar gnus-mail-reply-method (function gnus-mail-reply-using-mail)
 184   "*Function to compose a reply.
 185 Three pre-made functions are `gnus-mail-reply-using-mail' (sendmail);
 186 `gnus-mail-reply-using-mhe' (MH-E); and `gnus-mail-reply-using-vm'.")
 187
 188 (defvar gnus-mail-forward-method (function gnus-mail-forward-using-mail)
 189   "*Function to forward the current message to another user.
 190 Three pre-made functions are `gnus-mail-forward-using-mail' (sendmail);
 191 `gnus-mail-forward-using-mhe' (MH-E); and `gnus-mail-forward-using-vm'.")
 192
 193 (defvar gnus-mail-other-window-method 'gnus-mail-other-window-using-mail
 194   "*Function to compose mail in the other window.
 195 Three pre-made functions are `gnus-mail-other-window-using-mail'
 196 (sendmail); `gnus-mail-other-window-using-mhe' (MH-E); and
 197 `gnus-mail-other-window-using-vm'.")
 198
 199 (defvar gnus-mail-send-method send-mail-function
 200   "*Function to mail a message which is also being posted as an article.
 201 The message must have To or Cc header.  The default is copied from
 202 the variable `send-mail-function'.")
 203
 204 (defvar gnus-inews-article-function 'gnus-inews-article
 205   "*Function to post an article.")
 206
 207 (defvar gnus-inews-article-hook (list 'gnus-inews-do-fcc)
 208   "*A hook called before finally posting an article.
 209 The default hook (`gnus-inews-do-fcc') does FCC processing (ie. saves
 210 the article to a file).")
 211
 212 (defvar gnus-inews-article-header-hook nil
 213   "*A hook called after inserting the headers in an article to be posted.
 214 The hook is called from the *post-news* buffer, narrowed to the
 215 headers.")
 216
 217 (defvar gnus-mail-hook nil
 218   "*A hook called as the last thing after setting up a mail buffer.")
 219
 220 ;;; Internal variables.
 221
 222 (defvar gnus-post-news-buffer "*post-news*")
 223 (defvar gnus-mail-buffer "*mail*")
 224 (defvar gnus-summary-send-map nil)
 225 (defvar gnus-article-copy nil)
 226 (defvar gnus-reply-subject nil)
 227
 228 \f
 229 ;;;
 230 ;;; Gnus Posting Functions
 231 ;;;
 232
 233 (define-prefix-command 'gnus-summary-send-map)
 234 (define-key gnus-summary-mode-map "S" 'gnus-summary-send-map)
 235 (define-key gnus-summary-send-map "p" 'gnus-summary-post-news)
 236 (define-key gnus-summary-send-map "f" 'gnus-summary-followup)
 237 (define-key gnus-summary-send-map "F" 'gnus-summary-followup-with-original)
 238 (define-key gnus-summary-send-map "b" 'gnus-summary-followup-and-reply)
 239 (define-key gnus-summary-send-map "B" 'gnus-summary-followup-and-reply-with-original)
 240 (define-key gnus-summary-send-map "c" 'gnus-summary-cancel-article)
 241 (define-key gnus-summary-send-map "s" 'gnus-summary-supersede-article)
 242 (define-key gnus-summary-send-map "r" 'gnus-summary-reply)
 243 (define-key gnus-summary-send-map "R" 'gnus-summary-reply-with-original)
 244 (define-key gnus-summary-send-map "m" 'gnus-summary-mail-other-window)
 245 (define-key gnus-summary-send-map "u" 'gnus-uu-post-news)
 246 (define-key gnus-summary-send-map "om" 'gnus-summary-mail-forward)
 247 (define-key gnus-summary-send-map "op" 'gnus-summary-post-forward)
 248 (define-key gnus-summary-send-map "Om" 'gnus-uu-digest-mail-forward)
 249 (define-key gnus-summary-send-map "Op" 'gnus-uu-digest-post-forward)
 250
 251 ;;; Internal functions.
 252
 253 (defun gnus-number-base36 (num len)
 254   (if (if (< len 0) (<= num 0) (= len 0))
 255       ""
 256     (concat (gnus-number-base36 (/ num 36) (1- len))
 257             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
 258                                   (% num 36))))))
 259
 260 ;;; Post news commands of Gnus group mode and summary mode
 261
 262 (defun gnus-group-mail ()
 263   "Start composing a mail."
 264   (interactive)
 265   (funcall gnus-mail-other-window-method)
 266   (gnus-configure-windows 'group-mail)
 267   (run-hooks 'gnus-mail-hook))
 268
 269 (defun gnus-group-post-news ()
 270   "Post an article."
 271   (interactive)
 272   (let ((gnus-newsgroup-name nil))
 273     (gnus-post-news 'post nil nil gnus-article-buffer)))
 274
 275 (defun gnus-summary-post-news ()
 276   "Post an article."
 277   (interactive)
 278   (gnus-set-global-variables)
 279   (gnus-post-news 'post gnus-newsgroup-name))
 280
 281 (defun gnus-summary-followup (yank &optional yank-articles)
 282   "Compose a followup to an article.
 283 If prefix argument YANK is non-nil, original article is yanked automatically."
 284   (interactive "P")
 285   (gnus-set-global-variables)
 286   (if yank-articles (gnus-summary-goto-subject (car yank-articles)))
 287   (save-window-excursion
 288     (gnus-summary-select-article))
 289   (let ((headers gnus-current-headers)
 290         (gnus-newsgroup-name gnus-newsgroup-name))
 291     ;; Check Followup-To: poster.
 292     (set-buffer gnus-article-buffer)
 293     (if (and gnus-use-followup-to
 294              (string-equal "poster" (gnus-fetch-field "followup-to"))
 295              (or (not (eq gnus-use-followup-to t))
 296                  (not (gnus-y-or-n-p
 297                        "Do you want to ignore `Followup-To: poster'? "))))
 298         ;; Mail to the poster.
 299         (gnus-summary-reply yank)
 300       (gnus-post-news nil gnus-newsgroup-name
 301                       headers gnus-article-buffer
 302                       (or yank-articles (not (not yank)))))))
 303
 304 (defun gnus-summary-followup-with-original (n)
 305   "Compose a followup to an article and include the original article."
 306   (interactive "P")
 307   (gnus-summary-followup t (gnus-summary-work-articles n)))
 308
 309 ;; Suggested by Daniel Quinlan <quinlan@best.com>.
 310 (defun gnus-summary-followup-and-reply (yank &optional yank-articles)
 311   "Compose a followup and do an auto mail to author."
 312   (interactive "P")
 313   (gnus-set-global-variables)
 314   (let ((gnus-auto-mail-to-author t))
 315     (gnus-summary-followup yank yank-articles)))
 316
 317 (defun gnus-summary-followup-and-reply-with-original (n)
 318   "Compose a followup, include the original, and do an auto mail to author."
 319   (interactive "P")
 320   (gnus-summary-followup-and-reply t (gnus-summary-work-articles n)))
 321
 322 (defun gnus-summary-cancel-article (n)
 323   "Cancel an article you posted."
 324   (interactive "P")
 325   (gnus-set-global-variables)
 326   (let ((articles (gnus-summary-work-articles n)))
 327     (while articles
 328       (gnus-summary-select-article t nil nil (car articles))
 329       (and (gnus-eval-in-buffer-window gnus-article-buffer (gnus-cancel-news))
 330            (gnus-summary-mark-as-read (car articles) gnus-canceled-mark))
 331       (gnus-summary-remove-process-mark (car articles))
 332       (gnus-article-hide-headers-if-wanted)
 333       (setq articles (cdr articles)))))
 334
 335 (defun gnus-summary-supersede-article ()
 336   "Compose an article that will supersede a previous article.
 337 This is done simply by taking the old article and adding a Supersedes
 338 header line with the old Message-ID."
 339   (interactive)
 340   (gnus-set-global-variables)
 341   (gnus-summary-select-article t)
 342   (if (or
 343        (string-equal
 344         (downcase (mail-strip-quoted-names
 345                    (header-from gnus-current-headers)))
 346         (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
 347       (error "This article is not yours."))
 348   (save-excursion
 349     (set-buffer gnus-article-buffer)
 350     (let ((buffer-read-only nil))
 351       (goto-char (point-min))
 352       (search-forward "\n\n" nil t)
 353       (if (not (re-search-backward "^Message-ID: " nil t))
 354           (error "No Message-ID in this article"))))
 355   (if (gnus-post-news 'post gnus-newsgroup-name)
 356       (progn
 357         (erase-buffer)
 358         (insert-buffer gnus-article-buffer)
 359         (goto-char (point-min))
 360         (search-forward "\n\n" nil t)
 361         (if (not (re-search-backward "^Message-ID: " nil t))
 362             (error "No Message-ID in this article")
 363           (replace-match "Supersedes: " t t))
 364         (search-forward "\n\n")
 365         (forward-line -1)
 366         (insert mail-header-separator)
 367
 368         (forward-line -1)
 369         (narrow-to-region (point-min) (point))
 370         (goto-char (point-min))
 371         (and gnus-delete-supersedes-headers
 372              (delete-matching-lines gnus-delete-supersedes-headers))
 373         (widen))))
 374
 375 \f
 376 ;;;###autoload
 377 (defalias 'sendnews 'gnus-post-news)
 378
 379 ;;;###autoload
 380 (defalias 'postnews 'gnus-post-news)
 381
 382 (defun gnus-copy-article-buffer (&optional article-buffer)
 383   ;; make a copy of the article buffer with all text properties removed
 384   ;; this copy is in the buffer gnus-article-copy.
 385   ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
 386   ;; this buffer should be passed to all mail/news reply/post routines.
 387   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 388   (buffer-disable-undo gnus-article-copy)
 389   (or (memq gnus-article-copy gnus-buffer-list)
 390       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 391   (let ((article-buffer (or article-buffer gnus-article-buffer)))
 392     (if (and (get-buffer article-buffer)
 393              (buffer-name (get-buffer article-buffer)))
 394         (save-excursion
 395           (set-buffer article-buffer)
 396           (widen)
 397           (copy-to-buffer gnus-article-copy (point-min) (point-max))
 398           (set-text-properties (point-min) (point-max)
 399                                nil gnus-article-copy)))))
 400
 401 (defun gnus-post-news (post &optional group header article-buffer yank subject)
 402   "Begin editing a new USENET news article to be posted.
 403 Type \\[describe-mode] in the buffer to get a list of commands."
 404   (interactive (list t))
 405   (gnus-copy-article-buffer article-buffer)
 406   (if (or (not gnus-novice-user)
 407           gnus-expert-user
 408           (not (eq 'post
 409                    (nth 1 (assoc
 410                            (format "%s" (car (gnus-find-method-for-group
 411                                               gnus-newsgroup-name)))
 412                            gnus-valid-select-methods))))
 413           (and group
 414                (assq 'to-address
 415                      (nth 5 (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))))
 416           (gnus-y-or-n-p "Are you sure you want to post to all of USENET? "))
 417       (let ((sumart (if (not post)
 418                         (save-excursion
 419                           (set-buffer gnus-summary-buffer)
 420                           (cons (current-buffer) gnus-current-article))))
 421             (from (and header (header-from header)))
 422             (winconf (current-window-configuration))
 423             real-group)
 424         (and gnus-interactive-post
 425              (not gnus-expert-user)
 426              post (not group)
 427              (progn
 428                (setq group
 429                      (completing-read "Group: " gnus-active-hashtb))
 430                (or subject
 431                    (setq subject (read-string "Subject: ")))))
 432         (setq mail-reply-buffer gnus-article-copy)
 433
 434         (let ((newsgroup-name (or group gnus-newsgroup-name "")))
 435           (setq real-group (and group (gnus-group-real-name group)))
 436           (setq gnus-post-news-buffer
 437                 (gnus-request-post-buffer
 438                  post real-group subject header gnus-article-copy
 439                  (nth 2 (and group (gnus-gethash group gnus-newsrc-hashtb)))
 440                  (or (cdr (assq 'to-group
 441                                 (nth 5 (nth 2 (gnus-gethash
 442                                                newsgroup-name
 443                                                gnus-newsrc-hashtb)))))
 444                      (if (and (boundp 'gnus-followup-to-function)
 445                               gnus-followup-to-function
 446                               gnus-article-copy)
 447                          (save-excursion
 448                            (set-buffer gnus-article-copy)
 449                            (funcall gnus-followup-to-function group))))
 450                  gnus-use-followup-to))
 451           (if post
 452               (gnus-configure-windows 'post)
 453             (if yank
 454                 (gnus-configure-windows 'followup-yank)
 455               (gnus-configure-windows 'followup)))
 456           (gnus-overload-functions)
 457           (make-local-variable 'gnus-article-reply)
 458           (make-local-variable 'gnus-article-check-size)
 459           (make-local-variable 'gnus-reply-subject)
 460           (setq gnus-reply-subject (and header (header-subject header)))
 461           (setq gnus-article-reply sumart)
 462           ;; Handle `gnus-auto-mail-to-author'.
 463           ;; Suggested by Daniel Quinlan <quinlan@best.com>.
 464           (let ((to (and (not post)
 465                          (if (eq gnus-auto-mail-to-author 'ask)
 466                              (and (y-or-n-p "Also send mail to author? ") from)
 467                            (and gnus-auto-mail-to-author from)))))
 468             (if to
 469                 (progn
 470                   (if (mail-fetch-field "To")
 471                       (progn
 472                         (beginning-of-line)
 473                         (insert "Cc: " to "\n"))
 474                     (mail-position-on-field "To")
 475                     (insert to)))))
 476           ;; Handle author copy using BCC field.
 477           (if (and gnus-mail-self-blind
 478                    (not (mail-fetch-field "bcc")))
 479               (progn
 480                 (mail-position-on-field "Bcc")
 481                 (insert (if (stringp gnus-mail-self-blind)
 482                             gnus-mail-self-blind
 483                           (user-login-name)))))
 484           ;; Handle author copy using FCC field.
 485           (if gnus-author-copy
 486               (progn
 487                 (mail-position-on-field "Fcc")
 488                 (insert gnus-author-copy)))
 489           (goto-char (point-min))
 490           (if post
 491               (cond ((not group)
 492                      (re-search-forward "^Newsgroup:" nil t)
 493                      (end-of-line))
 494                     ((not subject)
 495                      (re-search-forward "^Subject:" nil t)
 496                      (end-of-line))
 497                     (t
 498                      (re-search-forward
 499                       (concat "^" (regexp-quote mail-header-separator) "$"))
 500                      (forward-line 1)))
 501             (re-search-forward
 502              (concat "^" (regexp-quote mail-header-separator) "$"))
 503             (forward-line 1)
 504             (if (not yank)
 505                 ()
 506               (save-excursion
 507                 (if (not (listp yank))
 508                     (news-reply-yank-original nil)
 509                   (while yank
 510                     (save-window-excursion
 511                       (set-buffer gnus-summary-buffer)
 512                       (gnus-summary-select-article nil nil nil (car yank))
 513                       (gnus-summary-remove-process-mark (car yank)))
 514                     (let ((mail-reply-buffer gnus-article-copy))
 515                       (news-reply-yank-original nil))
 516                     (setq yank (cdr yank)))))))
 517           (if gnus-post-prepare-function
 518               (funcall gnus-post-prepare-function group))
 519           (run-hooks 'gnus-post-prepare-hook)
 520           (make-local-variable 'gnus-prev-winconf)
 521           (setq gnus-prev-winconf winconf))))
 522   (setq gnus-article-check-size (cons (buffer-size) (gnus-article-checksum)))
 523   (message "")
 524   t)
 525
 526 (defun gnus-inews-news (&optional use-group-method)
 527   "Send a news message.
 528 If given a prefix, and the group is a foreign group, this function
 529 will attempt to use the foreign server to post the article."
 530   (interactive "P")
 531   (let* ((case-fold-search nil)
 532          (server-running (gnus-server-opened gnus-select-method))
 533          (reply gnus-article-reply)
 534          error)
 535     (save-excursion
 536       ;; Connect to default NNTP server if necessary.
 537       ;; Suggested by yuki@flab.fujitsu.junet.
 538       (gnus-start-news-server)          ;Use default server.
 539       ;; NNTP server must be opened before current buffer is modified.
 540       (widen)
 541       (goto-char (point-min))
 542       (run-hooks 'news-inews-hook)
 543       (save-restriction
 544         (narrow-to-region
 545          (point-min)
 546          (progn
 547            (goto-char (point-min))
 548            (re-search-forward
 549             (concat "^" (regexp-quote mail-header-separator) "$"))
 550            (match-beginning 0)))
 551
 552         ;; Correct newsgroups field: change sequence of spaces to comma and
 553         ;; eliminate spaces around commas.  Eliminate imbedded line breaks.
 554         (goto-char (point-min))
 555         (if (search-forward-regexp "^Newsgroups: +" nil t)
 556             (save-restriction
 557               (narrow-to-region
 558                (point)
 559                (if (re-search-forward "^[^ \t]" nil 'end)
 560                    (match-beginning 0)
 561                  (point-max)))
 562               (goto-char (point-min))
 563               (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing)
 564               (goto-char (point-min))
 565               (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")))
 566
 567         ;; Added by Per Abrahamsen <abraham@iesd.auc.dk>.
 568         ;; Help save the the world!
 569         (or
 570          gnus-expert-user
 571          (let ((newsgroups (mail-fetch-field "newsgroups"))
 572                (followup-to (mail-fetch-field "followup-to"))
 573                groups to)
 574            (if (and (string-match "," newsgroups) (not followup-to))
 575                (progn
 576                  (while (string-match "," newsgroups)
 577                    (setq groups
 578                          (cons (list (substring newsgroups
 579                                                 0 (match-beginning 0)))
 580                                groups))
 581                    (setq newsgroups (substring newsgroups (match-end 0))))
 582                  (setq groups (nreverse (cons (list newsgroups) groups)))
 583
 584                  (setq to
 585                        (completing-read "Followups to: (default all groups) "
 586                                         groups))
 587                  (if (> (length to) 0)
 588                      (progn
 589                        (goto-char (point-min))
 590                        (insert "Followup-To: " to "\n")))))))
 591
 592         ;; Cleanup Followup-To.
 593         (goto-char (point-min))
 594         (if (search-forward-regexp "^Followup-To: +" nil t)
 595             (save-restriction
 596               (narrow-to-region
 597                (point)
 598                (if (re-search-forward "^[^ \t]" nil 'end)
 599                    (match-beginning 0)
 600                  (point-max)))
 601               (goto-char (point-min))
 602               (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing)
 603               (goto-char (point-min))
 604               (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")))
 605
 606         ;; Mail the message too if To:, Bcc:. or Cc: exists.
 607         (let* ((types '("to" "bcc" "cc"))
 608                (ty types)
 609                fcc-line)
 610           (while ty
 611             (or (mail-fetch-field (car ty) nil t)
 612                 (setq types (delete (car ty) types)))
 613             (setq ty (cdr ty)))
 614
 615           (if (not types)
 616               ;; We do not want to send mail.
 617               ()
 618             (if (not gnus-mail-send-method)
 619                 (progn
 620                   (ding)
 621                   (gnus-message
 622                    1 "No mailer defined.  To: and/or Cc: fields ignored.")
 623                   (sit-for 1))
 624               (save-excursion
 625                 ;; We want to remove Fcc, because we want to handle
 626                 ;; that one ourselves...
 627
 628                 (goto-char (point-min))
 629                 (if (re-search-forward "^Fcc: " nil t)
 630                     (progn
 631                       (setq fcc-line
 632                             (buffer-substring
 633                              (progn (beginning-of-line) (point))
 634                              (progn (forward-line 1) (point))))
 635                       (forward-line -1)
 636                       (gnus-delete-line)))
 637
 638                 ;; We generate a Message-ID so that the mail and the
 639                 ;; news copy of the message both get the same ID.
 640                 (or (mail-fetch-field "message-id")
 641                     (progn
 642                       (goto-char (point-max))
 643                       (insert "Message-ID: " (gnus-inews-message-id) "\n")))
 644
 645                 (save-restriction
 646                   (widen)
 647                   (gnus-message 5 "Sending via mail...")
 648
 649                   (if (and gnus-mail-courtesy-message
 650                            (or (member "to" types)
 651                                (member "cc" types)))
 652                       ;; We only want to insert the courtesy mail
 653                       ;; message if we use to or cc; bcc should not
 654                       ;; have one. Well, if both bcc and to are
 655                       ;; present, it will get one anyway.
 656                       (progn
 657                         ;; Insert "courtesy" mail message.
 658                         (goto-char (point-min))
 659                         (re-search-forward
 660                          (concat "^" (regexp-quote
 661                                       mail-header-separator) "$"))
 662                         (forward-line 1)
 663                         (insert gnus-mail-courtesy-message)
 664                         (funcall gnus-mail-send-method)
 665                         (goto-char (point-min))
 666                         (search-forward gnus-mail-courtesy-message)
 667                         (replace-match "" t t))
 668                     (funcall gnus-mail-send-method))
 669
 670                   (gnus-message 5 "Sending via mail...done")
 671
 672                   (goto-char (point-min))
 673                   (narrow-to-region
 674                    (point)
 675                    (re-search-forward
 676                     (concat "^" (regexp-quote mail-header-separator) "$")))
 677                   (goto-char (point-min))
 678                   (delete-matching-lines "^BCC:"))
 679                 (if fcc-line
 680                     (progn
 681                       (goto-char (point-max))
 682                       (insert fcc-line))))))))
 683
 684       ;; Send to server.
 685       (gnus-message 5 "Posting to USENET...")
 686       (if (funcall gnus-inews-article-function use-group-method)
 687           (progn
 688             (gnus-message 5 "Posting to USENET...done")
 689             (if (gnus-buffer-exists-p (car-safe reply))
 690                 (progn
 691                   (save-excursion
 692                     (set-buffer gnus-summary-buffer)
 693                     (gnus-summary-mark-article-as-replied
 694                      (cdr reply))))))
 695         ;; We cannot signal an error.
 696         (setq error t)
 697         (ding) (gnus-message 1 "Article rejected: %s"
 698                              (gnus-status-message gnus-select-method)))
 699       (set-buffer-modified-p nil))
 700     ;; If NNTP server is opened by gnus-inews-news, close it by myself.
 701     (or server-running
 702         (gnus-close-server (gnus-find-method-for-group gnus-newsgroup-name)))
 703     (let ((conf gnus-prev-winconf))
 704       (bury-buffer)
 705       ;; Restore last window configuration.
 706       (and conf (not error) (set-window-configuration conf)))))
 707
 708 (defun gnus-inews-check-post ()
 709   "Check whether the post looks ok."
 710   (or
 711    (not gnus-check-before-posting)
 712    (and
 713     ;; We narrow to the headers and check them first.
 714     (save-excursion
 715       (save-restriction
 716         (goto-char (point-min))
 717         (narrow-to-region
 718          (point)
 719          (re-search-forward
 720           (concat "^" (regexp-quote mail-header-separator) "$")))
 721         (goto-char (point-min))
 722         (and
 723          ;; Check for commands in Subject.
 724          (or (gnus-check-before-posting 'subject-cmsg)
 725              (save-excursion
 726                (if (string-match "^cmsg " (mail-fetch-field "subject"))
 727                    (gnus-y-or-n-p
 728                     "The control code \"cmsg \" is in the subject. Really post? ")
 729                  t)))
 730          ;; Check for multiple identical headers.
 731          (or (gnus-check-before-posting 'multiple-headers)
 732              (save-excursion
 733                (let (found)
 734                  (while (and (not found) (re-search-forward "^[^ \t:]+: " nil t))
 735                    (save-excursion
 736                      (or (re-search-forward
 737                           (concat "^" (setq found
 738                                             (buffer-substring
 739                                              (match-beginning 0)
 740                                              (- (match-end 0) 2))))
 741                           nil t)
 742                          (setq found nil))))
 743                  (if found
 744                      (gnus-y-or-n-p
 745                       (format "Multiple %s headers. Really post? " found))
 746                    t))))
 747          ;; Check for version and sendsys.
 748          (or (gnus-check-before-posting 'sendsys)
 749              (save-excursion
 750                (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
 751                    (gnus-yes-or-no-p
 752                     (format "The article contains a %s command. Really post? "
 753                             (buffer-substring (match-beginning 0)
 754                                               (1- (match-end 0)))))
 755                  t)))
 756          ;; Check the Message-Id header.
 757          (or (gnus-check-before-posting 'message-id)
 758              (save-excursion
 759                (let* ((case-fold-search t)
 760                       (message-id (mail-fetch-field "message-id")))
 761                  (or (not message-id)
 762                      (and (string-match "@" message-id)
 763                           (string-match "@[^\\.]*\\." message-id))
 764                      (gnus-yes-or-no-p
 765                       (format
 766                        "The Message-ID looks strange: \"%s\". Really post? "
 767                        message-id))))))
 768          ;; Check the From header.
 769          (or (gnus-check-before-posting 'from)
 770              (save-excursion
 771                (let* ((case-fold-search t)
 772                       (from (mail-fetch-field "from")))
 773                  (or (not from)
 774                      (and (string-match "@" from)
 775                           (string-match "@[^\\.]*\\." from))
 776                      (gnus-yes-or-no-p
 777                       (format "The From looks strange: \"%s\". Really post? "
 778                               from)))))))))
 779     ;; Check for long lines.
 780     (or (gnus-check-before-posting 'long-lines)
 781         (save-excursion
 782           (goto-char (point-min))
 783           (re-search-forward
 784            (concat "^" (regexp-quote mail-header-separator) "$"))
 785           (while (and
 786                   (progn
 787                     (end-of-line)
 788                     (< (current-column) 80))
 789                   (zerop (forward-line 1))))
 790           (or (bolp)
 791               (eobp)
 792               (gnus-yes-or-no-p
 793                (format
 794                 "You have lines longer than 79 characters.  Really post? ")))))
 795     ;; Check for control characters.
 796     (or (gnus-check-before-posting 'control-chars)
 797         (save-excursion
 798           (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
 799               (gnus-y-or-n-p
 800                "The article contains control characters. Really post? ")
 801             t)))
 802     ;; Check excessive size.
 803     (or (gnus-check-before-posting 'size)
 804         (if (> (buffer-size) 60000)
 805             (gnus-y-or-n-p
 806              (format "The article is %d octets long. Really post? "
 807                      (buffer-size)))
 808           t))
 809     ;; Use the (size . checksum) variable to see whether the
 810     ;; article is empty or has only quoted text.
 811     (or (gnus-check-before-posting 'new-text)
 812         (if (and (= (buffer-size) (car gnus-article-check-size))
 813                  (= (gnus-article-checksum) (cdr gnus-article-check-size)))
 814             (gnus-yes-or-no-p
 815              "It looks like there's no new text in your article. Really post? ")
 816           t))
 817     ;; Check the length of the signature.
 818     (or (gnus-check-before-posting 'signature)
 819         (progn
 820           (goto-char (point-max))
 821           (if (not (re-search-backward gnus-signature-separator nil t))
 822               t
 823             (if (> (count-lines (point) (point-max)) 4)
 824                 (gnus-y-or-n-p
 825                  (format
 826                   "Your .sig is %d lines; it should be max 4.  Really post? "))
 827               t)))))))
 828
 829 (defun gnus-article-checksum ()
 830   (let ((sum 0))
 831     (save-excursion
 832       (while (not (eobp))
 833         (setq sum (logxor sum (following-char)))
 834         (forward-char 1)))
 835     sum))
 836
 837 ;; Returns non-nil if this type is not to be checked.
 838 (defun gnus-check-before-posting (type)
 839   (or (not gnus-check-before-posting)
 840       (if (listp gnus-check-before-posting)
 841           (memq type gnus-check-before-posting)
 842         t)))
 843
 844 (defun gnus-cancel-news ()
 845   "Cancel an article you posted."
 846   (interactive)
 847   (if (or gnus-expert-user
 848           (gnus-yes-or-no-p "Do you really want to cancel this article? "))
 849       (let ((from nil)
 850             (newsgroups nil)
 851             (message-id nil)
 852             (distribution nil))
 853         (or (gnus-member-of-valid 'post gnus-newsgroup-name)
 854             (error "This backend does not support canceling"))
 855         (save-excursion
 856           ;; Get header info. from original article.
 857           (save-restriction
 858             (gnus-article-show-all-headers)
 859             (goto-char (point-min))
 860             (search-forward "\n\n" nil 'move)
 861             (narrow-to-region (point-min) (point))
 862             (setq from (mail-fetch-field "from"))
 863             (setq newsgroups (mail-fetch-field "newsgroups"))
 864             (setq message-id (mail-fetch-field "message-id"))
 865             (setq distribution (mail-fetch-field "distribution")))
 866           ;; Verify if the article is absolutely user's by comparing
 867           ;; user id with value of its From: field.
 868           (if (not
 869                (string-equal
 870                 (downcase (mail-strip-quoted-names from))
 871                 (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
 872               (progn
 873                 (ding) (gnus-message 3 "This article is not yours.")
 874                 nil)
 875             ;; Make control article.
 876             (set-buffer (get-buffer-create " *Gnus-canceling*"))
 877             (buffer-disable-undo (current-buffer))
 878             (erase-buffer)
 879             (insert "Newsgroups: " newsgroups "\n"
 880                     "Subject: cancel " message-id "\n"
 881                     "Control: cancel " message-id "\n"
 882                     (if distribution
 883                         (concat "Distribution: " distribution "\n")
 884                       "")
 885                     mail-header-separator "\n"
 886                     "This is a cancel message from " from ".\n")
 887             ;; Send the control article to NNTP server.
 888             (gnus-message 5 "Canceling your article...")
 889             (prog1
 890                 (if (funcall gnus-inews-article-function)
 891                     (gnus-message 5 "Canceling your article...done")
 892                   (progn
 893                     (ding)
 894                     (gnus-message 1 "Cancel failed; %s"
 895                                   (gnus-status-message gnus-newsgroup-name))
 896                     nil)
 897                   t)
 898               ;; Kill the article buffer.
 899               (kill-buffer (current-buffer))))))))
 900
 901 \f
 902 ;;; Lowlevel inews interface
 903
 904 (defun gnus-inews-article (&optional use-group-method)
 905   "Post an article in current buffer using NNTP protocol."
 906   (let ((artbuf (current-buffer))
 907         (tmpbuf (get-buffer-create " *Gnus-posting*")))
 908     (widen)
 909     (goto-char (point-max))
 910     ;; require a newline at the end for inews to append .signature to
 911     (or (= (preceding-char) ?\n)
 912         (insert ?\n))
 913     ;; Prepare article headers.  All message body such as signature
 914     ;; must be inserted before Lines: field is prepared.
 915     (save-restriction
 916       (goto-char (point-min))
 917       (narrow-to-region
 918        (point-min)
 919        (save-excursion
 920          (re-search-forward
 921           (concat "^" (regexp-quote mail-header-separator) "$"))
 922          (match-beginning 0)))
 923       (gnus-inews-remove-headers)
 924       (gnus-inews-insert-headers)
 925       (run-hooks gnus-inews-article-header-hook)
 926       (widen))
 927     ;; Check whether the article is a good Net Citizen.
 928     (if (and gnus-article-check-size
 929              (not (gnus-inews-check-post)))
 930         ;; Aber nein!
 931         ()
 932       ;; Looks ok, so we do the nasty.
 933       (save-excursion
 934         (set-buffer tmpbuf)
 935         (buffer-disable-undo (current-buffer))
 936         (erase-buffer)
 937         (insert-buffer-substring artbuf)
 938         ;; Remove the header separator.
 939         (goto-char (point-min))
 940         (re-search-forward
 941          (concat "^" (regexp-quote mail-header-separator) "$"))
 942         (replace-match "" t t)
 943         ;; This hook may insert a signature.
 944         (run-hooks 'gnus-prepare-article-hook)
 945         ;; Run final inews hooks.  This hook may do FCC.
 946         ;; The article must be saved before being posted because
 947         ;; `gnus-request-post' modifies the buffer.
 948         (run-hooks 'gnus-inews-article-hook)
 949         ;; Post an article to NNTP server.
 950         ;; Return NIL if post failed.
 951         (prog1
 952             (gnus-request-post
 953              (if use-group-method
 954                  (gnus-find-method-for-group gnus-newsgroup-name)
 955                gnus-select-method) use-group-method)
 956           (kill-buffer (current-buffer)))))))
 957
 958 (defun gnus-inews-remove-headers ()
 959   (let ((case-fold-search t))
 960     ;; Remove NNTP-posting-host.
 961     (goto-char (point-min))
 962     (and (re-search-forward "^nntp-posting-host:" nil t)
 963          (delete-region (progn (beginning-of-line) (point))
 964                         (progn (forward-line 1) (point))))
 965     ;; Remove Bcc.
 966     (goto-char (point-min))
 967     (and (re-search-forward "^bcc:" nil t)
 968          (delete-region (progn (beginning-of-line) (point))
 969                         (progn (forward-line 1) (point))))))
 970
 971 (defun gnus-inews-insert-headers ()
 972   "Prepare article headers.
 973 Headers already prepared in the buffer are not modified.
 974 Headers in `gnus-required-headers' will be generated."
 975   (let ((Date (gnus-inews-date))
 976         (Message-ID (gnus-inews-message-id))
 977         (Organization (gnus-inews-organization))
 978         (From (gnus-inews-user-name))
 979         (Path (gnus-inews-path))
 980         (Subject nil)
 981         (Newsgroups nil)
 982         (Distribution nil)
 983         (Lines (gnus-inews-lines))
 984         (X-Newsreader gnus-version)
 985         (headers gnus-required-headers)
 986         (case-fold-search t)
 987         header value elem)
 988     ;; First we remove any old generated headers.
 989     (let ((headers gnus-deletable-headers))
 990       (while headers
 991         (goto-char (point-min))
 992         (and (re-search-forward
 993               (concat "^" (symbol-name (car headers)) ": *") nil t)
 994              (get-text-property (1+ (match-end 0)) 'gnus-deletable)
 995              (gnus-delete-line))
 996         (setq headers (cdr headers))))
 997     ;; Insert new Sender if the From is strange.
 998     (let ((from (mail-fetch-field "from")))
 999       (if (and from (not (string= (downcase from) (downcase From))))
1000           (progn
1001             (goto-char (point-min))
1002             (and (re-search-forward "^Sender:" nil t)
1003                  (delete-region (progn (beginning-of-line) (point))
1004                                 (progn (forward-line 1) (point))))
1005             (insert "Sender: " From "\n"))))
1006     ;; If there are References, and no "Re: ", then the thread has
1007     ;; changed name. See Son-of-1036.
1008     (if (and (mail-fetch-field "references")
1009              (get-buffer gnus-article-buffer))
1010         (let ((psubject (gnus-simplify-subject-re
1011                          (mail-fetch-field "subject"))))
1012           (or (and psubject gnus-reply-subject
1013                    (string= (gnus-simplify-subject-re gnus-reply-subject)
1014                             psubject))
1015               (progn
1016                 (string-match "@" Message-ID)
1017                 (setq Message-ID
1018                       (concat (substring Message-ID 0 (match-beginning 0))
1019                               "_-_"
1020                               (substring Message-ID (match-beginning 0))))))))
1021     ;; Go through all the required headers and see if they are in the
1022     ;; articles already. If they are not, or are empty, they are
1023     ;; inserted automatically - except for Subject, Newsgroups and
1024     ;; Distribution.
1025     (while headers
1026       (goto-char (point-min))
1027       (setq elem (car headers))
1028       (if (consp elem)
1029           (setq header (car elem))
1030         (setq header elem))
1031       (if (or (not (re-search-forward
1032                     (concat "^" (downcase (symbol-name header)) ":") nil t))
1033               (progn
1034                 (if (= (following-char) ? ) (forward-char 1) (insert " "))
1035                 (looking-at "[ \t]*$")))
1036           (progn
1037             (setq value
1038                   (or (if (consp elem)
1039                           ;; The element is a cons.  Either the cdr is
1040                           ;; a string to be inserted verbatim, or it
1041                           ;; is a function, and we insert the value
1042                           ;; returned from this function.
1043                           (or (and (stringp (cdr elem)) (cdr elem))
1044                               (and (fboundp (cdr elem)) (funcall (cdr elem))))
1045                         ;; The element is a symbol.  We insert the
1046                         ;; value of this symbol, if any.
1047                         (and (boundp header) (symbol-value header)))
1048                       ;; We couldn't generate a value for this header,
1049                       ;; so we just ask the user.
1050                       (read-from-minibuffer
1051                        (format "Empty header for %s; enter value: " header))))
1052             ;; Finally insert the header.
1053             (if (bolp)
1054                 (save-excursion
1055                   (goto-char (point-max))
1056                   (insert (symbol-name header) ": ")
1057                   ;; Add the deletable property to the headers that require it.
1058                   (if (memq header gnus-deletable-headers)
1059                       (add-text-properties
1060                        (point) (progn (insert value) (point))
1061                        '(gnus-deletable t) (current-buffer))
1062                     (insert value))
1063                   (insert "\n"))
1064               (replace-match value t t))))
1065       (setq headers (cdr headers)))))
1066
1067 (defun gnus-inews-insert-signature ()
1068   "Insert a signature file.
1069 If `gnus-signature-function' is bound and returns a string, this
1070 string is used instead of the variable `gnus-signature-file'.
1071 In either case, if the string is a file name, this file is
1072 inserted. If the string is not a file name, the string itself is
1073 inserted.
1074 If you never want any signature inserted, set both those variables to
1075 nil."
1076   (save-excursion
1077     (let ((signature
1078            (or (and gnus-signature-function
1079                     (funcall gnus-signature-function gnus-newsgroup-name))
1080                gnus-signature-file)))
1081       (if (and signature
1082                (or (file-exists-p signature)
1083                    (string-match " " signature)
1084                    (not (string-match
1085                          "^/[^/]+/" (expand-file-name signature)))))
1086           (progn
1087             (goto-char (point-max))
1088             (if (and mail-signature (search-backward "\n-- \n" nil t))
1089                 ()
1090               ;; Delete any previous signatures.
1091               (if (search-backward "\n-- \n" nil t)
1092                   (delete-region (1+ (point)) (point-max)))
1093               (insert "\n-- \n")
1094               (if (file-exists-p signature)
1095                   (insert-file-contents signature)
1096                 (insert signature))
1097               (goto-char (point-max))
1098               (or (bolp) (insert "\n"))))))))
1099
1100 (defun gnus-inews-do-fcc ()
1101   "Process FCC: fields in current article buffer.
1102 Unless the first character of the field is `|', the article is saved
1103 to the specified file using the function specified by the variable
1104 gnus-author-copy-saver.  The default function rmail-output saves in
1105 Unix mailbox format.
1106 If the first character is `|', the contents of the article is send to
1107 a program specified by the rest of the value."
1108   (let ((fcc-list nil)
1109         (fcc-file nil)
1110         (case-fold-search t))           ;Should ignore case.
1111     (save-excursion
1112       (save-restriction
1113         (goto-char (point-min))
1114         (search-forward "\n\n")
1115         (narrow-to-region (point-min) (point))
1116         (goto-char (point-min))
1117         (while (re-search-forward "^FCC:[ \t]*" nil t)
1118           (setq fcc-list
1119                 (cons (buffer-substring
1120                        (point)
1121                        (progn
1122                          (end-of-line)
1123                          (skip-chars-backward " \t")
1124                          (point)))
1125                       fcc-list))
1126           (delete-region (match-beginning 0)
1127                          (progn (forward-line 1) (point))))
1128         ;; Process FCC operations.
1129         (widen)
1130         (while fcc-list
1131           (setq fcc-file (car fcc-list))
1132           (setq fcc-list (cdr fcc-list))
1133           (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file)
1134                  (let ((program (substring fcc-file
1135                                            (match-beginning 1) (match-end 1))))
1136                    ;; Suggested by yuki@flab.fujitsu.junet.
1137                    ;; Send article to named program.
1138                    (call-process-region (point-min) (point-max) shell-file-name
1139                                         nil nil nil "-c" program)))
1140                 (t
1141                  ;; Suggested by hyoko@flab.fujitsu.junet.
1142                  ;; Save article in Unix mail format by default.
1143                  (gnus-make-directory (file-name-directory fcc-file))
1144                  (if (and gnus-author-copy-saver
1145                           (not (eq gnus-author-copy-saver 'rmail-output)))
1146                      (funcall gnus-author-copy-saver fcc-file)
1147                    (if (and (file-readable-p fcc-file) (rmail-file-p fcc-file))
1148                        (gnus-output-to-rmail fcc-file)
1149                      (rmail-output fcc-file 1 t t))))))))))
1150
1151 (defun gnus-inews-path ()
1152   "Return uucp path."
1153   (let ((login-name (gnus-inews-login-name)))
1154     (cond ((null gnus-use-generic-path)
1155            (concat (nth 1 gnus-select-method) "!" login-name))
1156           ((stringp gnus-use-generic-path)
1157            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
1158            (concat gnus-use-generic-path "!" login-name))
1159           (t login-name))))
1160
1161 (defun gnus-inews-user-name ()
1162   "Return user's network address as \"NAME@DOMAIN (FULL-NAME)\"."
1163   (let ((full-name (gnus-inews-full-name)))
1164     (or gnus-user-from-line
1165         (concat (if (or gnus-user-login-name gnus-use-generic-from
1166                         gnus-local-domain (getenv "DOMAINNAME"))
1167                     (concat (gnus-inews-login-name) "@"
1168                             (gnus-inews-domain-name gnus-use-generic-from))
1169                   user-mail-address)
1170                 ;; User's full name.
1171                 (cond ((string-equal full-name "") "")
1172                       ((string-equal full-name "&") ;Unix hack.
1173                        (concat " (" (user-login-name) ")"))
1174                       (t
1175                        (concat " (" full-name ")")))))))
1176
1177 (defun gnus-inews-login-name ()
1178   "Return login name."
1179   (or gnus-user-login-name (getenv "LOGNAME") (user-login-name)))
1180
1181 (defun gnus-inews-full-name ()
1182   "Return full user name."
1183   (or gnus-user-full-name (getenv "NAME") (user-full-name)))
1184
1185 (defun gnus-inews-domain-name (&optional genericfrom)
1186   "Return user's domain name.
1187 If optional argument GENERICFROM is a string, use it as the domain
1188 name; if it is non-nil, strip off local host name from the domain name.
1189 If the function `system-name' returns full internet name and the
1190 domain is undefined, the domain name is got from it."
1191   (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME"))
1192       (let* ((system-name (system-name))
1193              (domain
1194               (or (if (stringp genericfrom) genericfrom)
1195                   (getenv "DOMAINNAME")
1196                   gnus-local-domain
1197                   ;; Function `system-name' may return full internet name.
1198                   ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>.
1199                   (if (string-match "\\." system-name)
1200                       (substring system-name (match-end 0)))
1201                   (read-string "Domain name (no host): ")))
1202              (host (or (if (string-match "\\." system-name)
1203                            (substring system-name 0 (match-beginning 0)))
1204                        system-name)))
1205         (if (string-equal "." (substring domain 0 1))
1206             (setq domain (substring domain 1)))
1207         ;; Support GENERICFROM as same as standard Bnews system.
1208         ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
1209         (cond ((null genericfrom)
1210                (concat host "." domain))
1211               ;;((stringp genericfrom) genericfrom)
1212               (t domain)))
1213     (if (string-match "\\." (system-name))
1214         (system-name)
1215       (substring user-mail-address
1216                  (1+ (string-match "@" user-mail-address))))))
1217
1218 (defun gnus-inews-full-address ()
1219   (let ((domain (gnus-inews-domain-name))
1220         (system (system-name))
1221         (case-fold-search t))
1222     (if (string-match "\\." system) system
1223       (if (string-match (concat "^" (regexp-quote system)) domain) domain
1224         (concat system "." domain)))))
1225
1226 (defun gnus-inews-message-id ()
1227   "Generate unique Message-ID for user."
1228   ;; Message-ID should not contain a slash and should be terminated by
1229   ;; a number.  I don't know the reason why it is so.
1230   (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-full-address) ">"))
1231
1232 (defvar gnus-unique-id-char nil)
1233
1234 ;; If you ever change this function, make sure the new version
1235 ;; cannot generate IDs that the old version could.
1236 ;; You might for example insert a "." somewhere (not next to another dot
1237 ;; or string boundary), or modify the newsreader name to "Ding".
1238 (defun gnus-inews-unique-id ()
1239   ;; Dont use microseconds from (current-time), they may be unsupported.
1240   ;; Instead we use this randomly inited counter.
1241   (setq gnus-unique-id-char
1242         (% (1+ (or gnus-unique-id-char (logand (random t) (1- (lsh 1 20)))))
1243            ;; (current-time) returns 16-bit ints,
1244            ;; and 2^16*25 just fits into 4 digits i base 36.
1245            (* 25 25)))
1246   (let ((tm (if (fboundp 'current-time)
1247                 (current-time) '(12191 46742 287898))))
1248     (concat
1249      (if (memq system-type '(ms-dos emx vax-vms))
1250          (let ((user (downcase (gnus-inews-login-name))))
1251            (while (string-match "[^a-z0-9_]" user)
1252              (aset user (match-beginning 0) ?_))
1253            user)
1254        (gnus-number-base36 (user-uid) -1))
1255      (gnus-number-base36 (+ (car   tm) (lsh (% gnus-unique-id-char 25) 16)) 4)
1256      (gnus-number-base36 (+ (nth 1 tm) (lsh (/ gnus-unique-id-char 25) 16)) 4)
1257      ;; Append the newsreader name, because while the generated
1258      ;; ID is unique to this newsreader, other newsreaders might
1259      ;; otherwise generate the same ID via another algorithm.
1260      ".fsf")))
1261
1262
1263 (defun gnus-inews-date ()
1264   "Current time string."
1265   (timezone-make-date-arpa-standard
1266    (current-time-string) (current-time-zone)))
1267
1268 (defun gnus-inews-organization ()
1269   "Return user's organization.
1270 The ORGANIZATION environment variable is used if defined.
1271 If not, the variable `gnus-local-organization' is used instead.
1272 If it is a function, the function will be called with the current
1273 newsgroup name as the argument.
1274 If this is a file name, the contents of this file will be used as the
1275 organization."
1276   (let* ((organization
1277           (or (getenv "ORGANIZATION")
1278               (if gnus-local-organization
1279                   (if (and (symbolp gnus-local-organization)
1280                            (fboundp gnus-local-organization))
1281                       (funcall gnus-local-organization gnus-newsgroup-name)
1282                     gnus-local-organization))
1283               gnus-organization-file
1284               "~/.organization")))
1285     (and (stringp organization)
1286          (> (length organization) 0)
1287          (or (file-exists-p organization)
1288              (string-match " " organization)
1289              (not (string-match "^/usr/lib/" organization)))
1290          (save-excursion
1291            (gnus-set-work-buffer)
1292            (if (file-exists-p organization)
1293                (insert-file-contents organization)
1294              (insert organization))
1295            (goto-char (point-min))
1296            (while (re-search-forward " *\n *" nil t)
1297              (replace-match " " t t))
1298            (buffer-substring (point-min) (point-max))))))
1299
1300 (defun gnus-inews-lines ()
1301   "Count the number of lines and return numeric string."
1302   (save-excursion
1303     (save-restriction
1304       (widen)
1305       (goto-char (point-min))
1306       (re-search-forward
1307        (concat "^" (regexp-quote mail-header-separator) "$"))
1308       (forward-line 1)
1309       (int-to-string (count-lines (point) (point-max))))))
1310
1311 \f
1312 ;;;
1313 ;;; Gnus Mail Functions
1314 ;;;
1315
1316 ;;; Mail reply commands of Gnus summary mode
1317
1318 (defun gnus-summary-reply (yank &optional yank-articles)
1319   "Reply mail to news author.
1320 If prefix argument YANK is non-nil, original article is yanked automatically.
1321 Customize the variable gnus-mail-reply-method to use another mailer."
1322   (interactive "P")
1323   ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
1324   ;; Stripping headers should be specified with mail-yank-ignored-headers.
1325   (gnus-set-global-variables)
1326   (if yank-articles (gnus-summary-goto-subject (car yank-articles)))
1327   (gnus-summary-select-article)
1328   (let ((gnus-newsgroup-name gnus-newsgroup-name))
1329     (bury-buffer gnus-article-buffer)
1330     (funcall gnus-mail-reply-method (or yank-articles (not (not yank))))))
1331
1332 (defun gnus-summary-reply-with-original (n)
1333   "Reply mail to news author with original article.
1334 Customize the variable gnus-mail-reply-method to use another mailer."
1335   (interactive "P")
1336   (gnus-summary-reply t (gnus-summary-work-articles n)))
1337
1338 (defun gnus-summary-mail-forward (post)
1339   "Forward the current message to another user.
1340 Customize the variable gnus-mail-forward-method to use another mailer."
1341   (interactive "P")
1342   (gnus-set-global-variables)
1343   (gnus-summary-select-article)
1344   (gnus-copy-article-buffer)
1345   (let ((gnus-newsgroup-name gnus-newsgroup-name))
1346     (if post
1347         (gnus-forward-using-post gnus-article-copy)
1348       (funcall gnus-mail-forward-method gnus-article-copy))))
1349
1350 (defun gnus-summary-post-forward ()
1351   "Forward the current article to a newsgroup."
1352   (interactive)
1353   (gnus-summary-mail-forward t))
1354
1355 (defvar gnus-nastygram-message
1356   "The following article was inappropriately posted to %s.\n"
1357   "Format string to insert in nastygrams.
1358 The current group name will be inserted at \"%s\".")
1359
1360 (defun gnus-summary-mail-nastygram (n)
1361   "Send a nastygram to the author of the current article."
1362   (interactive "P")
1363   (if (or gnus-expert-user
1364           (gnus-y-or-n-p
1365            "Really send a nastygram to the author of the current article? "))
1366       (let ((group gnus-newsgroup-name))
1367         (gnus-summary-reply-with-original n)
1368         (set-buffer gnus-mail-buffer)
1369         (insert (format gnus-nastygram-message group))
1370         (gnus-mail-send-and-exit))))
1371
1372 (defun gnus-summary-mail-other-window ()
1373   "Compose mail in other window.
1374 Customize the variable `gnus-mail-other-window-method' to use another
1375 mailer."
1376   (interactive)
1377   (gnus-set-global-variables)
1378   (let ((gnus-newsgroup-name gnus-newsgroup-name))
1379     (funcall gnus-mail-other-window-method)))
1380
1381 (defun gnus-mail-reply-using-mail (&optional yank to-address)
1382   (save-excursion
1383     (set-buffer gnus-summary-buffer)
1384     (let ((group (gnus-group-real-name gnus-newsgroup-name))
1385           (cur (cons (current-buffer) (cdr gnus-article-current)))
1386           (winconf (current-window-configuration))
1387           from subject date reply-to message-of
1388           references message-id sender follow-to sendto elt)
1389       (set-buffer (get-buffer-create gnus-mail-buffer))
1390       (mail-mode)
1391       (make-local-variable 'gnus-article-reply)
1392       (setq gnus-article-reply cur)
1393       (make-local-variable 'gnus-prev-winconf)
1394       (setq gnus-prev-winconf winconf)
1395       (if (and (buffer-modified-p)
1396                (> (buffer-size) 0)
1397                (not (gnus-y-or-n-p
1398                      "Unsent article being composed; erase it? ")))
1399           ()
1400         (erase-buffer)
1401         (save-excursion
1402           (gnus-copy-article-buffer)
1403           (save-restriction
1404             (set-buffer gnus-article-copy)
1405             (gnus-narrow-to-headers)
1406             (if (and (boundp 'gnus-reply-to-function)
1407                      gnus-reply-to-function)
1408                 (setq follow-to (funcall gnus-reply-to-function group)))
1409             (setq from (mail-fetch-field "from"))
1410             (setq date (or (mail-fetch-field "date")
1411                            (header-date gnus-current-headers)))
1412             (and from
1413                  (let ((stop-pos
1414                         (string-match "  *at \\|  *@ \\| *(\\| *<" from)))
1415                    (setq message-of
1416                          (concat (if stop-pos (substring from 0 stop-pos) from)
1417                                  "'s message of " date))))
1418             (setq sender (mail-fetch-field "sender"))
1419             (setq subject (or (mail-fetch-field "subject")
1420                               "Re: none"))
1421             (or (string-match "^[Rr][Ee]:" subject)
1422                 (setq subject (concat "Re: " subject)))
1423             (setq reply-to (mail-fetch-field "reply-to"))
1424             (setq references (mail-fetch-field "references"))
1425             (setq message-id (mail-fetch-field "message-id"))
1426             (widen))
1427           (setq news-reply-yank-from (or from "(nobody)")))
1428         (setq news-reply-yank-message-id
1429               (or message-id "(unknown Message-ID)"))
1430
1431         ;; Gather the "to" addresses out of the follow-to list and remove
1432         ;; them as we go.
1433         (if (and follow-to (listp follow-to))
1434             (while (setq elt (assoc "To" follow-to))
1435               (setq sendto (concat sendto (and sendto ", ") (cdr elt)))
1436               (setq follow-to (delq elt follow-to))))
1437
1438         (mail-setup (or to-address
1439                         (if (and follow-to (not (stringp follow-to))) sendto
1440                           (or follow-to reply-to from sender "")))
1441                     subject message-of nil gnus-article-copy nil)
1442
1443         (use-local-map (copy-keymap mail-mode-map))
1444         (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
1445
1446         (if (and follow-to (listp follow-to))
1447             (progn
1448               (goto-char (point-min))
1449               (re-search-forward "^To:" nil t)
1450               (beginning-of-line)
1451               (forward-line 1)
1452               (while follow-to
1453                 (insert (car (car follow-to)) ": " (cdr (car follow-to)) "\n")
1454                 (setq follow-to (cdr follow-to)))))
1455         ;; Fold long references line to follow RFC1036.
1456         (mail-position-on-field "References")
1457         (let ((begin (- (point) (length "References: ")))
1458               (fill-column 78)
1459               (fill-prefix "\t"))
1460           (if references (insert references))
1461           (if (and references message-id) (insert " "))
1462           (if message-id (insert message-id))
1463           ;; The region must end with a newline to fill the region
1464           ;; without inserting extra newline.
1465           (fill-region-as-paragraph begin (1+ (point))))
1466         (goto-char (point-min))
1467         (re-search-forward
1468          (concat "^" (regexp-quote mail-header-separator) "$"))
1469         (forward-line 1)
1470         (if (not yank)
1471             (gnus-configure-windows 'reply)
1472           (let ((last (point))
1473                 end)
1474             (if (not (listp yank))
1475                 (progn
1476                   (save-excursion
1477                     (mail-yank-original nil))
1478                   (or mail-yank-hooks mail-citation-hook
1479                       (run-hooks 'news-reply-header-hook)))
1480               (while yank
1481                 (save-window-excursion
1482                   (set-buffer gnus-summary-buffer)
1483                   (gnus-summary-select-article nil nil nil (car yank))
1484                   (gnus-summary-remove-process-mark (car yank)))
1485                 (save-excursion
1486                   (gnus-copy-article-buffer)
1487                   (mail-yank-original nil)
1488                   (setq end (point)))
1489                 (or mail-yank-hooks mail-citation-hook
1490                     (run-hooks 'news-reply-header-hook))
1491                 (goto-char end)
1492                 (setq yank (cdr yank))))
1493             (goto-char last))
1494           (gnus-configure-windows 'reply-yank))
1495         (run-hooks 'gnus-mail-hook)))))
1496
1497 (defun gnus-mail-yank-original ()
1498   (interactive)
1499   (save-excursion
1500    (mail-yank-original nil))
1501   (or mail-yank-hooks mail-citation-hook
1502       (run-hooks 'news-reply-header-hook)))
1503
1504 (defun gnus-mail-send-and-exit ()
1505   (interactive)
1506   (let ((reply gnus-article-reply)
1507         (winconf gnus-prev-winconf))
1508     (mail-send-and-exit nil)
1509     (if (get-buffer gnus-group-buffer)
1510         (progn
1511           (if (gnus-buffer-exists-p (car-safe reply))
1512               (progn
1513                 (set-buffer (car reply))
1514                 (and (cdr reply)
1515                      (gnus-summary-mark-article-as-replied
1516                       (cdr reply)))))
1517           (and winconf (set-window-configuration winconf))))))
1518
1519 (defun gnus-forward-make-subject (buffer)
1520   (save-excursion
1521     (set-buffer buffer)
1522     (concat "[" (if (memq 'mail (assoc (symbol-name
1523                                         (car (gnus-find-method-for-group
1524                                               gnus-newsgroup-name)))
1525                                        gnus-valid-select-methods))
1526                     (gnus-fetch-field "From")
1527                 gnus-newsgroup-name)
1528             "] " (or (gnus-fetch-field "Subject") ""))))
1529
1530 (defun gnus-forward-insert-buffer (buffer)
1531   (let ((beg (goto-char (point-max))))
1532     (insert "------- Start of forwarded message -------\n")
1533     (insert-buffer buffer)
1534     (goto-char (point-max))
1535     (insert "------- End of forwarded message -------\n")
1536     ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
1537     (goto-char beg)
1538     (while (setq beg (next-single-property-change (point) 'invisible))
1539       (goto-char beg)
1540       (delete-region beg (or (next-single-property-change
1541                               (point) 'invisible)
1542                              (point-max))))))
1543
1544 (defun gnus-mail-forward-using-mail (&optional buffer)
1545   "Forward the current message to another user using mail."
1546   ;; This is almost a carbon copy of rmail-forward in rmail.el.
1547   (let* ((forward-buffer (or buffer (current-buffer)))
1548          (winconf (current-window-configuration))
1549          (subject (gnus-forward-make-subject forward-buffer)))
1550     (set-buffer forward-buffer)
1551     (mail nil nil subject)
1552     (use-local-map (copy-keymap (current-local-map)))
1553     (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
1554     (make-local-variable 'gnus-prev-winconf)
1555     (setq gnus-prev-winconf winconf)
1556     (gnus-forward-insert-buffer forward-buffer)
1557     (goto-char (point-min))
1558     (re-search-forward "^To: " nil t)
1559     (gnus-configure-windows 'mail-forward)
1560     ;; You have a chance to arrange the message.
1561     (run-hooks 'gnus-mail-forward-hook)
1562     (run-hooks 'gnus-mail-hook)))
1563
1564 (defun gnus-forward-using-post (&optional buffer)
1565   (let* ((forward-buffer (or buffer (current-buffer)))
1566          (subject (gnus-forward-make-subject forward-buffer)))
1567     (gnus-post-news 'post nil nil nil nil subject)
1568     (save-excursion
1569       (gnus-forward-insert-buffer forward-buffer)
1570       ;; You have a chance to arrange the message.
1571       (run-hooks 'gnus-mail-forward-hook))))
1572
1573 (defun gnus-mail-other-window-using-mail ()
1574   "Compose mail other window using mail."
1575   (let ((winconf (current-window-configuration)))
1576     (mail-other-window nil nil nil nil nil (get-buffer gnus-article-buffer))
1577     (use-local-map (copy-keymap (current-local-map)))
1578     (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
1579     (make-local-variable 'gnus-prev-winconf)
1580     (setq gnus-prev-winconf winconf)
1581     (run-hooks 'gnus-mail-hook)))
1582
1583 (defun gnus-article-mail (yank)
1584   "Send a reply to the address near point.
1585 If YANK is non-nil, include the original article."
1586   (interactive "P")
1587   (let ((address
1588          (buffer-substring
1589           (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
1590           (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
1591     (and address
1592          (progn
1593            (switch-to-buffer gnus-summary-buffer)
1594            (funcall gnus-mail-reply-method yank address)))))
1595
1596 (defun gnus-article-mail-with-original ()
1597   "Send a reply to the address near point and include the original article."
1598   (interactive)
1599   (gnus-article-mail 'yank))
1600
1601 (defun gnus-bug ()
1602   "Send a bug report to the Gnus maintainers."
1603   (interactive)
1604   (let ((winconf (current-window-configuration)))
1605     (delete-other-windows)
1606     (switch-to-buffer "*Gnus Help Bug*")
1607     (erase-buffer)
1608     (insert gnus-bug-message)
1609     (goto-char (point-min))
1610     (pop-to-buffer "*Gnus Bug*")
1611     (erase-buffer)
1612     (mail-mode)
1613     (mail-setup gnus-maintainer nil nil nil nil nil)
1614     (make-local-variable 'gnus-prev-winconf)
1615     (setq gnus-prev-winconf winconf)
1616     (use-local-map (copy-keymap mail-mode-map))
1617     (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
1618     (goto-char (point-min))
1619     (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
1620     (forward-line 1)
1621     (insert (format "%s\n%s\n\n\n\n\n" (gnus-version) (emacs-version)))
1622     (let ((b (point)))
1623       (gnus-debug)
1624       (goto-char (- b 3)))
1625     (message "")))
1626
1627 (defun gnus-debug ()
1628   "Attemps to go through the Gnus source file and report what variables have been changed.
1629 The source file has to be in the Emacs load path."
1630   (interactive)
1631   (let ((files '("gnus.el" "gnus-msg.el" "gnus-score.el"))
1632         file dirs expr olist)
1633     (save-excursion
1634       (set-buffer (get-buffer-create " *gnus bug info*"))
1635       (buffer-disable-undo (current-buffer))
1636       (message "Please wait while we snoop your variables...")
1637       (sit-for 0)
1638       (while files
1639         (erase-buffer)
1640         (setq dirs load-path)
1641         (while dirs
1642           (if (or (not (car dirs))
1643                   (not (stringp (car dirs)))
1644                   (not (file-exists-p
1645                         (setq file (concat (file-name-as-directory
1646                                             (car dirs)) (car files))))))
1647               (setq dirs (cdr dirs))
1648             (setq dirs nil)
1649             (insert-file-contents file)
1650             (goto-char (point-min))
1651             (or (re-search-forward "^;;* Internal variables" nil t)
1652                 (error "Malformed sources in file %s" file))
1653             (narrow-to-region (point-min) (point))
1654             (goto-char (point-min))
1655             (while (setq expr (condition-case ()
1656                                   (read (current-buffer)) (error nil)))
1657               (and (eq (car expr) 'defvar)
1658                    (stringp (nth 3 expr))
1659                    (or (not (boundp (nth 1 expr)))
1660                        (not (equal (eval (nth 2 expr))
1661                                    (symbol-value (nth 1 expr)))))
1662                    (setq olist (cons (nth 1 expr) olist))))))
1663         (setq files (cdr files)))
1664       (kill-buffer (current-buffer)))
1665     (insert "------------------- Environment follows -------------------\n\n")
1666     (while olist
1667       (if (boundp (car olist))
1668           (insert "(setq " (symbol-name (car olist)) " '"
1669                   (prin1-to-string (symbol-value (car olist))) ")\n")
1670         (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1671       (setq olist (cdr olist)))
1672     (insert "\n\n")))
1673
1674 (gnus-ems-redefine)
1675
1676 (provide 'gnus-msg)
1677
1678 ;;; gnus-msg.el ends here