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-set-operators
  59      liece-nick-region-nicks]
  60     ["Set Channel Voice(s)" liece-menu-callback-set-voices
  61      liece-nick-region-nicks]
  62     ["Unset Channel Operator(s)" liece-menu-callback-unset-operators
  63      liece-nick-region-nicks]
  64     ["Unset Channel Voice(s)" liece-menu-callback-unset-voices
  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-ctcp-action
  96      liece-current-channel]
  97     ["VERSION" liece-command-ctcp-version
  98      liece-current-channel]
  99     ["USERINFO" liece-command-ctcp-userinfo
 100      liece-current-channel]
 101     ["HELP" liece-command-ctcp-help
 102      liece-current-channel]
 103     ["CLIENTINFO" liece-command-ctcp-clientinfo
 104      liece-current-channel]
 105     ["PING" liece-command-ctcp-ping
 106      liece-current-channel]
 107     "----"
 108     ["Request X-Face" liece-command-ctcp-x-face
 109      liece-current-channel]
 110     ["Set my X-Face" liece-command-ctcp-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      ["Go to unread channel" liece-command-unread-channel
 125       (or liece-current-channels liece-current-chat-partners)]
 126      ["Rotate left channels" liece-command-pop
 127       (or liece-current-channels liece-current-chat-partners)]
 128      ["Rotate right channels" liece-command-push
 129       (or liece-current-channels liece-current-chat-partners)]
 130      "----"
 131      ["Invite to this channel" liece-command-invite
 132       liece-current-channel]
 133      ["Kick out from this channel" liece-command-kick
 134       liece-current-channel]
 135      "----"
 136      ["Set mode of this channel" liece-command-modec
 137       liece-current-channel]
 138      ["Set topic of this channel" liece-command-topic
 139       liece-current-channel]
 140      "----"
 141      ["Toggle freeze of this channel" liece-command-freeze
 142       liece-current-channel]
 143      ["Toggle own freeze of this channel" liece-command-own-freeze
 144       liece-current-channel]
 145      ["Toggle beep notice of this channel" liece-dialogue-beep
 146       liece-current-channel]
 147      "----"
 148      ["List channel" liece-command-list
 149       (liece-server-opened)]
 150      ["Display names of channel" liece-command-names
 151       (liece-server-opened)]
 152      ["Display who are on the channel" liece-command-names
 153       (liece-server-opened)]
 154      "----"
 155      ["Set default key of this channel" liece-command-set-default-key
 156       (or liece-current-channel liece-current-chat-partner)]
 157      "----")
 158    (list liece-menu-ctcp-menu)))
 159
 160 (defvar liece-menu-IRC-menu
 161   '("IRC"
 162     ["Load variables file" liece-command-load-vars t]
 163     ["Save variables file" liece-command-save-vars t]
 164     "----"
 165     ["Change window style" liece-command-set-window-style t]
 166     ["Reload style file" liece-command-reload-window-style t]
 167     ["Reconfigure windows" liece-command-reconfigure-windows t]
 168     ["Toggle channel buffer display state"
 169      liece-command-toggle-channel-buffer-mode t]
 170     ["Toggle nick buffer display state"
 171      liece-command-toggle-nick-buffer-mode t]
 172     "----"
 173     ["Enter debug mode" liece-command-debug t]
 174     ["Quit IRC" liece-command-quit t]))
 175
 176 (defvar liece-menu-alist
 177   '(
 178     (liece-menu-IRC-menu "IRC Menu.")
 179     (liece-menu-channel-menu "Channel Menu.")
 180     (liece-menu-private-menu "Private Menu.")
 181     (liece-menu-dcc-menu "DCC Menu.")
 182     (liece-menu-url-menu "URL Menu.")))
 183
 184 (defvar liece-menu-IRC-menu-map)
 185 (defvar liece-menu-channel-menu-map)
 186 (defvar liece-menu-private-menu-map)
 187 (defvar liece-menu-dcc-menu-map)
 188 (defvar liece-menu-url-menu-map)
 189
 190 ;;; @ popup menus
 191 ;;;
 192 (defmacro liece-menu-bogus-filter-constructor (name menu)
 193   `(let (x y)
 194      (setq x (x-popup-menu t ,menu)
 195            y (and x (lookup-key ,menu (apply #'vector x))))
 196      (if (and x y)
 197          (funcall y))))
 198
 199 (defmacro liece-menu-popup-menu (event menu)
 200   (if (featurep 'xemacs)
 201       `(popup-menu ,menu)
 202     `(let (bogus-menu)
 203        (easy-menu-define bogus-menu nil nil ,menu)
 204        (liece-menu-bogus-filter-constructor "Popup" bogus-menu))))
 205
 206 (defun liece-nick-popup-menu (widget &optional event)
 207   (let ((menu (copy-sequence liece-nick-popup-menu))
 208         (pos (widget-event-point event)))
 209     (when pos
 210       (goto-char pos)
 211       (if (eq major-mode 'liece-nick-mode)
 212           (liece-nick-update-region))
 213       (liece-menu-popup-menu event menu))))
 214
 215 ;;; @ initialize menus
 216 ;;;
 217 (when (or (featurep 'menubar); XEmacs
 218           (featurep 'menu-bar))
 219   (add-hook 'liece-command-mode-hook 'liece-command-define-menus)
 220   (add-hook 'liece-command-mode-hook 'liece-command-add-menus 'append)
 221   (add-hook 'liece-add-url-functions 'liece-menu-add-url))
 222
 223 (defun liece-menu-define (menu)
 224   (eval (list 'easy-menu-define
 225               (intern (concat (symbol-name (car menu)) "-map"))
 226               'liece-command-mode-map (cadr menu)
 227               '(symbol-value (car menu)))))
 228
 229 (defun liece-command-define-menus-1 (value)
 230   (dolist (spec value)
 231     (cond
 232      ((stringp spec))
 233      ((vectorp spec)
 234       (when liece-use-localized-menu
 235         (aset spec 0 (liece-intl-get-msgstr (aref spec 0)))))
 236      ((listp spec)
 237       (liece-command-define-menus-1 spec)))))
 238
 239 (defun liece-command-define-menus ()
 240   (dolist (menu (reverse liece-menu-alist))
 241     (let ((value (symbol-value (car menu))))
 242       (liece-command-define-menus-1 value)
 243       (liece-menu-define menu))))
 244
 245 (defun liece-command-add-menus ()
 246   (dolist (menu liece-menu-alist)
 247     (easy-menu-add (symbol-value (car menu)) liece-command-mode-map)))
 248
 249 (defun liece-menu-add-url (url)
 250   (when (boundp 'liece-menu-url-menu-map)
 251     (easy-menu-add-item
 252      liece-menu-url-menu-map nil
 253      (vector url (list 'liece-command-browse-url url) t))))
 254
 255 ;;; @ menu callbacks
 256 ;;;
 257 (autoload 'liece-menu-callback-ctcp-version "liece-ctcp" nil t)
 258 (autoload 'liece-menu-callback-ctcp-userinfo "liece-ctcp" nil t)
 259 (autoload 'liece-menu-callback-ctcp-help "liece-ctcp" nil t)
 260 (autoload 'liece-menu-callback-ctcp-clientinfo "liece-ctcp" nil t)
 261 (autoload 'liece-menu-callback-ctcp-ping "liece-ctcp" nil t)
 262
 263 (defun liece-menu-callback-finger ()
 264   (interactive)
 265   (dolist (nick liece-nick-region-nicks)
 266     (liece-command-finger nick)))
 267
 268 (defun liece-menu-callback-kick ()
 269   (interactive)
 270   (dolist (nick liece-nick-region-nicks)
 271     (liece-command-kick nick)))
 272
 273 (defun liece-menu-callback-set-operators ()
 274   (interactive)
 275   (let ((opers (liece-channel-get-operators)))
 276     (setq liece-nick-region-nicks
 277           (filter-elements nick liece-nick-region-nicks
 278             (not (liece-nick-member nick opers)))))
 279   (liece-command-set-operators liece-nick-region-nicks))
 280
 281 (defun liece-menu-callback-set-voices ()
 282   (interactive)
 283   (let ((voices (liece-channel-get-voices)))
 284     (setq liece-nick-region-nicks
 285           (filter-elements nick liece-nick-region-nicks
 286             (not (liece-nick-member nick voices)))))
 287   (liece-command-set-voices liece-nick-region-nicks))
 288
 289 (defun liece-menu-callback-unset-operators ()
 290   (interactive)
 291   (let ((opers (liece-channel-get-operators)))
 292     (setq liece-nick-region-nicks
 293           (filter-elements nick liece-nick-region-nicks
 294             (liece-nick-member nick opers))))
 295   (liece-command-set-operators liece-nick-region-nicks t))
 296
 297 (defun liece-menu-callback-unset-voices ()
 298   (interactive)
 299   (let ((voices (liece-channel-get-voices)))
 300     (setq liece-nick-region-nicks
 301           (filter-elements nick liece-nick-region-nicks
 302             (liece-nick-member nick voices))))
 303   (liece-command-set-voices liece-nick-region-nicks t))
 304
 305 (provide 'liece-menu)
 306
 307 ;;; liece-menu.el ends here