cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-mouse.el

   1 ;;; xwem-mouse.el --- Mouse support for XWEM.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: 21 Mar 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xwem-mouse.el,v 1.10 2005-04-04 19:54:14 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30 ;;
  31 ;; XWEM supports mouse as well as keyboard.
  32
  33 ;;; Code:
  34 \f
  35 (require 'xwem-load)
  36 (require 'xwem-manage)
  37
  38 ;;; Customisation
  39 (defcustom xwem-popup-menu-function 'popup-menu
  40   "*Function used to popup menus.
  41 It is created for case when you change default `popup-menu' function,
  42 for example if you are using tpum.el."
  43   :type 'function
  44   :group 'xwem)
  45
  46 ;;; Internal variables
  47
  48 \f
  49 (defun xwem-mouse-change-cursor (cursor)
  50   "XXX.
  51 CURSOR - Dunno."
  52   (XChangeActivePointerGrab (xwem-dpy) cursor
  53                             (Xmask-or XM-ButtonPress XM-ButtonRelease)))
  54
  55 ;;;###autoload
  56 (defun xwem-mouse-grab (cursor &optional win mask)
  57   "Begin to grab mouse, showing CURSOR in WIN using event mask MASK.
  58 Default WIN is root window.
  59 Default MASK is capturing ButtonPress or ButtonRelease events."
  60   ;; TODO: install custom events handlers?
  61   (XGrabPointer (xwem-dpy)
  62                 (or win (xwem-rootwin))
  63                 (or mask (Xmask-or XM-ButtonPress XM-ButtonRelease))
  64                 cursor))
  65
  66 ;;;###autoload
  67 (defun xwem-mouse-ungrab (&optional flush-p)
  68   "Stop grabing mouse.
  69 If FLUSH-P is non-nil, mouse is ungrabbed imediately."
  70   (XUngrabPointer (xwem-dpy))
  71   (when flush-p
  72     ;; XX flush data to server and wait a little
  73     (XFlush (xwem-dpy))
  74     (sit-for 0)))
  75
  76 ;;; Menus
  77 ;;;###autoload
  78 (defun xwem-popup-menu (menu &optional event)
  79   "Popup MENU.
  80 MENU and EVENT is same as for `popup-menu'."
  81   (xwem-mouse-ungrab t)
  82
  83   (funcall xwem-popup-menu-function menu
  84            (or event
  85                (and (member (event-type xwem-last-event)
  86                             '(button-press button-release motion))
  87                     xwem-last-event))))
  88
  89 (defvar xwem-applications-submenu
  90   '("Applications"
  91     ("XEmacs"
  92      ["New frame" (make-frame nil (default-x-device))]
  93      ["*scratch* frame" (with-selected-frame
  94                             (make-frame nil (default-x-device))
  95                           (switch-to-buffer "*scratch*"))])
  96     ("XTerm"
  97      ["Default xterm" (xwem-launch-xterm nil)]
  98      ["2 xterm" (xwem-launch-xterm 2)]
  99      ["3 xterm" (xwem-launch-xterm 3)]
 100      ["4 xterm" (xwem-launch-xterm 4)])
 101     ["Mozilla" (xwem-execute-program "mozilla")]
 102     "--"
 103     ["GhostView" (xwem-execute-program "gv")]
 104     ["xfontsel" (xwem-execute-program "xfontsel")]
 105     ["Lupe" (xwem-launch-lupe nil)]
 106     )
 107   "Submenu with applications.")
 108
 109 ;;;###xwem-autoload
 110 (defun xwem-generate-window-menu (title &optional win)
 111   "Generate menu for WIN."
 112   (unless title
 113     (setq title "Window"))
 114   (list title
 115         (vector "Vertical Split" `(xwem-window-split-vertically nil ,win))
 116         (vector "Horizontal Split" `(xwem-window-split-horizontally nil ,win))
 117         (vector "Delete Window" `(xwem-window-delete ,win))
 118         (vector "Delete Others" `(xwem-window-delete-others ,win))
 119         (vector "Balance" `(xwem-balance-windows ,win))))
 120
 121 (defun xwem-generate-iconified-cl-menu (title &optional max-mwidth)
 122   "Generate menu for iconified clients with TITLE.
 123 MAX-MWIDTH specifies maximum menu width."
 124   (list (xwem-misc-fixup-string title max-mwidth)
 125         :filter
 126         `(lambda (not-used)
 127            (delq nil
 128                  (mapcar #'(lambda (cl)
 129                              (when (eq (xwem-cl-state cl) 'iconified)
 130                                (vector (xwem-misc-fixup-string
 131                                         (xwem-client-name cl) ,max-mwidth)
 132                                        `(xwem-select-client ,cl)
 133                                        :active (xwem-non-dummy-client-p cl))))
 134                          xwem-clients)))))
 135
 136 (defun xwem-generate-applications-cl-menu (title &optional max-mwidth)
 137   "Generate menu for applications."
 138   (list (xwem-misc-fixup-string title max-mwidth)
 139         :filter
 140         `(lambda (not-used)
 141            (mapcar
 142             #'(lambda (app-spec)
 143                 (list (xwem-misc-fixup-string (car app-spec) ,max-mwidth)
 144                       :filter
 145                       `(lambda (not-used)
 146                          (delq nil
 147                                (mapcar
 148                                 #'(lambda (cl)
 149                                     (when (xwem-cl-match-p
 150                                            cl (cdr (quote ,app-spec)))
 151                                       (vector (xwem-misc-fixup-string
 152                                                (xwem-client-name cl) ,,max-mwidth)
 153                                               `(xwem-select-client ,cl)
 154                                               :active
 155                                               (xwem-non-dummy-client-p cl))))
 156                                 xwem-clients)))))
 157             xwem-applications-alist))))
 158
 159 ;;;###xwem-autoload
 160 (defun xwem-generate-clients-menu (title &optional max-mwidth)
 161   "Generate clients menu.
 162 TITLE is menu title.
 163 Optional MAX-MWIDTH argument specifies maximum width for menu items,
 164 default is 42."
 165   (unless max-mwidth
 166     (setq max-mwidth 42))
 167
 168   (let (malist)
 169     (mapc #'(lambda (cl)
 170               (let ((kv (assq (xwem-cl-manage-type cl) malist)))
 171                 (if kv
 172                     (setcdr kv (cons cl (cdr kv)))
 173                   (setq malist (put-alist (xwem-cl-manage-type cl)
 174                                           (list cl) malist)))))
 175           xwem-clients)
 176
 177     (nconc (list (xwem-misc-fixup-string title max-mwidth))
 178            (mapcar #'(lambda (mc)
 179                        (list (xwem-misc-fixup-string
 180                               (symbol-name (car mc)) max-mwidth)
 181                              :filter
 182                              `(lambda (not-used)
 183                                 (mapcar #'(lambda (mccl)
 184                                             (vector (xwem-misc-fixup-string
 185                                                      (xwem-client-name mccl) ,max-mwidth)
 186                                                     `(xwem-select-client ,mccl)
 187                                                     :active (xwem-non-dummy-client-p mccl)))
 188                                         (cdr (quote ,mc))))))
 189                    malist)
 190
 191            ;; Iconified
 192            (list "==")
 193            (list (xwem-generate-iconified-cl-menu "Iconified" max-mwidth))
 194
 195            ;; Applications
 196            (list "--")
 197            (list (xwem-generate-applications-cl-menu "Applications" max-mwidth))
 198            )))
 199
 200 (defun xwem-generate-recent-files (&optional title limit)
 201   "Generate recent files menu."
 202   (unless title (setq title "Recent Files"))
 203   (unless limit (setq limit 10))
 204   (list title
 205         :filter `(lambda (not-used)
 206                    (mapcar #'(lambda (file)
 207                                (vector file `(xwem-open-file ,file)))
 208                            (let ((files xwem-read-filename-history)
 209                                  (ret-files nil)
 210                                  (ci 0))
 211                              (while (and files (< ci ,limit))
 212                                (setq ret-files (cons (car files) ret-files)
 213                                      files (cdr files))
 214                                (incf ci))
 215                              (nreverse ret-files))))))
 216
 217 ;;;###xwem-autoload
 218 (defun xwem-generate-menu ()
 219   "Generate xwem menu on fly."
 220   (list "XWEM Menu"
 221         (list "Minibuffer"
 222               ["Hide" (xwem-iconify (xwem-minib-cl xwem-minibuffer))
 223                :active (eq (xwem-cl-state (xwem-minib-cl xwem-minibuffer)) 'active) ]
 224               ["Show" (xwem-activate (xwem-minib-cl xwem-minibuffer))
 225                :active (not (eq (xwem-cl-state (xwem-minib-cl xwem-minibuffer)) 'active)) ]
 226               ["Restore size" (xwem-minib-rsz-resize 1)])
 227         (xwem-generate-window-menu "Window" (xwem-win-selected))
 228         "--"
 229         (list "Frames" :filter
 230               #'(lambda (not-used)
 231                   (nconc
 232                    (list (list "Operations"
 233                                ["New Frame" (xwem-make-frame 'desktop)]
 234                                ["Next" (xwem-frame-next 1)]
 235                                ["Previous" (xwem-frame-previous 1)]
 236                                ["Iconify" (xwem-frame-hide (xwem-frame-selected))]
 237                                ["Transpose" (xwem-transpose-frames 1)]
 238                                "--"
 239                                ["Destroy" (xwem-frame-destroy (xwem-frame-selected))])
 240                          (list "Side-by-side"
 241                                ["Vertical" (xwem-frame-sbs-vert-split 1)]
 242                                ["Horizontal" (xwem-frame-sbs-hor-split 1)])
 243                          "--"
 244                          ["Show Root" (xwem-frame-showroot)]
 245                          ["Lower" (xwem-frame-lower (xwem-frame-selected))]
 246                          ["Raise" (xwem-frame-raise (xwem-frame-selected))]
 247                          )
 248                    (list "==")
 249                    (mapcar #'(lambda (el)
 250                                (let ((fn (xwem-frame-num el)))
 251                                  (vector
 252                                   (concat "Frame " (int-to-string fn) ": " (xwem-frame-name el))
 253                                   `(xwem-frame-switch-nth ,fn))))
 254                            (xwem-frames-list)))))
 255
 256         (list "Clients" :filter
 257               #'(lambda (not-used)
 258                   (nconc
 259                    (cdr (xwem-generate-clients-menu nil))
 260                    (list "==")
 261                    (and (xwem-cl-selected) (cdr (xwem-generate-cl-menu (xwem-cl-selected) 32))))))
 262         "--"
 263         xwem-applications-submenu
 264
 265         (xwem-generate-recent-files)
 266         ;; XXX - it is just demo of popup menus
 267         ))
 268
 269 ;;;###autoload(autoload 'xwem-popup-clients-menu "xwem-mouse" nil t)
 270 (define-xwem-command xwem-popup-clients-menu ()
 271   "Popup clients menu."
 272   (xwem-interactive)
 273
 274   (xwem-popup-menu (xwem-generate-clients-menu "XWEM Clients")))
 275
 276 ;;;###xwem-autoload
 277 (defun xwem-generate-cl-menu (cl &optional maxnlen)
 278   "Generate menu for CL.
 279 MAXNLEN - maximum menu width in characters."
 280   (unless maxnlen
 281     (setq maxnlen 20))
 282
 283   (delq nil
 284         (list (let ((name (xwem-client-name cl)))
 285                 (when (> (length name) maxnlen)
 286                   (setq name (concat (substring name 0 (- maxnlen 2)) "..")))
 287                 name)
 288               "--"
 289               (vector "Focus client" `(xwem-cl-pop-to-client ,cl))
 290               (vector "Info" `(xwem-client-info ,cl))
 291               (vector "Iconify" `(xwem-client-iconify ,cl))
 292               "--:singleDashedLine"
 293               (vector "Transpose ==>" `(xwem-cl-transpose ,cl))
 294               (vector "Transpose <==" `(xwem-cl-transpose ,cl '(4)))
 295               "--:singleDashedLine"
 296               (vector "Mark client" `(if (xwem-cl-marked-p ,cl)
 297                                          (xwem-client-unset-mark ,cl)
 298                                        (xwem-client-set-mark ,cl))
 299                       :style 'toggle :selected `(xwem-cl-marked-p ,cl))
 300               (when (and xwem-cl-mark-ring
 301                          (not (eq (xwem-cl-frame (car xwem-cl-mark-ring))
 302                                   (if (and (boundp 'xwem-tabber-click-frame)
 303                                            (xwem-frame-p xwem-tabber-click-frame))
 304                                       xwem-tabber-click-frame
 305                                     (xwem-frame-selected)))))
 306                 (vector "Attach"
 307                         `(xwem-win-set-cl ,(xwem-frame-selwin
 308                                             (if (and (boundp 'xwem-tabber-click-frame)
 309                                                      (xwem-frame-p xwem-tabber-click-frame))
 310                                                 xwem-tabber-click-frame
 311                                               (xwem-frame-selected)))
 312                                           ,(car xwem-cl-mark-ring))))
 313               (when (and xwem-cl-mark-ring
 314                          (not (eq (xwem-cl-frame (car xwem-cl-mark-ring))
 315                                   (if (and (boundp 'xwem-tabber-click-frame)
 316                                            (xwem-frame-p xwem-tabber-click-frame))
 317                                       xwem-tabber-click-frame
 318                                     (xwem-frame-selected)))))
 319                 (vector "Attach (unmark)"
 320                         `(progn
 321                            (xwem-win-set-cl ,(xwem-frame-selwin
 322                                               (if (and (boundp 'xwem-tabber-click-frame)
 323                                                        (xwem-frame-p xwem-tabber-click-frame))
 324                                                   xwem-tabber-click-frame
 325                                                 (xwem-frame-selected)))
 326                                             ,(car xwem-cl-mark-ring))
 327                            (xwem-client-unset-mark ,(car xwem-cl-mark-ring)))))
 328               "--:singleDashedLine"
 329               (vector "Run Copy" `(xwem-client-run-copy nil ,cl))
 330               (vector "Run Copy other win" `(xwem-client-run-copy-other-win nil ,cl))
 331               (vector "Run Copy other frame" `(xwem-client-run-copy-other-frame nil ,cl))
 332               "--:doubleLine"
 333               (when (XWMProtocol-set-p
 334                      (xwem-dpy) (xwem-hints-wm-protocols (xwem-cl-hints cl)) "WM_DELETE_WINDOW")
 335                 (vector "Close" `(xwem-client-kill ,cl)))
 336               (vector "Kill" `(xwem-client-kill ,cl '(4))))))
 337
 338 ;;;###autoload(autoload 'xwem-popup-auto-menu "xwem-mouse" nil t)
 339 (define-xwem-command xwem-popup-auto-menu (arg)
 340   "Popup menu generated by `xwem-generate-menu'.
 341 ARG - Not used yet."
 342   (xwem-interactive "_P")
 343
 344   (xwem-popup-menu (xwem-generate-menu)))
 345
 346 \f
 347 (provide 'xwem-mouse)
 348
 349 ;;; xwem-mouse.el ends here