Gnus-summary-move-article

1999-06-11  Kai Grossjohann 

	* gnus-sum.el (gnus-summary-move-article): Send flags to backend.

(defun gnus-summary-move-article (&optional n to-newsgroup
					    select-method action)
  "Move the current article to a different newsgroup.
If N is a positive number, move the N next articles.
If N is a negative number, move the N previous articles.
If N is nil and any articles have been marked with the process mark,
move those articles instead.
If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but
re-spool using this method.

For this function to work, both the current newsgroup and the
newsgroup that you want to move to have to support the `request-move'
and `request-accept' functions."
  (interactive "P")
  (unless action
    (setq action 'move))
  ;; Disable marking as read.
  (let (gnus-mark-article-hook)
    (save-window-excursion
      (gnus-summary-select-article)))
  ;; Check whether the source group supports the required functions.
  (cond ((and (eq action 'move)
	      (not (gnus-check-backend-function
		    'request-move-article gnus-newsgroup-name)))
	 (error "The current group does not support article moving"))
	((and (eq action 'crosspost)
	      (not (gnus-check-backend-function
		    'request-replace-article gnus-newsgroup-name)))
	 (error "The current group does not support article editing")))
  (let ((articles (gnus-summary-work-articles n))
	(prefix (gnus-group-real-prefix gnus-newsgroup-name))
	(names '((move "Move" "Moving")
		 (copy "Copy" "Copying")
		 (crosspost "Crosspost" "Crossposting")))
	(copy-buf (save-excursion
		    (nnheader-set-temp-buffer " *copy article*")))
	art-group to-method new-xref article to-groups)
    (unless (assq action names)
      (error "Unknown action %s" action))
    ;; Read the newsgroup name.
    (when (and (not to-newsgroup)
	       (not select-method))
      (setq to-newsgroup
	    (gnus-read-move-group-name
	     (cadr (assq action names))
	     (symbol-value (intern (format "gnus-current-%s-group" action)))
	     articles prefix))
      (set (intern (format "gnus-current-%s-group" action)) to-newsgroup))
    (setq to-method (or select-method
			(gnus-group-name-to-method to-newsgroup)))
    ;; Check the method we are to move this article to...
    (unless (gnus-check-backend-function
	     'request-accept-article (car to-method))
      (error "%s does not support article copying" (car to-method)))
    (unless (gnus-check-server to-method)
      (error "Can't open server %s" (car to-method)))
    (gnus-message 6 "%s to %s: %s..."
		  (caddr (assq action names))
		  (or (car select-method) to-newsgroup) articles)
    (while articles
      (setq article (pop articles))
      (setq
       art-group
       (cond
	;; Move the article.
	((eq action 'move)
	 ;; Remove this article from future suppression.
	 (gnus-dup-unsuppress-article article)
	 (gnus-request-move-article
	  article			; Article to move
	  gnus-newsgroup-name		; From newsgroup
	  (nth 1 (gnus-find-method-for-group
		  gnus-newsgroup-name)) ; Server
	  (list 'gnus-request-accept-article
		to-newsgroup (list 'quote select-method)
		(not articles) t)		; Accept form
	  (not articles)))		; Only save nov last time
	;; Copy the article.
	((eq action 'copy)
	 (save-excursion
	   (set-buffer copy-buf)
	   (when (gnus-request-article-this-buffer article gnus-newsgroup-name)
	     (gnus-request-accept-article
	      to-newsgroup select-method (not articles) t))))
	;; Crosspost the article.
	((eq action 'crosspost)
	 (let ((xref (message-tokenize-header
		      (mail-header-xref (gnus-summary-article-header article))
		      " ")))
	   (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name)
				  ":" article))
	   (unless xref
	     (setq xref (list (system-name))))
	   (setq new-xref
		 (concat
		  (mapconcat 'identity
			     (delete "Xref:" (delete new-xref xref))
			     " ")
		  " " new-xref))
	   (save-excursion
	     (set-buffer copy-buf)
	     ;; First put the article in the destination group.
	     (gnus-request-article-this-buffer article gnus-newsgroup-name)
	     (when (consp (setq art-group
				(gnus-request-accept-article
				 to-newsgroup select-method (not articles))))
	       (setq new-xref (concat new-xref " " (car art-group)
				      ":" (cdr art-group)))
	       ;; Now we have the new Xrefs header, so we insert
	       ;; it and replace the new article.
	       (nnheader-replace-header "Xref" new-xref)
	       (gnus-request-replace-article
		(cdr art-group) to-newsgroup (current-buffer))
	       art-group))))))
      (cond
       ((not art-group)
	(gnus-message 1 "Couldn't %s article %s"
		      (cadr (assq action names)) article))
       ((and (eq art-group 'junk)
	     (eq action 'move))
	(gnus-summary-mark-article article gnus-canceled-mark)
	(gnus-message 4 "Deleted article %s" article))
       (t
	(let* ((pto-group (gnus-group-prefixed-name
			   (car art-group) to-method))
	       (entry
		(gnus-gethash pto-group gnus-newsrc-hashtb))
	       (info (nth 2 entry))
	       (to-group (gnus-info-group info)))
	  ;; Update the group that has been moved to.
	  (when (and info
		     (memq action '(move copy)))
	    (unless (member to-group to-groups)
	      (push to-group to-groups))

	    (unless (memq article gnus-newsgroup-unreads)
	      (gnus-info-set-read
	       info (gnus-add-to-range (gnus-info-read info)
				       (list (cdr art-group)))))

	    ;; Copy any marks over to the new group.
	    (let ((marks gnus-article-mark-lists)
		  (to-article (cdr art-group))
		  (to-marks nil))

	      (unless (memq article gnus-newsgroup-unreads)
		(push 'read to-marks))

	      ;; See whether the article is to be put in the cache.
	      (when gnus-use-cache
		(gnus-cache-possibly-enter-article
		 to-group to-article
		 (let ((header (copy-sequence
				(gnus-summary-article-header article))))
		   (mail-header-set-number header to-article)
		   header)
		 (memq article gnus-newsgroup-marked)
		 (memq article gnus-newsgroup-dormant)
		 (memq article gnus-newsgroup-unreads)))

	      (when (and (equal to-group gnus-newsgroup-name)
			 (not (memq article gnus-newsgroup-unreads)))
		;; Mark this article as read in this group.
		(push (cons to-article gnus-read-mark) gnus-newsgroup-reads)
		(setcdr (gnus-active to-group) to-article)
		(setcdr gnus-newsgroup-active to-article))

	      (while marks
		(when (memq article (symbol-value
				     (intern (format "gnus-newsgroup-%s"
						     (caar marks)))))
		  (push (cdar marks) to-marks)
		  ;; If the other group is the same as this group,
		  ;; Copy the marks to other group.
		  (when (equal to-group gnus-newsgroup-name)
		    (set (intern (format "gnus-newsgroup-%s" (caar marks)))
			 (cons to-article
			       (symbol-value
				(intern (format "gnus-newsgroup-%s"
						(caar marks)))))))
		  (gnus-add-marked-articles
		   to-group (cdar marks) (list to-article) info))
		(setq marks (cdr marks)))

	      (gnus-request-set-mark to-group (list (list (list to-article)
							  'set
							  to-marks)))

	      (gnus-dribble-enter
	       (concat "(gnus-group-set-info '"
		       (gnus-prin1-to-string (gnus-get-info to-group))
		       ")"))))

	  ;; Update the Xref header in this article to point to
	  ;; the new crossposted article we have just created.
	  (when (eq action 'crosspost)
	    (save-excursion
	      (set-buffer copy-buf)
	      (gnus-request-article-this-buffer article gnus-newsgroup-name)
	      (nnheader-replace-header "Xref" new-xref)
	      (gnus-request-replace-article
	       article gnus-newsgroup-name (current-buffer)))))

	;;;!!!Why is this necessary?
	(set-buffer gnus-summary-buffer)

	(gnus-summary-goto-subject article)
	(when (eq action 'move)
	  (gnus-summary-mark-article article gnus-canceled-mark))))
      (gnus-summary-remove-process-mark article))
    ;; Re-activate all groups that have been moved to.
    (while to-groups
      (save-excursion
	(set-buffer gnus-group-buffer)
	(when (gnus-group-goto-group (car to-groups) t)
	  (gnus-group-get-new-news-this-group 1 t))
	(pop to-groups)))

    (gnus-kill-buffer copy-buf)
    (gnus-summary-position-point)
    (gnus-set-mode-line 'summary)))