Function: gnus-summary-move-article

gnus-summary-move-article is an interactive and byte-compiled function defined in gnus-sum.el.gz.

Signature

(gnus-summary-move-article &optional N TO-NEWSGROUP SELECT-METHOD ACTION)

Documentation

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.

When called interactively with TO-NEWSGROUP being nil, the value of the variable gnus-move-split-methods is used for finding a default for the target newsgroup.

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.

ACTION can be either move (the default), crosspost or copy.

Key Bindings

Source Code

;; Defined in /usr/src/emacs/lisp/gnus/gnus-sum.el.gz
(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.

When called interactively with TO-NEWSGROUP being nil, the value of
the variable `gnus-move-split-methods' is used for finding a default
for the target newsgroup.

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.

ACTION can be either `move' (the default), `crosspost' or `copy'."
  (interactive "P" gnus-summary-mode)
  (unless action
    (setq action 'move))
  ;; 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)))
	 (user-error "The current group does not support article moving"))
	((and (eq action 'crosspost)
	      (not (gnus-check-backend-function
		    'request-replace-article gnus-newsgroup-name)))
	 (user-error "The current group does not support article editing")))
  (let ((articles (gnus-summary-work-articles n))
	(prefix (if (gnus-check-backend-function
		     'request-move-article gnus-newsgroup-name)
		    (funcall gnus-move-group-prefix-function
			     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
	articles-to-update-marks)
    (unless (assq action names)
      (error "Unknown action %s" action))
    ;; Read the newsgroup name.
    (unless (or to-newsgroup select-method)
      (if (and gnus-move-split-methods
	       (not
		(and (memq gnus-current-article articles)
		     (gnus-buffer-live-p gnus-original-article-buffer))))
	  ;; When `gnus-move-split-methods' is non-nil, we have to
	  ;; select an article to give `gnus-read-move-group-name' an
	  ;; opportunity to suggest an appropriate default.  However,
	  ;; we needn't render or mark the article.
	  (let ((gnus-display-mime-function nil)
		(gnus-article-prepare-hook nil)
		(gnus-mark-article-hook nil))
	    (gnus-summary-select-article nil nil nil (car articles))))
      (setq to-newsgroup (gnus-read-move-group-name
			  (cadr (assq action names))
			  (symbol-value
			   (intern (format "gnus-current-%s-group" action)))
			  articles prefix)
	    to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))
      (set (intern (format "gnus-current-%s-group" action)) to-newsgroup))
    (unless to-method
      (setq to-method (or select-method
			  (gnus-server-to-method
			   (gnus-group-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)
    ;; This `while' is not equivalent to a `dolist' (bug#33653#134).
    (while articles
      (setq article (pop articles))
      ;; Set any marks that may have changed in the summary buffer.
      (when gnus-preserve-marks
	(gnus-summary-push-marks-to-backend article))
      (setq
       art-group
       (cond
	;; Move the article.
	((eq action 'move)
         (when gnus-suppress-duplicates
           ;; Remove this article from future suppression.
           (gnus-dup-unsuppress-article article))
	 (let* ((from-method (gnus-find-method-for-group
			      gnus-newsgroup-name))
		(to-method (or select-method
			       (gnus-find-method-for-group to-newsgroup)))
		(move-is-internal (gnus-server-equal from-method to-method)))
	   (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
	    (and move-is-internal
		 to-newsgroup		; Not respooling
					; Is this move internal?
		 (gnus-group-real-name to-newsgroup)))))
	;; Copy the article.
	((eq action 'copy)
	 (with-current-buffer copy-buf
	   (when (gnus-request-article-this-buffer article
						   gnus-newsgroup-name)
	     (save-restriction
	       (nnheader-narrow-to-headers)
	       (dolist (hdr gnus-copy-article-ignored-headers)
		 (message-remove-header hdr t)))
	     (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)
				  ":" (number-to-string article)))
	   (unless xref
	     (setq xref (list (system-name))))
	   (setq new-xref
		 (concat
		  (mapconcat #'identity
			     (delete "Xref:" (delete new-xref xref))
			     " ")
		  " " new-xref))
	   (with-current-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)
				 t)))
	       (setq new-xref (concat new-xref " " (car art-group)
				      ":"
				      (number-to-string (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) t)
	       art-group))))))
      (cond
       ((not art-group)
	(gnus-message 1 "Couldn't %s article %s: %s"
		      (cadr (assq action names)) article
		      (nnheader-get-report (car to-method))))
       ((eq art-group 'junk)
	(when (eq action 'move)
	  (gnus-summary-mark-article article gnus-canceled-mark)
	  (gnus-message 4 "Deleted article %s" article)
	  ;; run the delete hook
	  (run-hook-with-args 'gnus-summary-article-delete-hook
			      action
			      (gnus-data-header
			       (gnus-data-find-in article (gnus-data-list nil)))
			      gnus-newsgroup-name nil
			      select-method)))
       (t
	(let* ((pto-group (gnus-group-prefixed-name
			   (car art-group) to-method))
	       (info (gnus-get-info pto-group))
	       (to-group (gnus-info-group info))
	       to-marks)
	  ;; 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))

	    (when (and (not (memq article gnus-newsgroup-unreads))
		       (cdr art-group))
	      (push 'read to-marks)
	      (setf (gnus-info-read info)
		    (gnus-add-to-range (gnus-info-read info)
				       (list (cdr art-group)))))

	    ;; See whether the article is to be put in the cache.
	    (let* ((expirable (gnus-group-auto-expirable-p to-group))
		   (marks (if expirable
			      gnus-article-mark-lists
			    (delete '(expirable . expire)
				    (copy-sequence
				     gnus-article-mark-lists))))
		   (to-article (cdr art-group)))

	      ;; Enter the article into the cache in the new group,
	      ;; if that is required.
	      (when (and to-article
			 gnus-use-cache)
		(gnus-cache-possibly-enter-article
		 to-group to-article
		 (memq article gnus-newsgroup-marked)
		 (memq article gnus-newsgroup-dormant)
		 (memq article gnus-newsgroup-unreads)))

	      (when (and gnus-preserve-marks
			 to-article)
		;; Copy any marks over to the new group.
		(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)
		  ;; Increase the active status of this group.
		  (setcdr (gnus-active to-group) to-article)
		  (setcdr gnus-newsgroup-active to-article))

		(while marks
		  (when (eq (gnus-article-mark-to-type (cdar marks)) 'list)
		    (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,
		      ;; then we have to add the mark to the list.
		      (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)))))))
		      ;; Copy the marks to other group.
		      (gnus-add-marked-articles
		       to-group (cdar marks) (list to-article) info)))
		  (setq marks (cdr marks)))

		(when (and expirable
			   gnus-mark-copied-or-moved-articles-as-expirable
			   (not (memq 'expire to-marks)))
		  ;; Mark this article as expirable.
		  (push 'expire to-marks)
		  (when (equal to-group gnus-newsgroup-name)
		    (push to-article gnus-newsgroup-expirable))
		  ;; Copy the expirable mark to other group.
		  (gnus-add-marked-articles
		   to-group 'expire (list to-article) info))

		(when (and to-marks
			   (gnus-method-option-p
			    (gnus-find-method-for-group to-group)
			    'server-marks))
		  (gnus-request-set-mark
		   to-group (list (list (list to-article) 'add to-marks)))))

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

	  ;; Update the Xref header in this article to point to
	  ;; the new crossposted article we have just created.
	  (when (eq action 'crosspost)
	    (with-current-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) t)))

	  ;; run the move/copy/crosspost/respool hook
	  (run-hook-with-args 'gnus-summary-article-move-hook
			      action
			      (gnus-data-header (gnus-data-find article))
			      gnus-newsgroup-name
			      to-newsgroup
			      select-method))

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

	(when (eq action 'move)
	  (save-excursion
	    (gnus-summary-goto-subject article)
	    (gnus-summary-mark-article article gnus-canceled-mark)))))
      (push article articles-to-update-marks))

    (save-excursion
      (apply #'gnus-summary-remove-process-mark articles-to-update-marks))
    ;; Re-activate all groups that have been moved to.
    (with-current-buffer gnus-group-buffer
      (let ((gnus-group-marked to-groups))
	(gnus-group-get-new-news-this-group nil t)))

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