;;; Start of editing parts.

;; Editing parts generics.

(defvar message-edit-part-counter 0
  "Counter so all indirect buffers for editing MML parts are different.")

(defvar fp-mml-edit-part-map nil
  "Keymap while editing an MML part in an indirect buffer.")
(unless fp-mml-edit-part-map
  (setq fp-mml-edit-part-map (make-sparse-keymap))
  (define-key fp-mml-edit-part-map "\C-c\C-c" 'fp-mml-stop-edit-part))

(defun fp-mml-find-current-part-extent ()
  ;; Return the current MML part extent, or nil if not within a part.
  ;; The result is a list of three positions: the start of the starting MML tag,
  ;; the end of the starting MML tag and the start of the ending MML tag.
  (save-excursion
    (let ((here (point))
	  start end)
      (when (search-backward "<#part" nil t)
	(setq start (point))
	(when (search-forward ">" nil)
	  (setq end (point))
	  (when (and (search-forward "<#/part>" nil t)
		     (> (point) here))
	    (list start end (match-beginning 0))))))))

(defun fp-mml-find-current-part-type ()
  ;; Return the type/subtype for the current part, or nil if not within a part.
  (let ((extent (fp-mml-find-current-part-extent)))
    (when extent
      (save-excursion
	(goto-char (nth 1 extent))
	(when (re-search-backward "type=\"\\([a-z]+/[a-z]+\\)\"" (car extent) t)
	  (match-string 1))))))

(defun fp-mml-replace-current-part-type (type)
  "Force TYPE as the type/subtype for the current part."
  (interactive (list (mml-minibuffer-read-type nil "text/enriched")))
  (let ((extent (fp-mml-find-current-part-extent)))
    (unless extent
      (error "Not within an MML part"))
    (save-excursion
      (goto-char (nth 1 extent))
      (unless (re-search-backward "type=\"[a-z]+/[a-z]+\"" (car extent) t)
	(error "MML part had no type"))
      (replace-match (concat "type=\"" type "\"") t t))))

(defun fp-mml-edit-current-part ()
  "Setup an indirect buffer to edit the MML part containing point."
  (interactive)
  (let ((part-data (fp-mml-find-current-part-extent)))
    (unless part-data
      (error "Not within an MML part"))
    (let ((start (nth 1 part-data))
	  (end (nth 2 part-data))
	  (type (fp-mml-find-current-part-type)))
      (let ((name (format "*edit part <%d>*" (incf message-edit-part-counter)))
	    (action (intern-soft (concat "fp-mml-" type "-start-edit"))))
	(switch-to-buffer (make-indirect-buffer (current-buffer) name))
	(narrow-to-region start end)
	(when action
	  (apply action nil))
	(use-local-map fp-mml-edit-part-map)
	(message "Type `C-c C-c' once done")))))

(defun fp-mml-stop-edit-part (prefix)
  "Get rid of the current indirect buffer for editing an MML part."
  (interactive "P")
  (let* ((type (save-restriction
		 (widen)
		 (fp-mml-find-current-part-type)))
	 (action (intern-soft (concat "fp-mml-" type "-stop-edit"))))
    (when action
      (apply action nil)))
  (kill-buffer (current-buffer)))

(autoload 'mml-minibuffer-read-type "mml")

(defun fp-mml-new-part-at-point (type)
  "Make a new MIME part and select an indirect buffer for editing its contents.
TYPE is a string giving the MIME type and subtype, separated by a slash.
The editing buffer starts empty and is aimed for the current position."
  (interactive (list (mml-minibuffer-read-type nil "text/plain")))
  (fp-mml-new-part-from-region type (point) (point)))

(defun fp-mml-new-part-from-region (type start end)
  "Make a new MIME part and select an indirect buffer for editing its contents.
TYPE is a string giving the MIME type and subtype, separated by a slash.
The editing buffer is initialized with the text going from START to END."
  (interactive (list (mml-minibuffer-read-type nil "text/plain")
		     (region-beginning)
		     (region-end)))
  (let ((start-extent (save-excursion
			(goto-char start)
			(fp-mml-find-current-part-extent)))
	(end-extent (save-excursion
		      (goto-char end)
		      (fp-mml-find-current-part-extent))))
    (if (or start-extent end-extent)
	(unless (equal start-extent end-extent)
	  (error "Requested part would partially overlap with another"))
      (save-excursion
	(goto-char start)
	(when (re-search-forward "<#/?part" end t)
	  (error "Requested part would overlap with a subpart"))))
    (goto-char end)
    (insert "<#/part>")
    (when end-extent
      (insert (buffer-substring (car end-extent) (nth 1 end-extent))))
    (goto-char start)
    (when start-extent
      (insert "<#/part>"))
    (insert "<#part type=\"" type "\" disposition=inline>")
    (fp-mml-edit-current-part)))

(unless (fboundp 'buffer-indirect-children)
  (defun buffer-indirect-children (main-buffer)
    (and (bufferp main-buffer)
	 (let ((buffers (buffer-list))
	       result)
	   (while buffers
	     (let ((buffer (pop buffers)))
	       (when (eq (buffer-base-buffer buffer) main-buffer)
		 (push buffer result))))
	   result))))

(defun fp-mml-stop-edit-all-parts ()
  (let ((buffers (buffer-indirect-children (current-buffer))))
    (save-excursion
      (while buffers
	(set-buffer (pop buffers))
	(fp-mml-stop-edit-part)))))
(add-hook 'message-send-hook 'fp-mml-stop-edit-all-parts)

;; Editing text/enriched parts.

(defun fp-mml-new-text/enriched-at-point ()
  "Make a new text/enriched part and setup a buffer for editing its contents.
The editing buffer starts empty and is aimed for the current position."
  (interactive)
  (fp-mml-new-part-from-region "text/enriched" (point) (point)))

(defun fp-mml-new-text/enriched-from-region (start end)
  "Make a new text/enriched part and setup a buffer for editing its contents.
The editing buffer is initialized with the text going from START to END."
  (interactive "r")
  (fp-mml-new-part-from-region "text/enriched" start end))

(defun fp-mml-text/enriched-start-edit ()
  (let ((contents (buffer-substring-no-properties (point-min) (point-max))))
    (delete-region (point-min) (point-max))
    (insert contents))
  (format-decode-region (point-min) (point-max) 'text/enriched)
  (enriched-mode 1))

(defun fp-mml-text/enriched-stop-edit ()
  (format-encode-region (point-min) (point-max) 'text/enriched)
  (goto-char (point-min))
  (forward-line 3)
  (delete-region (point-min) (point)))

;; Editing parts keymap.

(eval-after-load "mml"
  '(progn
     ;; FIXME: the \M-m is required?  "mml.el" does not use it, how comes?
     (define-key mml-mode-map "\M-mP" 'fp-mml-new-text/enriched-at-point)
     (define-key mml-mode-map "\M-mR" 'fp-mml-new-text/enriched-from-region)
     (define-key mml-mode-map "\M-me" 'fp-mml-edit-current-part)
     (define-key mml-mode-map "\M-mp" 'fp-mml-new-part-at-point)
     (define-key mml-mode-map "\M-mr" 'fp-mml-new-part-from-region)
     (define-key mml-mode-map "\M-mt" 'fp-mml-replace-current-part-type)
     (define-key mml-mode-map "\M-mx" 'mml-attach-external)))

;;; End of editing parts.