lisp/liece-menu.el

   1 ;;; liece-menu.el --- Define menus.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-09-06
   6 ;; Revised: 1999-09-06
   7 ;; Keywords: menu, easymenu
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (eval-when-compile
  33   (require 'easymenu)
  34   (require 'advice)
  35   (require 'liece-compat)
  36   (require 'liece-commands)
  37   (require 'liece-intl)
  38   (require 'liece-nick))
  39
  40 (defvar liece-use-localized-menu (featurep 'meadow))
  41
  42 (defvar liece-nick-popup-menu
  43   '("Liece"
  44     ["Finger" liece-menu-callback-finger
  45      liece-nick-region-nicks]
  46     "----"
  47     ["CTCP VERSION" liece-menu-callback-ctcp-version
  48      liece-nick-region-nicks]
  49     ["CTCP USERINFO" liece-menu-callback-ctcp-userinfo
  50      liece-nick-region-nicks]
  51     ["CTCP HELP" liece-menu-callback-ctcp-help
  52      liece-nick-region-nicks]
  53     ["CTCP CLIENTINFO" liece-menu-callback-ctcp-clientinfo
  54      liece-nick-region-nicks]
  55     ["CTCP PING" liece-menu-callback-ctcp-ping
  56      liece-nick-region-nicks]
  57     "----"
  58     ["Set Channel Operator(s)" liece-menu-callback-mode+o
  59      liece-nick-region-nicks]
  60     ["Set Channel Voice(s)" liece-menu-callback-mode+v
  61      liece-nick-region-nicks]
  62     ["Unset Channel Operator(s)" liece-menu-callback-mode-o
  63      liece-nick-region-nicks]
  64     ["Unset Channel Voice(s)" liece-menu-callback-mode-v
  65      liece-nick-region-nicks]
  66     "----"
  67     ["Kick" liece-menu-callback-kick
  68      liece-nick-region-nicks]))
  69
  70 (defvar liece-menu-url-menu '("URL" "----"))
  71 (defvar liece-menu-dcc-menu
  72   '("DCC"
  73     ["Send file" liece-command-dcc-send t]
  74     ["Receive file" liece-command-dcc-receive t]
  75     "----"
  76     ["Send chat request" liece-command-dcc-chat-listen t]
  77     ["Accept chat request" liece-command-dcc-chat-connect t]
  78     "----"
  79     ["List DCC request" liece-command-dcc-list t]
  80     ["Dispatch stacked DCC requests" liece-command-dcc-accept t]))
  81
  82 (defvar liece-menu-private-menu
  83   '("Private"
  84     ["Toggle private conversation" liece-command-toggle-private
  85      (liece-server-opened)]
  86     ["IsON" liece-command-ison (liece-server-opened)]
  87     ["Register friends" liece-command-activate-friends t]
  88     ["Unregister friends" liece-command-deactivate-friends t]
  89     ["Display userhost" liece-command-userhost (liece-server-opened)]
  90     ["Ignore nicks / regexp" liece-command-kill t]
  91     ["Compose mail" liece-command-mail-compose t]))
  92
  93 (defvar liece-menu-ctcp-menu
  94   '("CTCP"
  95     ["ACTION" liece-command-client-action
  96      liece-current-channel]
  97     ["VERSION" liece-command-client-version
  98      liece-current-channel]
  99     ["USERINFO" liece-command-client-userinfo
 100      liece-current-channel]
 101     ["HELP" liece-command-client-help
 102      liece-current-channel]
 103     ["CLIENTINFO" liece-command-client-clientinfo
 104      liece-current-channel]
 105     ["PING" liece-command-client-ping
 106      liece-current-channel]
 107     "----"
 108     ["Request X-Face" liece-command-client-x-face
 109      liece-current-channel]
 110     ["Set my X-Face" liece-command-client-x-face-from-xbm-file
 111      liece-current-channel]))
 112
 113 (defvar liece-menu-channel-menu
 114   (nconc
 115    '("Channel"
 116      ["Join channel" liece-command-join
 117       (liece-server-opened)]
 118      ["Part channel" liece-command-part
 119       (or liece-current-channels liece-current-chat-partners)]
 120      ["Go to next channel" liece-command-next-channel
 121       (or liece-current-channels liece-current-chat-partners)]
 122      ["Go to previous channel" liece-command-previous-channel
 123       (or liece-current-channels liece-current-chat-partners)]
 124      ["Rotate left channels" liece-command-pop
 125       (or liece-current-channels liece-current-chat-partners)]
 126      ["Rotate right channels" liece-command-push
 127       (or liece-current-channels liece-current-chat-partners)]
 128      "----"
 129      ["Invite to this channel" liece-command-invite
 130       liece-current-channel]
 131      ["Kick out from this channel" liece-command-kick
 132       liece-current-channel]
 133      "----"
 134      ["Set mode of this channel" liece-command-modec
 135       liece-current-channel]
 136      ["Set topic of this channel" liece-command-topic
 137       liece-current-channel]
 138      "----"
 139      ["Toggle freeze of this channel" liece-command-freeze
 140       liece-current-channel]
 141      ["Toggle own freeze of this channel" liece-command-own-freeze
 142       liece-current-channel]
 143      ["Toggle beep notice of this channel" liece-dialogue-beep
 144       liece-current-channel]
 145      "----"
 146      ["List channel" liece-command-list
 147       (liece-server-opened)]
 148      ["Display names of channel" liece-command-names
 149       (liece-server-opened)]
 150      ["Display who are on the channel" liece-command-names
 151       (liece-server-opened)]
 152      "----"
 153      ["Set default key of this channel" liece-command-set-default-key
 154       (or liece-current-channel liece-current-chat-partner)]
 155      "----")
 156    (list liece-menu-ctcp-menu)))
 157
 158 (defvar liece-menu-IRC-menu
 159   '("IRC"
 160     ["Load variables file" liece-command-load-vars t]
 161     ["Save variables file" liece-command-save-vars t]
 162     "----"
 163     ["Change window style" liece-command-set-window-style t]
 164     ["Reload style file" liece-command-reload-window-style t]
 165     ["Reconfigure windows" liece-command-reconfigure-windows t]
 166     ["Toggle channel buffer display state"
 167      liece-command-toggle-channel-buffer-mode t]
 168     ["Toggle nick buffer display state"
 169      liece-command-toggle-nick-buffer-mode t]
 170     "----"
 171     ["Enter debug mode" liece-command-debug t]
 172     ["Quit IRC" liece-command-quit t]))
 173
 174 (defvar liece-menu-alist
 175   '(
 176     (liece-menu-IRC-menu "IRC Menu.")
 177     (liece-menu-channel-menu "Channel Menu.")
 178     (liece-menu-private-menu "Private Menu.")
 179     (liece-menu-dcc-menu "DCC Menu.")
 180     (liece-menu-url-menu "URL Menu.")))
 181
 182 (defvar liece-menu-IRC-menu-map)
 183 (defvar liece-menu-channel-menu-map)
 184 (defvar liece-menu-private-menu-map)
 185 (defvar liece-menu-dcc-menu-map)
 186 (defvar liece-menu-url-menu-map)
 187
 188 ;;; @ popup menus
 189 ;;;
 190 (defmacro liece-menu-bogus-filter-constructor (name menu)
 191   `(let (x y)
 192      (setq x (x-popup-menu t ,menu)
 193            y (and x (lookup-key ,menu (apply #'vector x))))
 194      (if (and x y)
 195          (funcall y))))
 196
 197 (defmacro liece-menu-popup-menu (event menu)
 198   (if (featurep 'xemacs)
 199       `(popup-menu ,menu)
 200     `(let (bogus-menu)
 201        (easy-menu-define bogus-menu nil nil ,menu)
 202        (liece-menu-bogus-filter-constructor "Popup" bogus-menu))))
 203
 204 (defun liece-nick-popup-menu (widget &optional event)
 205   (let ((menu (copy-sequence liece-nick-popup-menu))
 206         (pos (widget-event-point event)))
 207     (when pos
 208       (goto-char pos)
 209       (if (eq major-mode 'liece-nick-mode)
 210           (liece-nick-update-region))
 211       (liece-menu-popup-menu event menu))))
 212
 213 ;;; @ initialize menus
 214 ;;;
 215 (when (or (featurep 'menubar); XEmacs
 216           (featurep 'menu-bar))
 217   (add-hook 'liece-command-mode-hook 'liece-command-define-menus)
 218   (add-hook 'liece-command-mode-hook 'liece-command-add-menus 'append)
 219   (add-hook 'liece-add-url-functions 'liece-menu-add-url))
 220
 221 (defun liece-menu-define (menu)
 222   (eval (list 'easy-menu-define
 223               (intern (concat (symbol-name (car menu)) "-map"))
 224               'liece-command-mode-map (cadr menu)
 225               '(symbol-value (car menu)))))
 226
 227 (defun liece-command-define-menus-1 (value)
 228   (dolist (spec value)
 229     (cond
 230      ((stringp spec))
 231      ((vectorp spec)
 232       (when liece-use-localized-menu
 233         (aset spec 0 (liece-intl-get-msgstr (aref spec 0)))))
 234      ((listp spec)
 235       (liece-command-define-menus-1 spec)))))
 236
 237 (defun liece-command-define-menus ()
 238   (dolist (menu (reverse liece-menu-alist))
 239     (let ((value (symbol-value (car menu))))
 240       (liece-command-define-menus-1 value)
 241       (liece-menu-define menu))))
 242
 243 (defun liece-command-add-menus ()
 244   (dolist (menu liece-menu-alist)
 245     (easy-menu-add (symbol-value (car menu)) liece-command-mode-map)))
 246
 247 (defun liece-menu-add-url (url)
 248   (when (boundp 'liece-menu-url-menu-map)
 249     (easy-menu-add-item
 250      liece-menu-url-menu-map nil
 251      (vector url (list 'liece-command-browse-url url) t))))
 252
 253 ;;; @ menu callbacks
 254 ;;;
 255 (autoload 'liece-menu-callback-ctcp-version "liece-ctcp" nil t)
 256 (autoload 'liece-menu-callback-ctcp-userinfo "liece-ctcp" nil t)
 257 (autoload 'liece-menu-callback-ctcp-help "liece-ctcp" nil t)
 258 (autoload 'liece-menu-callback-ctcp-clientinfo "liece-ctcp" nil t)
 259 (autoload 'liece-menu-callback-ctcp-ping "liece-ctcp" nil t)
 260
 261 (defun liece-menu-callback-finger ()
 262   (interactive)
 263   (dolist (nick liece-nick-region-nicks)
 264     (liece-command-finger nick)))
 265
 266 (defun liece-menu-callback-kick ()
 267   (interactive)
 268   (dolist (nick liece-nick-region-nicks)
 269     (liece-command-kick nick)))
 270
 271 (defun liece-menu-callback-mode+o ()
 272   (interactive)
 273   (dolist (oper liece-nick-region-opers)
 274     (setq liece-nick-region-nicks
 275           (string-list-remove-ignore-case oper liece-nick-region-nicks)))
 276   (liece-command-mode+o liece-nick-region-nicks))
 277
 278 (defun liece-menu-callback-mode+v ()
 279   (interactive)
 280   (dolist (voice liece-nick-region-voices)
 281     (setq liece-nick-region-nicks
 282           (string-list-remove-ignore-case voice liece-nick-region-nicks)))
 283   (liece-command-mode+v liece-nick-region-nicks))
 284
 285 (defun liece-menu-callback-mode-o ()
 286   (interactive)
 287   (liece-command-mode-o liece-nick-region-opers))
 288
 289 (defun liece-menu-callback-mode-v ()
 290   (interactive)
 291   (liece-command-mode-v liece-nick-region-voices))
 292
 293 (provide 'liece-menu)
 294
 295 ;;; liece-menu.el ends here