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