;;; liece-xemacs.el --- XEmacs specific routines.
;; Copyright (C) 1998-2000 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1998-09-28
;; Revised: 1999-08-22
;; Keywords: emulation

;; This file is part of Liece.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(eval-when-compile
  (require 'liece-inlines)
  (require 'liece-misc)
  (require 'liece-commands))

(autoload 'liece-command-dcc-send "liece-dcc")
(defvar liece-nick-popup-menu)

(defgroup liece-toolbar nil
  "Toolbar of your XEmacs"
  :tag "Toolbar"
  :group 'liece)

(defgroup liece-toolbar-icons nil
  "Toolbar Icons of your XEmacs"
  :tag "Toolbar Icons"
  :prefix "liece-toolbar-"
  :group 'liece)

(defmacro liece-xemacs-icon-path (file)
  "Search icon FILE and return absolete path of the file."
  `(or (and liece-icon-directory
	    (expand-file-name ,file liece-icon-directory))
       (let ((path (liece-find-path ,file "icons")))
	 (when path
	   (setq liece-icon-directory
		 (file-name-directory path)))
	 path)))

(define-widget 'liece-toolbar-icon 'list
  "Edit toolbar spec entries"
  :match (lambda (widget value)
	   (valid-plist-p value))
  :convert-widget 'liece-toolbar-icon-convert)

(eval-and-compile
  (defconst liece-toolbar-icon-states
    '(:up :down :disabled :cap-up :cap-down :cap-disabled)
    "toolbar event states")

  (defun liece-toolbar-icon-convert-1 (state)
    (list 'group :inline t :format "%t: %v"
	  :tag (capitalize (substring (symbol-name state) 1))
	  (list 'const :format "" :value state
		(list 'radio '(const :tag "none" nil) 'file)))))

(defun liece-toolbar-icon-convert (widget)
  "Widget converter of the WIDGET `liece-toolbar-icon'."
  (apply #'widget-put widget :args
	 (eval-when-compile
	   (mapcar #'liece-toolbar-icon-convert-1
		   liece-toolbar-icon-states)))
  widget)

(defcustom liece-use-toolbar (if (featurep 'toolbar)
				 'default-toolbar
			       nil)
  "*If nil, do not use a toolbar.
If it is non-nil, it must be a toolbar.  The five valid values are
`default-toolbar', `top-toolbar', `bottom-toolbar',
`right-toolbar', and `left-toolbar'."
  :type '(choice (const default-toolbar)
                 (const top-toolbar) (const bottom-toolbar)
                 (const left-toolbar) (const right-toolbar)
                 (const :tag "no toolbar" nil))
  :group 'liece-toolbar)

(defcustom liece-toolbar-back-icon '(:up "back.xpm")
  "Back button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-toolbar-forward-icon '(:up "forward.xpm")
  "Forward button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-toolbar-reload-icon '(:up "reload.xpm")
  "Reload button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-toolbar-home-icon '(:up "home.xpm")
  "Home button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-toolbar-search-icon '(:up "search.xpm")
  "Search button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-toolbar-location-icon '(:up "location.xpm")
  "Location button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-toolbar-stop-icon '(:up "stop.xpm")
  "Stop button."
  :type 'liece-toolbar-icon
  :group 'liece-toolbar-icons)

(defcustom liece-xemacs-unread-icon "balloon.xpm"
  "Unread icon."
  :type 'file
  :group 'liece-look)

;;; @ internal variables
;;; 
(defvar liece-glyph-cache nil)
(defvar liece-toolbar-position (if (featurep 'toolbar)
				   (default-toolbar-position)
				 nil))

(defvar liece-toolbar-back-glyph nil)
(defvar liece-toolbar-forward-glyph nil)
(defvar liece-toolbar-reload-glyph nil)
(defvar liece-toolbar-home-glyph nil)
(defvar liece-toolbar-search-glyph nil)
(defvar liece-toolbar-location-glyph nil)
(defvar liece-toolbar-stop-glyph nil)

(defvar liece-toolbar-spec-list
  '([liece-toolbar-back-glyph
     liece-command-previous-channel t "Previous Channel"]
    [liece-toolbar-forward-glyph
     liece-command-next-channel t "Next Channel"]
    [liece-toolbar-reload-glyph
     liece-command-list t "List Channel"]
    [liece-toolbar-home-glyph
     liece-switch-to-channel-no-1 t "Go Home Channel"]
    [liece-toolbar-search-glyph
     liece-command-finger t "Finger"]
    [liece-toolbar-location-glyph
     liece-command-join t "Join Channel"]
    [liece-toolbar-stop-glyph
     liece-command-quit t "Quit IRC"]))

;;; @ toolbar icons
;;; 
(defun liece-toolbar-icon-plist-get (spec prop)
  "Return absolete path of icon file which SPEC has PROP."
  (let ((icon (plist-get spec prop)))
    (if icon (liece-locate-icon-file icon))))

(defun liece-toolbar-map-button-list (plist)
  "Make toolbar icon list based on status PLIST."
  (apply #'toolbar-make-button-list
	 (mapcar
	  (lambda (prop)
	    (liece-toolbar-icon-plist-get plist prop))
	  liece-toolbar-icon-states)))

(defun liece-xemacs-setup-toolbar (bar &optional force)
  "Prepare icons of toolbar BAR.
If optional argument FORCE is non-nil, always update toolbar."
  (let (icon plist)
    (set-default-toolbar-position liece-toolbar-position)
    (dolist (spec bar)
      (setq icon (aref spec 0)
	    plist (symbol-value
		   (intern (concat
			    (substring (prin1-to-string icon) -5 0)
			    "icon"))))
      (when (or force
		(not (symbol-value icon)))
	(set icon (liece-toolbar-map-button-list plist))))
    (run-hooks 'liece-xemacs-setup-toolbar-hook)))

;;; @ modeline decoration
;;; 
(defun liece-xemacs-hide-modeline ()
  "Remove modeline from current window."
  (set-specifier has-modeline-p nil (current-buffer)))

(when (featurep 'scrollbar)
  (defun liece-xemacs-hide-scrollbars ()
    (static-cond
     ((boundp 'horizontal-scrollbar-visible-p)
      (set-specifier horizontal-scrollbar-visible-p nil (current-buffer)))
     ((boundp 'scrollbar-height)
      (set-specifier scrollbar-height 0 (current-buffer)))))
  (add-hook 'liece-nick-mode-hook 'liece-xemacs-hide-scrollbars)
  (add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-scrollbars))

(add-hook 'liece-nick-mode-hook 'liece-xemacs-hide-modeline)
(add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-modeline)

(defvar liece-xemacs-modeline-left-extent
  (let ((ext (copy-extent modeline-buffer-id-left-extent)))
    ext))

(defvar liece-xemacs-modeline-right-extent
  (let ((ext (copy-extent modeline-buffer-id-right-extent)))
    ext))

(add-hook 'liece-command-mode-hook 'liece-setup-toolbar)

(defun liece-setup-toolbar ()
  "Prepare toolbar if wanted."
  (when liece-use-toolbar
    (liece-xemacs-setup-toolbar liece-toolbar-spec-list)
    (set-specifier (symbol-value liece-use-toolbar) liece-toolbar-spec-list
		   (current-buffer))))

(defun liece-xemacs-modeline-glyph ()
  "Return a glyph of modeline pointer."
  (let ((glyph
	 (let (file)
	   (make-glyph
	    (nconc
	     (if (and (featurep 'xpm)
		      (setq file (liece-locate-icon-file "liece-pointer.xpm")))
		 (list (vector 'xpm :file file)))
	     (if (setq file (liece-locate-icon-file "liece-pointer.xbm"))
		 (list (vector 'xbm :file file)))
	     '([string :data "Liece:"]))))))
    (set-glyph-face glyph 'modeline-buffer-id)
    glyph))

(defun liece-xemacs-mode-line-buffer-identification (line)
  "Decorate 1st	element	of `mode-line-buffer-identification' LINE.
Modify whole identification by side effect."
  (let ((id (car line)) chop)
    (if (and (stringp id) (string-match "^Liece:" id))
	(progn
	  (setq chop (match-end 0))
	  (nconc
	   (list
	    (let ((glyph (liece-xemacs-modeline-glyph)))
	      (if glyph
		  (cons liece-xemacs-modeline-left-extent glyph)
		(cons liece-xemacs-modeline-left-extent
		      (substring id 0 chop))))
	    (cons liece-xemacs-modeline-right-extent
		  (substring id chop)))
	   (cdr line)))
      line)))

(defun liece-xemacs-suppress-modeline-format ()
  "Remove unnecessary information from `modeline-format'."
  (setq modeline-format
	(remrassq 'modeline-modified
		  (delq 'modeline-multibyte-status
			(copy-sequence mode-line-format)))))

;;; @ menus
;;; 
(defun liece-xemacs-nick-popup-menu (widget &optional event)
  "Trigger function for popup menu."
  (let ((pos (widget-event-point event)))
    (when pos
      (goto-char pos)
      (if (eq major-mode 'liece-nick-mode)
	  (liece-nick-update-region))
      (let ((menu (cdr liece-nick-popup-menu)))
	(setq menu (nconc (list "IRCHAT" ; title: not displayed
				"     IRC commands"
				"--:shadowDoubleEtchedOut")
			  (mapcar (lambda (spec)
				    (if (stringp spec)
					"--:shadowEtchedOut"
				      spec))
				  menu)))
	(let (popup-menu-titles)
	  (popup-menu menu))))))

(fset 'liece-nick-popup-menu 'liece-xemacs-nick-popup-menu)

;;; @ nick buffer decoration
;;; 
(defun liece-xemacs-create-nick-glyph (file &optional string)
  "Return a glyph of nick indicator from FILE or STRING."
  (or
   (cdr-safe (assoc file liece-glyph-cache))
   (let ((glyph
	  (make-glyph
	   (nconc
	    (if (and (featurep 'xpm)
		     (setq file (liece-locate-icon-file file)))
		(list (vector 'xpm :file file)))
	    (if string
		(list (vector 'string :data string)))))))
     (push (cons file glyph) liece-glyph-cache)
     (set-glyph-face glyph 'default)
     glyph)))

(defun liece-xemacs-glyph-nick-region (start end)
  "Decorate nick buffer between START and END."
  (save-excursion
    (setq start (progn (goto-char start)(beginning-of-line)(point))
	  end (progn (goto-char end)(beginning-of-line 2)(point)))
    (save-restriction
      (narrow-to-region start end)
      (let ((buffer-read-only nil)
	    (inhibit-read-only t)
	    (case-fold-search nil)
	    mark file glyph ext ant)
	(map-extents
	 (lambda (e void)
	   (when (or
		  (extent-property
		   e 'liece-xemacs-glyph-nick-extent)
		  (extent-property
		   e 'liece-xemacs-glyph-nick-annotation))
	     (delete-extent e)))
	 (current-buffer) start end)
	(dolist (entry liece-nick-image-alist)
	  (setq mark (car entry)
		file (cdr entry)
		glyph (liece-xemacs-create-nick-glyph
		       file (char-to-string mark)))
	  (when glyph
	    (goto-char start)
	    (while (not (eobp))
	      (when (eq (char-after) mark)
		(mapcar 'delete-annotation
			(annotations-at (1+ (point))))
		(setq ext (make-extent (point) (1+ (point)))
		      ant (make-annotation glyph (1+ (point)) 'text))
		(set-extent-property ext 'end-open t)
		(set-extent-property ext 'start-open t)
		(set-extent-property ext 'invisible t)
		(set-extent-property ext 'intangible t)
		(set-extent-property
		 ant 'liece-xemacs-glyph-nick-extent ext)
		(set-extent-property
		 ext 'liece-xemacs-glyph-nick-annotation ant))
	      (beginning-of-line 2))))))))

(defun liece-xemacs-set-drop-functions (start end)
  "Initialize drag and drop in DCC between START and END.
This function needs window system independent drag and drop
support (21.0 b39 or later)"
  (interactive "r")
  (liece-xemacs-set-drop-functions-buffer
   (current-buffer) start end)
  (goto-char end))

(defun liece-xemacs-set-drop-functions-buffer (&optional buffer start end)
  "Initialize BUFFER drag and drop DCC settings between START and END.
This function needs window system independent drag and drop
support (21.0 b39 or later)"
  (interactive)
  (when (and (featurep 'x) (featurep 'dragdrop))
    (save-excursion
      (when buffer
	(set-buffer buffer))
      (setq start (or start (point-min))
	    end (or end (point-max)))
      (goto-char start)
      (setq start (line-beginning-position))
      (goto-char end)
      (setq end (line-beginning-position))
      (goto-char end)
      (when (not (eobp))
	(beginning-of-line 2)
	(setq end (point)))
      (save-restriction
	(narrow-to-region start end)
	(let (buffer-read-only case-fold-search)
	  (map-extents
	   (function
	    (lambda (e void)
	      (when (extent-property e 'liece-xemacs-drop-extent)
		(delete-extent e))))
	   buffer start end)
	  (goto-char start)
	  (let (st nd nick func)
	    (while (not (eobp))
	      (forward-char)
	      (setq st (point)
		    nd (line-end-position)
		    nick (buffer-substring st nd))
	      (mapcar 'delete-annotation (annotations-at nd))
	      (setq func (intern (concat "liece-xemacs-drop-function-" nick)))
	      (fset func
		    (list 'lambda (list 'object)
			  (list 'liece-xemacs-drop-function 'object nick)))
	      (let ((ext (make-extent st nd)))
		(set-extent-property ext 'liece-xemacs-drop-extent t)
		(set-extent-property ext 'dragdrop-drop-functions (list func)))
	      (beginning-of-line 2))))))))

(defun liece-xemacs-drop-function (object nick)
  "Drag and drop handler.
Always two arguments are passed, OBJECT and NICK."
  (if (and (eq (car object) 'dragdrop_URL)
	   (stringp (cdr object))
	   (string-match "^[^:]*:\\(.*\\)" (cdr object)))
      (let ((filename (match-string 1 (cdr object))))
	(liece-command-dcc-send filename nick))))

(defadvice easy-menu-add-item
  (around liece-fix-menu-path-switch-buffer activate)
  "Advice for XEmacs 20.4 or earlier."
  (save-excursion
    (set-buffer liece-command-buffer)
    (add-menu-button
     (cons (car (ad-get-arg 0)) (ad-get-arg 1))
     (ad-get-arg 2) (ad-get-arg 3))))

(eval-and-compile
  (setq liece-x-face-insert-function
	(function liece-x-face-insert-with-xemacs))

  (defun liece-x-face-insert-with-xemacs (buffer str nick)
    (save-excursion
      (let ((glyph (cdr-safe (assoc nick liece-glyph-cache))))
	(unless glyph
	  (setq glyph (make-glyph
		       (list (vector 'xface :data str)
			     (vector 'string :data str))))
	  (when glyph
	    (push (cons nick glyph) liece-glyph-cache)
	    (set-glyph-face glyph 'default)))
	(set-buffer buffer)
	(goto-char (point-max))
	(when glyph
	  (set-extent-end-glyph (make-extent (point) (point)) glyph))))))

;;; @ startup splash
;;; 
(eval-when-compile
  (defvar filename)
  (setq load-path
	`(,(if (and (boundp 'filename)
		    (stringp filename)
		    (file-exists-p filename))
	       (file-name-directory filename)
	     default-directory)
	  ,@load-path)))

(when (featurep 'xpm)
  (eval-when-compile
    (defmacro liece-xemacs-logo ()
      (let ((logo "liece.xpm")
	    (dir (if (and (boundp 'filename)
			  (stringp filename)
			  (file-exists-p filename))
		     (file-name-directory filename)
		   default-directory)))
	(setq logo (expand-file-name logo dir))
	(if (file-exists-p logo)
	    (let ((buffer (generate-new-buffer " *liece-logo*"))
		  (coding-system-for-read (quote binary))
		  buffer-file-format format-alist
		  insert-file-contents-post-hook
		  insert-file-contents-pre-hook)
	      (prog1
		  (save-excursion
		    (set-buffer buffer)
		    (insert-file-contents logo)
		    (buffer-string))
		(kill-buffer buffer)))
	  (progn
	    (byte-compile-warn
	     "Warning: file \"%s\" not found." logo)
	    (sit-for 2)
	    nil))))))

(defconst liece-xemacs-logo
  (when (featurep 'xpm)
    (liece-xemacs-logo)))

(defun liece-xemacs-splash-at-point (&optional height)
  "Display splash logo in HEIGHT."
  (or (bolp) (insert "\n"))
  (let ((bow (point))
	(glyph (make-glyph
		(list (vector 'xpm :data liece-xemacs-logo)
		      [nothing])))
	(lh (/ (window-pixel-height) (window-height)))
	(lw (/ (window-pixel-width) (window-width)))
	(liece-insert-environment-version nil)
        bov)
    
    (insert-char ?\n (max 0 (/ (- (or height (window-height))
				  (/ (glyph-height glyph) lh))
			       2)))
    (insert-char ?\  (max 0 (/ (- (window-width)
				  (/ (glyph-width glyph) lw))
			       2)))
    (set-extent-end-glyph
     (make-extent (point) (point))
     glyph)
    (insert "\n")
    (insert-char ?\  (max 0 (/ (- (window-width) (length (liece-version))) 2)))
    (setq bov (point))
    (insert (liece-version))
    (and (find-face 'bold-italic)
         (put-text-property bov (point) 'face 'bold-italic))
    (goto-char bow)
    (set-window-start (get-buffer-window (current-buffer)) (point))
    (redisplay-frame)))

(defun liece-xemacs-splash (&optional arg)
  "Display splash logo interactively.
If ARG is given, don't hide splash buffer."
  (interactive "P")
  (and liece-xemacs-logo
       (let ((frame (selected-frame))
             config buffer
	     (liece-insert-environment-version nil))
         (and frame
              (unwind-protect
                  (progn
                    (setq config (current-window-configuration))
		    (setq buffer (generate-new-buffer
				  (concat (if arg "*" " *")
					  (liece-version) "*")))
                    (switch-to-buffer buffer)
                    (delete-other-windows)
                    (liece-xemacs-splash-at-point)
                    (set-buffer-modified-p nil)
                    (or arg (sleep-for 2)))
                (unless arg
                  (kill-buffer buffer)
                  (set-window-configuration config)
                  (redisplay-frame frame)))))))

(unless (or liece-inhibit-startup-message
	    (eq 'stream (device-type)))
  (liece-xemacs-splash))

;;; @ unread mark
;;; 
(defun liece-xemacs-unread-mark (chnl)
  (if liece-display-unread-mark
      (with-current-buffer liece-channel-list-buffer
        (let* ((buffer-read-only nil)
	       (file (liece-locate-icon-file liece-xemacs-unread-icon))
	       (glyph
		(make-glyph
		 (nconc (if (and (featurep 'xpm) file)
			    (list (vector 'xpm :file file)))
			(list (vector 'string
				      :data liece-channel-unread-character)))))
	       ext)
	  (goto-char (point-min))
	  (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
            (goto-char (match-end 0))
	    (insert " ")
	    (setq ext (make-extent (match-end 0) (1+ (match-end 0))))
	    (set-extent-end-glyph ext glyph))))))

(defun liece-xemacs-read-mark (chnl)
  (if liece-display-unread-mark
      (with-current-buffer liece-channel-list-buffer
        (let ((buffer-read-only nil))
	  (goto-char (point-min))
	  (when (re-search-forward (concat "^ ?[0-9]+: " chnl " $") nil t)
            (goto-char (1- (match-end 0)))
	    (delete-char 1))))))

(defun liece-xemacs-redisplay-unread-mark ()
  (if liece-display-unread-mark
      (dolist (chnl liece-channel-unread-list)
        (liece-xemacs-unread-mark chnl))))


;;; @ emulation functions
;;; 
(defun liece-xemacs-map-extents (function)
  "Map FUNCTION over the extents which overlap the current buffer."
  (map-extents (lambda (extent ignore)
		 (if (overlayp extent) (funcall function extent)))))

(defun liece-xemacs-kill-all-overlays ()
  "Delete all extents in the current buffer."
  (liece-xemacs-map-extents #'delete-extent))

(defun liece-xemacs-overlays-at (pos)
  "Return a list of the overlays that contain position POS."
  (let ((ext (extent-at pos)))
    (and ext (overlayp ext) (list ext))))
      
(fset 'liece-mode-line-buffer-identification
      'liece-xemacs-mode-line-buffer-identification)

(fset 'liece-suppress-mode-line-format
      'liece-xemacs-suppress-modeline-format)

(fset 'liece-kill-all-overlays 'liece-xemacs-kill-all-overlays)
(fset 'liece-map-overlays 'liece-xemacs-map-extents)
(fset 'liece-locate-data-directory 'locate-data-directory)

(add-hook 'liece-nick-insert-hook 'liece-xemacs-glyph-nick-region)
(add-hook 'liece-nick-insert-hook 'liece-xemacs-set-drop-functions)

(add-hook 'liece-nick-replace-hook 'liece-xemacs-glyph-nick-region)
(add-hook 'liece-nick-replace-hook 'liece-xemacs-set-drop-functions)

(fset 'liece-redisplay-unread-mark 'liece-xemacs-redisplay-unread-mark)
(add-hook 'liece-channel-unread-functions 'liece-xemacs-unread-mark)
(add-hook 'liece-channel-read-functions 'liece-xemacs-read-mark)

(provide 'liece-xemacs)

;;; liece-xemacs.el ends here