; http://scrlab.g-7.ne.jp/diary/200308.php#D10
(provide "my-buffer-bar-context-menu")
(defun replace-buffer-bar-context-menu ()
	(flet ((buf  () *buffer-bar-context-menu-buffer*)
		   (bn   () (buffer-name *buffer-bar-context-menu-buffer*))
		   (bfn  () (get-buffer-file-name *buffer-bar-context-menu-buffer*))
		   (cbfn () (get-buffer-file-name))
		   (sb   () (set-buffer (buffer-name *buffer-bar-context-menu-buffer*)))
		   (check-init (&optional prog)
			   (unless (and (get-buffer-file-name *buffer-bar-context-menu-buffer*)
							(if prog (file-exist-p prog) t))
				   :disable)))
		(setq *buffer-bar-context-menu*
			  (define-popup-menu
				  ;==============================
				  (:item nil "バイトコンパイル(&C)"
				   #'(lambda () (interactive) (sb) (byte-compile-file (cbfn)))
				   #'(lambda () (check-init)))
				  ;==============================
				  :sep
				  (:item nil "すべて閉じる(&*)"
				   #'(lambda () (interactive)
						 (and (yes-or-no-p "バッファを全部閉じますよ。")
							  (kill-all-buffers))))
				  (:item nil "他のタブを閉じる"
				   #'(lambda ()
						 (interactive)
						 (mybb-close-other-buffers)))
				  (:item nil "左タブを閉じる"
				   #'(lambda ()
						 (interactive)
						 (mybb-close-left-buffers)))
				  (:item nil "右タブを閉じる"
				   #'(lambda ()
						 (interactive)
						 (mybb-close-right-buffers)))
				  (:item nil "閉じる(&C)"
				   #'(lambda ()
						 (interactive)
						 (kill-buffer *buffer-bar-context-menu-buffer*)))
				  ))))

(add-hook '*init-app-menus-hook* #'replace-buffer-bar-context-menu)

;; これ以外を閉じる
(defun mybb-close-other-buffers ()
	(interactive)
	(let ((buf0 *buffer-bar-context-menu-buffer*))
		(dolist (buffer (buffer-list))
			(unless (or (eq buffer buf0)
						(string= (buffer-name buffer) "*scratch*"))
				(kill-buffer buffer)))))

;; これより右を閉じる(version 0.2.2.233 以降)
(defun mybb-close-right-buffers ()
	(interactive)
	(let ((buffer *buffer-bar-context-menu-buffer*)
		  (buff (get-next-buffer (get-next-buffer :bottom nil t) nil t)))
		(let ((buf (get-next-buffer buffer nil t)) buf1)
			(while (not (equal buf buff))
				(setq buf1 buf)
				(setq buf (get-next-buffer buf nil t))
				(unless (string= (buffer-name buf1) "*scratch*")
					(kill-buffer buf1))))
		(switch-to-buffer buffer)))

;; これより左を閉じる(version 0.2.2.233 以降)
(defun mybb-close-left-buffers ()
	(interactive)
	(let ((buffer *buffer-bar-context-menu-buffer*)
		  (buff (get-next-buffer (get-next-buffer :top nil t) t t)))
		(let ((buf (get-next-buffer buffer t t)) buf1)
			(while (not (equal buf buff))
				(setq buf1 buf)
				(setq buf (get-next-buffer buf t t))
				(unless (string= (buffer-name buf1) "*scratch*")
					(kill-buffer buf1))))
		(switch-to-buffer buffer)))