Catch up with the changes incorporated in XEmacs package.

[elisp/liece.git] / lisp / liece-xemacs.el

diff --git a/lisp/liece-xemacs.el b/lisp/liece-xemacs.el
index 06cc66c..e12aec4 100644 (file)
--- a/lisp/liece-xemacs.el
+++ b/lisp/liece-xemacs.el
@@ -31,7 +31,7 @@
 
 (eval-when-compile
   (require 'liece-inlines)
 
 (eval-when-compile
   (require 'liece-inlines)

-  (require 'liece-crypt)
+  (require 'liece-misc)

   (require 'liece-commands))
 
 (autoload 'liece-command-dcc-send "liece-dcc")
   (require 'liece-commands))
 
 (autoload 'liece-command-dcc-send "liece-dcc")

@@ -126,31 +126,22 @@ If it is non-nil, it must be a toolbar.  The five valid values are
   :type 'liece-toolbar-icon
   :group 'liece-toolbar-icons)
 
   :type 'liece-toolbar-icon
   :group 'liece-toolbar-icons)
 

-(defcustom liece-toolbar-crypt-active-icon '(:up "encrypt.xpm")
-  "Crypt button (active)."
-  :type 'liece-toolbar-icon
-  :group 'liece-toolbar-icons)
-
-(defcustom liece-toolbar-crypt-inactive-icon '(:up "crypt.xpm")
-  "Crypt button (inactive)."
-  :type 'liece-toolbar-icon
-  :group 'liece-toolbar-icons)
-
-(defcustom liece-toolbar-crypt-icon
-  liece-toolbar-crypt-inactive-icon
-  "Crypt 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-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)
 ;;; @ internal variables
 ;;; 
 (defvar liece-glyph-cache nil)

-(defvar liece-toolbar-position default-toolbar-position)
+(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-back-glyph nil)
 (defvar liece-toolbar-forward-glyph nil)

@@ -158,9 +149,6 @@ If it is non-nil, it must be a toolbar.  The five valid values are
 (defvar liece-toolbar-home-glyph nil)
 (defvar liece-toolbar-search-glyph nil)
 (defvar liece-toolbar-location-glyph nil)
 (defvar liece-toolbar-home-glyph nil)
 (defvar liece-toolbar-search-glyph nil)
 (defvar liece-toolbar-location-glyph nil)

-(defvar liece-toolbar-crypt-glyph nil)
-(defvar liece-toolbar-crypt-active-glyph nil)
-(defvar liece-toolbar-crypt-inactive-glyph nil)

 (defvar liece-toolbar-stop-glyph nil)
 
 (defvar liece-toolbar-spec-list
 (defvar liece-toolbar-stop-glyph nil)
 
 (defvar liece-toolbar-spec-list

@@ -176,8 +164,6 @@ If it is non-nil, it must be a toolbar.  The five valid values are
      liece-command-finger t "Finger"]
     [liece-toolbar-location-glyph
      liece-command-join t "Join Channel"]
      liece-command-finger t "Finger"]
     [liece-toolbar-location-glyph
      liece-command-join t "Join Channel"]

-    [liece-toolbar-crypt-glyph
-     liece-toolbar-toggle-crypt t "Toggle Crypt Mode"]

     [liece-toolbar-stop-glyph
      liece-command-quit t "Quit IRC"]))
 
     [liece-toolbar-stop-glyph
      liece-command-quit t "Quit IRC"]))
 

@@ -209,44 +195,22 @@ If optional argument FORCE is non-nil, always update toolbar."
                            "icon"))))
       (when (or force
                (not (symbol-value icon)))
                            "icon"))))
       (when (or force
                (not (symbol-value icon)))

-       (set icon (liece-toolbar-map-button-list plist)))
-      (run-hooks 'liece-xemacs-setup-toolbar-hook))))
-
-(add-hook 'liece-xemacs-setup-toolbar-hook 'liece-toolbar-setup-crypt-glyph)
-
-(defun liece-toolbar-setup-crypt-glyph ()
-  "Set crypt icons in two states."
-  (setq liece-toolbar-crypt-active-glyph
-       (liece-toolbar-map-button-list liece-toolbar-crypt-active-icon)
-       liece-toolbar-crypt-inactive-glyph
-       (liece-toolbar-map-button-list liece-toolbar-crypt-inactive-icon)))
-
-(defun liece-toolbar-toggle-crypt ()
-  "Toolbar button handler for crypt mode."
-  (interactive)
-  (liece-command-toggle-crypt)
-  (setq liece-toolbar-crypt-glyph
-       (if liece-crypt-mode-active
-           liece-toolbar-crypt-active-glyph
-         liece-toolbar-crypt-inactive-glyph))
-  (and liece-use-toolbar
-       (set-specifier (symbol-value liece-use-toolbar)
-                     (cons (current-buffer) liece-toolbar-spec-list))))
+       (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."
 
 ;;; @ modeline decoration
 ;;; 
 (defun liece-xemacs-hide-modeline ()
   "Remove modeline from current window."

-  (set-specifier has-modeline-p (cons (current-buffer) nil)))
+  (set-specifier has-modeline-p nil (current-buffer)))

 
 (when (featurep 'scrollbar)
   (defun liece-xemacs-hide-scrollbars ()
     (static-cond
      ((boundp 'horizontal-scrollbar-visible-p)
 
 (when (featurep 'scrollbar)
   (defun liece-xemacs-hide-scrollbars ()
     (static-cond
      ((boundp 'horizontal-scrollbar-visible-p)

-      (set-specifier horizontal-scrollbar-visible-p nil
-                    (current-buffer)))
+      (set-specifier horizontal-scrollbar-visible-p nil (current-buffer)))

      ((boundp 'scrollbar-height)
      ((boundp 'scrollbar-height)

-      (set-specifier scrollbar-height (cons (current-buffer) 0)))))
+      (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-scrollbars)
   (add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-scrollbars))
 

@@ -265,10 +229,10 @@ If optional argument FORCE is non-nil, always update toolbar."
 
 (defun liece-setup-toolbar ()
   "Prepare toolbar if wanted."
 
 (defun liece-setup-toolbar ()
   "Prepare toolbar if wanted."

-  (and liece-use-toolbar
-       (liece-xemacs-setup-toolbar liece-toolbar-spec-list)
-       (set-specifier (symbol-value liece-use-toolbar)
-                     (cons (current-buffer) liece-toolbar-spec-list))))
+  (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."
 
 (defun liece-xemacs-modeline-glyph ()
   "Return a glyph of modeline pointer."

@@ -276,11 +240,11 @@ If optional argument FORCE is non-nil, always update toolbar."
         (let (file)
           (make-glyph
            (nconc
         (let (file)
           (make-glyph
            (nconc

-            (if (setq file (liece-locate-icon-file
-                            "liece-pointer.xpm"))
+            (if (and (featurep 'xpm)
+                     (setq file (liece-locate-icon-file "liece-pointer.xpm")))

                 (list (vector 'xpm :file file)))
                 (list (vector 'xpm :file file)))

-            (if (setq file (liece-locate-icon-file
-                            "liece-pointer.xbm"))
+            (if (and (featurep 'xbm)
+                     (setq file (liece-locate-icon-file "liece-pointer.xbm")))

                 (list (vector 'xbm :file file)))
             '([string :data "Liece:"]))))))
     (set-glyph-face glyph 'modeline-buffer-id)
                 (list (vector 'xbm :file file)))
             '([string :data "Liece:"]))))))
     (set-glyph-face glyph 'modeline-buffer-id)

@@ -344,7 +308,8 @@ Modify whole identification by side effect."
    (let ((glyph
          (make-glyph
           (nconc
    (let ((glyph
          (make-glyph
           (nconc

-           (if (setq file (liece-locate-icon-file file))
+           (if (and (featurep 'xpm)
+                    (setq file (liece-locate-icon-file file)))

                (list (vector 'xpm :file file)))
            (if string
                (list (vector 'string :data string)))))))
                (list (vector 'xpm :file file)))
            (if string
                (list (vector 'string :data string)))))))

@@ -458,15 +423,6 @@ Always two arguments are passed, OBJECT and NICK."
       (let ((filename (match-string 1 (cdr object))))
        (liece-command-dcc-send filename nick))))
 
       (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))
 (eval-and-compile
   (setq liece-x-face-insert-function
        (function liece-x-face-insert-with-xemacs))

@@ -476,11 +432,8 @@ Always two arguments are passed, OBJECT and NICK."
       (let ((glyph (cdr-safe (assoc nick liece-glyph-cache))))
        (unless glyph
          (setq glyph (make-glyph
       (let ((glyph (cdr-safe (assoc nick liece-glyph-cache))))
        (unless glyph
          (setq glyph (make-glyph

-                      (cond
-                       ((and (featurep 'xface)
-                             (memq (console-type) '(x mswindows)))
-                        `[xface :data ,str])
-                       (t `[string :data ,str]))))
+                      (list (vector 'xface :data str)
+                            (vector 'string :data str))))

          (when glyph
            (push (cons nick glyph) liece-glyph-cache)
            (set-glyph-face glyph 'default)))
          (when glyph
            (push (cons nick glyph) liece-glyph-cache)
            (set-glyph-face glyph 'default)))

@@ -537,7 +490,9 @@ Always two arguments are passed, OBJECT and NICK."
   "Display splash logo in HEIGHT."
   (or (bolp) (insert "\n"))
   (let ((bow (point))
   "Display splash logo in HEIGHT."
   (or (bolp) (insert "\n"))
   (let ((bow (point))

-       (glyph (make-glyph `[xpm :data ,liece-xemacs-logo]))
+       (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)
        (lh (/ (window-pixel-height) (window-height)))
        (lw (/ (window-pixel-width) (window-width)))
        (liece-insert-environment-version nil)

@@ -549,10 +504,9 @@ Always two arguments are passed, OBJECT and NICK."
     (insert-char ?\  (max 0 (/ (- (window-width)
                                  (/ (glyph-width glyph) lw))
                               2)))
     (insert-char ?\  (max 0 (/ (- (window-width)
                                  (/ (glyph-width glyph) lw))
                               2)))

-    (when (and (featurep 'xpm) (memq (console-type) '(x mswindows)))
-      (set-extent-end-glyph
-       (make-extent (point) (point))
-       glyph))
+    (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 "\n")
     (insert-char ?\  (max 0 (/ (- (window-width) (length (liece-version))) 2)))
     (setq bov (point))

@@ -575,10 +529,10 @@ If ARG is given, don't hide splash buffer."
               (unwind-protect
                   (progn
                     (setq config (current-window-configuration))
               (unwind-protect
                   (progn
                     (setq config (current-window-configuration))

-                    (switch-to-buffer
-                     (setq buffer (generate-new-buffer
-                                   (concat (if arg "*" " *")
-                                           (liece-version) "*"))))
+                   (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)
                     (delete-other-windows)
                     (liece-xemacs-splash-at-point)
                     (set-buffer-modified-p nil)

@@ -588,8 +542,44 @@ If ARG is given, don't hide splash buffer."
                   (set-window-configuration config)
                   (redisplay-frame frame)))))))
 
                   (set-window-configuration config)
                   (redisplay-frame frame)))))))
 

-(or (eq 'stream (device-type))
-    (liece-xemacs-splash))
+(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))))

 
 \f
 ;;; @ emulation functions
 
 \f
 ;;; @ emulation functions

@@ -624,6 +614,10 @@ If ARG is given, don't hide splash buffer."
 (add-hook 'liece-nick-replace-hook 'liece-xemacs-glyph-nick-region)
 (add-hook 'liece-nick-replace-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
 (provide 'liece-xemacs)
 
 ;;; liece-xemacs.el ends here