cgit.sxemacs.org Git - packages/blob - xemacs-packages/text-modes/tpum.el

   1 ;;; tpum.el --- Popup menus in text mode.
   2
   3 ;; Copyright (C) 2003,2004,2005 by Zajcev Evgeny.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Maintainer: none, if you want be a maintainer please e-mail me.
   7 ;;             Temporary maintainer is Zajcev Evgeny.
   8 ;; Created: 2003/10/21
   9 ;; Keywords: tools, menus
  10 ;; X-CVS: $Id: tpum.el,v 1.1 2005-04-15 21:10:48 lg Exp $
  11
  12 ;; This file is NOT part of XEmacs.
  13
  14 ;; tpum.el is free software; you can redistribute it and/or modify it
  15 ;; under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; tpum.el is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  26 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  27 ;; 02111-1307, USA.
  28
  29 ;;; Synched up with: Not in FSF
  30
  31 ;;; Commentary:
  32 ;;
  33 ;; This package aimed to bring popup menus to be more usable for
  34 ;; keyboard friendly and mouse unfriendly people like me.  On the one
  35 ;; hand I like popup menus, because they just perfect and easy
  36 ;; interface for selective task, but on the other hand I hate them,
  37 ;; because I need to find my trackball, click ugly buttons, twiddle
  38 ;; ball to access menu item.  This pretty annoys.  Also popup menus
  39 ;; are not available in console.  tpum.el package makes popup menu
  40 ;; inlined in buffer, or creates transient XEmacs frame with temporary
  41 ;; buffer, where menu will be inlined.  So this makes possible to
  42 ;; control popup menus using keyboard and makes possible to popup
  43 ;; menus in console.  To start using tpum.el just include in your
  44 ;; ~/.emacs next:
  45
  46 ;; To enable tpum globally:
  47
  48 ;;    (require 'tpum)
  49 ;;    (tpum-global-mode 1)
  50
  51 ;; Or if you don't want tpum to be enable globally (default) do
  52 ;; something like:
  53
  54 ;;    (autoload 'tpum-minor-mode "Toggle tpum minor mode." t)
  55 ;;
  56 ;;  And then enable tpum minor mode by `M-x tpum-minor-mode RET'.
  57
  58 ;; To define new keys in order to emulate mouse events use something
  59 ;; like:
  60
  61 ;;    (define-tpum-key global-map (kbd "s-3") (kbd "<button3>"))
  62 ;;    (define-tpum-key global-map (kbd "C-s-3") (kbd "C-<button3>"))
  63 ;;    (define-tpum-key global-map (kbd "C-s-1") (kbd "C-<button1>"))
  64 ;;    (define-tpum-key global-map (kbd "s-!") (kbd "Sh-<button1>"))
  65 ;;    (define-tpum-key global-map (kbd "s-#") (kbd "Sh-<button3>"))
  66
  67 ;;; Customization:
  68 ;;
  69 ;; To change tpum styles use:
  70
  71 ;;    (setq tpum-cstyle 'tpum-style-pseudo)
  72 ;;    (setq tpum-menu-type 'inline)
  73
  74 ;; Best menu redering done if you are using fixed width fonts with
  75 ;; pseudo-graphic characters and 'tpum-style-pseudo as tpum style.
  76
  77 ;;; Bugs:
  78 ;;
  79 ;;  * With setnu-mode if poping up menu while point at the beginning
  80 ;;    of line, setnu's numbers gets invisible.
  81
  82 ;;  * If some menu uses broken :suffix keyword, tpum may render menu
  83 ;;    incorrectly.
  84
  85 ;;  * Control characters may temporaly change their displying type.
  86
  87 ;;; TODO:
  88 ;;
  89 ;; - Document code more carefuly
  90 ;; - Improve docstrings
  91 ;; - If it is possible to avoid overriding local map - avoid it
  92
  93 ;;; Code:
  94 ;;
  95 \f
  96 (eval-when-compile
  97   (require 'cl))
  98
  99 (defgroup tpum nil
 100   "Popup menus in text mode."
 101   :prefix "tpum-"
 102   :group 'environment)
 103
 104 (defcustom tpum-global-mode nil
 105   "*Non-nil mean tpum is enabled globally."
 106   :type 'boolean
 107   :group 'tpum)
 108
 109 (defgroup tpum-faces nil
 110   "Faces used in tpum."
 111   :prefix "tpum-"
 112   :group 'tpum
 113   :group 'faces)
 114
 115 (defface tpum-active-face
 116   '((((background light))
 117      (:foreground "black"))
 118     (((background dark))
 119      (:foreground "brightwhite")))
 120   "*Face for displaying activated menu items."
 121   :group 'tpum-faces)
 122
 123 (defface tpum-deactive-face
 124   '((((background dark))
 125      (:foreground "darkgrey"))
 126     (((background light))
 127      (:foreground "darkgrey")))
 128   "*Face for displaying deactivated menu items."
 129   :group 'tpum-faces)
 130
 131 (defface tpum-title-face
 132   '((((type tty) (class color))
 133      (:foreground "red" :bold t))
 134     (((type tty))
 135      (:bold t))
 136
 137     (((type x) (class color))
 138      (:foreground "red4" :bold t))
 139     (((type x))
 140      (:bold t)))
 141   "*Face to display title of menu."
 142   :group 'tpum-faces)
 143
 144 (defface tpum-toggled-face
 145   '((t (:bold t)))
 146   "*Face for toggle items, whos state is on."
 147   :group 'tpum-faces)
 148
 149 (defcustom tpum-menu-type 'inline
 150   "Type of `popup-menu' behaviour.
 151 'inline - To inline in current buffer.
 152 'frame  - To pop Emacs frame."
 153   :type '(choice (const :tag "Inline" inline)
 154                  (const :tag "Frame" frame))
 155   :group 'tpum)
 156
 157 (defcustom tpum-auto-submenu-mode nil
 158   "*Non-nil mean auto opening submenus at point."
 159   :type 'boolean
 160   :group 'tpum)
 161
 162 (defcustom tpum-isearch-global-scope t
 163   "*Non-nil mean that isearch will be performed in any shown tpums."
 164   :type 'boolean
 165   :group 'tpum)
 166
 167 (defcustom tpum-truncate-lines nil
 168   "*Value of `truncate-lines' while in `tpum-mode'."
 169   :type 'boolean
 170   :group 'tpum)
 171
 172 (defcustom tpum-cstyle 'tpum-style-plain
 173   "*Style to be used."
 174   :type 'symbol
 175   :group 'tpum)
 176
 177 (unless (fboundp 'get-face)
 178   (defalias 'get-face 'identity))
 179
 180 (defface tpum-plain-face1
 181   `((((class color))
 182      (:foreground "blue" :bold t)))
 183   "Border face for plain style."
 184   :group 'tpum-faces)
 185
 186 (defvar tpum-plain-face (get-face 'tpum-plain-face1))
 187
 188 (defface tpum-pseudo-face1
 189   `((((class color))
 190      (:foreground "blue" :bold t))
 191     (t (:bold t)))
 192   "Border face for pseudo style."
 193   :group 'tpum-face)
 194
 195 (defvar tpum-pseudo-face (get-face 'tpum-pseudo-face1))
 196
 197 (defvar tpum-frame-face (get-face 'blue))
 198
 199 (defcustom tpum-max-height 80
 200   "*Maximum height of popup menu."
 201   :type 'number
 202   :group 'tpum)
 203
 204 (defcustom tpum-search-ahead-mode t
 205   "*Non-nil mean to use type ahead search mode."
 206   :type 'boolean
 207   :group 'tpum)
 208
 209 (defcustom tpum-load-hook nil
 210   "*Hooks to run after tpum loaded."
 211   :type 'hook
 212   :group 'tpum)
 213
 214 ;; FSFmacs
 215 (unless (fboundp 'set-keymap-default-binding)
 216   (defun set-keymap-default-binding (map cmd)
 217     (define-key map [t] cmd)))
 218
 219 (defvar tpum-mode-map
 220   (let ((map (make-sparse-keymap)))
 221     (set-keymap-default-binding map 'tpum-default-command)
 222     (define-key map (kbd "C-u") 'universal-argument)
 223     (define-key map (kbd "C-1") 'digit-argument)
 224     (define-key map (kbd "C-2") 'digit-argument)
 225     (define-key map (kbd "C-3") 'digit-argument)
 226     (define-key map (kbd "C-4") 'digit-argument)
 227     (define-key map (kbd "C-5") 'digit-argument)
 228     (define-key map (kbd "C-6") 'digit-argument)
 229     (define-key map (kbd "C-7") 'digit-argument)
 230     (define-key map (kbd "C-8") 'digit-argument)
 231     (define-key map (kbd "C-9") 'digit-argument)
 232     (define-key map (kbd "C-0") 'digit-argument)
 233     (define-key map (kbd "M-1") 'digit-argument)
 234     (define-key map (kbd "M-2") 'digit-argument)
 235     (define-key map (kbd "M-3") 'digit-argument)
 236     (define-key map (kbd "M-4") 'digit-argument)
 237     (define-key map (kbd "M-5") 'digit-argument)
 238     (define-key map (kbd "M-6") 'digit-argument)
 239     (define-key map (kbd "M-7") 'digit-argument)
 240     (define-key map (kbd "M-8") 'digit-argument)
 241     (define-key map (kbd "M-9") 'digit-argument)
 242     (define-key map (kbd "M-0") 'digit-argument)
 243
 244     (define-key map (kbd "C-g") 'tpum-quit)
 245     (define-key map (kbd "C-G") 'tpum-global-quit)
 246     ;; Motion
 247     (define-key map (kbd "C-l") 'recenter)
 248     (define-key map (kbd "C-n") 'tpum-next)
 249     (define-key map (kbd "<up>") 'tpum-prev)
 250     (define-key map (kbd "C-p") 'tpum-prev)
 251     (define-key map (kbd "<down>") 'tpum-next)
 252     (define-key map (kbd "M->") 'tpum-goto-last)
 253     (define-key map (kbd "M-<") 'tpum-goto-first)
 254
 255     (define-key map (kbd "M-RET") 'tpum-submenu-toggle)
 256     (define-key map (kbd "C-RET") 'tpum-submenu-toggle)
 257     (define-key map (kbd "M-t") 'tpum-auto-submenu-toggle)
 258     (define-key map (kbd "RET") 'tpum-select)
 259 ;    (define-key map (kbd "M-s") 'tpum-submenu-show)
 260 ;    (define-key map (kbd "M-c") 'tpum-submenu-hide)
 261
 262     ;; Searching
 263     (define-key map (kbd "C-t") 'tpum-isearch-global-toggle)
 264     (define-key map (kbd "C-s") 'isearch-forward)
 265     (define-key map (kbd "C-r") 'isearch-backward)
 266
 267     ;; Misc
 268     (define-key map (kbd "<f1>") 'tpum-help)
 269     (define-key map (kbd "C-h") 'tpum-help)
 270     (define-key map (kbd "M-h") 'tpum-describe-bindings)
 271     (define-key map (kbd "M-x") 'execute-extended-command)
 272     (define-key map (kbd "M-:") 'eval-expression)
 273     (define-key map (kbd "C-x 1") 'delete-other-windows)
 274     map)
 275   "Keymap used while in tpum.")
 276
 277 \f
 278 (defun tpum-da-face (isactive)
 279   "Return face according to ISACTIVE."
 280   (if isactive 'tpum-active-face 'tpum-deactive-face))
 281
 282 (defstruct tpum-style
 283   border-face                           ; face used to draw borders
 284   toggle-dis toggle-act radio-dis radio-act submenu
 285   title-sep title-sl title-sr
 286   left right top bottom
 287   left-top left-bottom
 288   right-top right-bottom
 289   right-bot2 left-bot2 line-bot2 center-bot2 ;when menu is not fully displayed
 290
 291   ;; delimiters
 292   single-line double-line
 293   single-dashed-line double-dashed-line
 294   no-line
 295   right-sl right-dl right-sdl right-ddl right-nl
 296   left-sl left-dl left-sdl left-ddl left-nl)
 297
 298 (defvar tpum-style-plain
 299   (make-tpum-style
 300    :border-face tpum-plain-face
 301    :toggle-dis "[ ] " :toggle-act "[x] " :radio-dis "( ) " :radio-act "(*) "
 302    :submenu " >>"
 303    :title-sep "=" :title-sl "|" :title-sr "|"
 304    :left "|" :right "|" :top "-" :bottom "-"
 305    :left-top "." :left-bottom "`" :right-top "." :right-bottom "'"
 306    :right-bot2 "|" :left-bot2 "|" :line-bot2 "." :center-bot2 "vvv"
 307
 308    :single-line "-" :double-line "=" :single-dashed-line "- -"
 309    :double-dashed-line "= =" :no-line " "
 310    :right-sl "|" :right-dl "|" :right-sdl "|" :right-ddl "|" :right-nl "|"
 311    :left-sl "|" :left-dl "|" :left-sdl "|" :left-ddl "|" :left-nl "|")
 312   "Plain text style.")
 313
 314 (defvar tpum-style-pseudo
 315   (make-tpum-style
 316    :border-face  tpum-pseudo-face
 317    :toggle-dis "[ ] " :toggle-act "[x] " :radio-dis "( ) " :radio-act "(*) "
 318    :submenu " >>"
 319    :title-sep "=" :title-sl "\x15" :title-sr "\x16"
 320    :left "\x19" :right "\x19" :top "\x12" :bottom "\x12"
 321    :left-top "\x0d" :left-bottom "\x0e" :right-top "\x0c" :right-bottom "\x0b"
 322    :right-bot2 "|" :left-bot2 "|" :line-bot2 "." :center-bot2 "vvv"
 323
 324    :single-line "\x12" :double-line "=" :single-dashed-line "- -"
 325    :double-dashed-line "= =" :no-line " "
 326    :right-sl "\x16" :right-dl "\x16" :right-sdl "|" :right-ddl "|" :right-nl "|"
 327    :left-sl "\x15" :left-dl "\x15" :left-sdl "|" :left-ddl "|" :left-nl "|")
 328   "Pseudo graphics style.")
 329
 330 (defvar tpum-style-frame
 331   (make-tpum-style
 332    :border-face tpum-frame-face
 333    :toggle-dis "[ ] " :toggle-act "[x] " :radio-dis "( ) " :radio-act "(*) "
 334    :submenu " >>"
 335    :title-sep "=" :title-sl "" :title-sr ""
 336    :left "" :right "" :top "-" :bottom "-"
 337    :left-top "" :left-bottom "" :right-top "" :right-bottom ""
 338    :right-bot2 "" :left-bot2 "" :line-bot2 "" :center-bot2 "vvv"
 339
 340    :single-line "-" :double-line "=" :single-dashed-line "- -"
 341    :double-dashed-line "= =" :no-line " "
 342    :right-sl "" :right-dl "" :right-sdl "" :right-ddl "" :right-nl ""
 343    :left-sl "" :left-dl "" :left-sdl "" :left-ddl "" :left-nl "")
 344   "Separate frame style.")
 345
 346 (defun tpum-style-toggle (&optional act)
 347   "Return toggle button, if ACT non-nil toggle button is on."
 348   (if act
 349       (tpum-style-toggle-act (eval tpum-cstyle))
 350     (tpum-style-toggle-dis (eval tpum-cstyle))))
 351
 352 (defun tpum-style-radio (&optional act)
 353   "Return radio button, if ACT is non-nil - radio button is on."
 354   (if act
 355       (tpum-style-radio-act (eval tpum-cstyle))
 356     (tpum-style-radio-dis (eval tpum-cstyle))))
 357
 358 (defmacro tpum-defmacro (new old)
 359   "Define NEW accesor using OLD accessor."
 360   `(defun ,new ()
 361      (,old (eval tpum-cstyle))))
 362
 363 (tpum-defmacro tpum-st-bface tpum-style-border-face)
 364 (tpum-defmacro tpum-st-td tpum-style-toggle-dis)
 365 (tpum-defmacro tpum-st-ta tpum-style-toggle-act)
 366 (tpum-defmacro tpum-st-rd tpum-style-radio-dis)
 367 (tpum-defmacro tpum-st-ra tpum-style-radio-act)
 368 (tpum-defmacro tpum-st-sub tpum-style-submenu)
 369 (tpum-defmacro tpum-st-ts tpum-style-title-sep)
 370 (tpum-defmacro tpum-st-tsl tpum-style-title-sl)
 371 (tpum-defmacro tpum-st-tsr tpum-style-title-sr)
 372 (tpum-defmacro tpum-st-l tpum-style-left)
 373 (tpum-defmacro tpum-st-r tpum-style-right)
 374 (tpum-defmacro tpum-st-t tpum-style-top)
 375 (tpum-defmacro tpum-st-b tpum-style-bottom)
 376 (tpum-defmacro tpum-st-lt tpum-style-left-top)
 377 (tpum-defmacro tpum-st-lb tpum-style-left-bottom)
 378 (tpum-defmacro tpum-st-lb2 tpum-style-left-bot2)
 379 (tpum-defmacro tpum-st-rt tpum-style-right-top)
 380 (tpum-defmacro tpum-st-rb tpum-style-right-bottom)
 381 (tpum-defmacro tpum-st-rb2 tpum-style-right-bot2)
 382 (tpum-defmacro tpum-st-lbot2 tpum-style-line-bot2)
 383 (tpum-defmacro tpum-st-cbot2 tpum-style-center-bot2)
 384 (tpum-defmacro tpum-st-sl tpum-style-single-line)
 385 (tpum-defmacro tpum-st-dl tpum-style-double-line)
 386 (tpum-defmacro tpum-st-sdl tpum-style-single-dashed-line)
 387 (tpum-defmacro tpum-st-ddl tpum-style-double-dashed-line)
 388 (tpum-defmacro tpum-st-noline tpum-style-no-line)
 389 (tpum-defmacro tpum-st-rsl tpum-style-right-sl)
 390 (tpum-defmacro tpum-st-rdl tpum-style-right-dl)
 391 (tpum-defmacro tpum-st-rsdl tpum-style-right-sdl)
 392 (tpum-defmacro tpum-st-rddl tpum-style-right-ddl)
 393 (tpum-defmacro tpum-st-rnl tpum-style-right-nl)
 394 (tpum-defmacro tpum-st-lsl tpum-style-left-sl)
 395 (tpum-defmacro tpum-st-ldl tpum-style-left-dl)
 396 (tpum-defmacro tpum-st-lsdl tpum-style-left-sdl)
 397 (tpum-defmacro tpum-st-lddl tpum-style-left-ddl)
 398 (tpum-defmacro tpum-st-lnl tpum-style-left-nl)
 399
 400 (defstruct tpum-ctx
 401   local-mode-map local-mode-name
 402   overriding-local-map
 403   recursive-p post-command-hooks truncate-lines
 404   after-change-functions before-change-functions
 405   undo-list selective-display
 406   buffer point tmpoint column width offset height atomics-list todel-list
 407   frame child-ctx parent-ctx
 408
 409   plist)                                ; user defined plist
 410
 411 ;;; Functions
 412 (defun tpum-plist-put (ctx prop val)
 413   "In CTX put property PROP with value VAL."
 414   (setf (tpum-ctx-plist ctx) (plist-put (tpum-ctx-plist ctx) prop val)))
 415
 416 (defun tpum-plist-get (ctx prop)
 417   "In CTX get value of property PROP."
 418   (plist-get (tpum-ctx-plist ctx) prop))
 419
 420 (defun tpum-plist-rem (ctx prop)
 421   "In CTX remove property PROP."
 422   (setf (tpum-ctx-plist ctx) (plist-remprop (tpum-ctx-plist ctx) prop)))
 423
 424 (defun tpum-delete-region (tpum-ctx start end)
 425   "In TPUM-CTX delete region from START to END.
 426 Check for overlaps inside todel-list in TPUM-CTX."
 427   (push (cons start end) (tpum-ctx-todel-list tpum-ctx)))
 428
 429 (defun tpum-get-context (&optional point)
 430   "Return tpum context at POINT."
 431   (get-text-property (or point (point)) 'tpum-ctx))
 432
 433 (defun tpum-get-global-context (&optional tpum-ctx)
 434   "Return global tpum context.
 435 Optionally local tpum context TPUM-CTX can be specified."
 436   (let ((ctx (or tpum-ctx (tpum-get-context))))
 437     (while (tpum-get-context (tpum-ctx-point ctx))
 438       (setq ctx (tpum-get-context (tpum-ctx-point ctx))))
 439     ctx))
 440
 441 (defun tpum-line-num (&optional pnt)
 442   "Get number of line at PNT.
 443 PNT default to `(point)'."
 444   (let ((p (or pnt (point))))
 445     (count-lines (point-min) p)))
 446
 447 (defun tpum-current-column ()
 448   "Return current column skiping invisible chars."
 449   (let ((spnt (point))
 450         (col 0))
 451     (save-excursion
 452       (beginning-of-line)
 453       (while (< (point) spnt)
 454         (unless (and (get-text-property (point) 'invisible)
 455                      (not (get-text-property (point) 'tpum-invisible)))
 456           (setq col (1+ col)))
 457         (forward-char 1)))
 458     col))
 459
 460 (defun tpum-forward-char (num)
 461   "Forward NUM chars skiping invisible chars."
 462   (let ((fcfun (if (>= num 0) 'forward-char 'backward-char)))
 463     (when (< num 0)
 464       (setq num (- num)))
 465
 466     ;; First skip any invisible characters at point
 467     (while (get-text-property (point) 'invisible)
 468       (funcall fcfun 1))
 469
 470     (while (> num 0)
 471       (funcall fcfun 1)
 472       (unless (and (get-text-property (point) 'invisible)
 473                    (not (get-text-property (point) 'tpum-invisible)))
 474         (setq num (1- num))))))
 475
 476 (defun tpum-next-line (num)
 477   "Move NUM next lines in tpum's CTX."
 478   (let ((ccol (tpum-current-column)))
 479     (forward-line num)
 480     (tpum-forward-char ccol)))
 481
 482 (defun tpum-move-to-offset (&optional tpum-context)
 483   "In TPUM-CONTEXT move point to offset column."
 484   (let ((ctx (or tpum-context (tpum-get-context))))
 485     (when (tpum-ctx-p ctx)
 486       (beginning-of-line)
 487       (tpum-forward-char (+ (tpum-ctx-column ctx) (tpum-ctx-offset ctx) -1)))))
 488
 489 (defun tpum-get-mi (&optional point)
 490   "Get menu item at POINT."
 491   (get-text-property (or point (point)) 'tpum-menu-item))
 492
 493 (defun tpum-mi-help (mi)
 494   "Display menu item MI help string in minibuffer."
 495   (let ((help (tpum-get-keyword mi :help)))
 496     (when help
 497       (message help))))
 498
 499 (defun tpum-move-point (arg &optional ctx)
 500   "Move point ARG times down.
 501 If CTX is ommited `tpum-get-context' will be used."
 502   (let ((tpum-ctx (or ctx (tpum-get-context)))
 503         (sarg arg)
 504         (lines-to-go 0)
 505         (not-break t))
 506     (save-excursion
 507       (catch 'lout
 508         (while not-break
 509           (condition-case nil
 510               (tpum-next-line (if (> sarg 0) 1 -1))
 511             (t (throw 'lout (setq lines-to-go 0))))
 512
 513           (when (not (eq (tpum-get-context) tpum-ctx))
 514             (throw 'lout (setq lines-to-go 0)))
 515
 516           (let ((mi (tpum-get-mi)))
 517             (when (and mi (tpum-mi-active-p tpum-ctx mi))
 518               (setq arg (if (> arg 0) (1- arg) (1+ arg)))
 519               (when (= arg 0)
 520                 (setq not-break nil))))
 521           (setq lines-to-go (1+ lines-to-go)))
 522         ))
 523
 524     (if (= lines-to-go 0)
 525         (error "TPUM: can't move")
 526       (tpum-next-line (if (> sarg 0) lines-to-go (- lines-to-go))))
 527     ))
 528
 529 ;;; Interactive commands
 530 (defun tpum-help ()
 531   "Show tpum help in minibuffer."
 532   (interactive)
 533   (message
 534    (substitute-command-keys
 535     (concat
 536      "`\\[tpum-describe-bindings]':bindings `\\[tpum-help]':help "
 537      "`\\[tpum-next]':next `\\[tpum-prev]':prev `\\[tpum-quit]':quit"))))
 538
 539 (defun tpum-describe-bindings ()
 540   "Describe TPUM bindings."
 541   (interactive)
 542
 543   (with-displaying-help-buffer
 544    (lambda ()
 545      (let ((local (current-local-map)))
 546        (set-buffer standard-output)
 547        (insert "Key Bindings for TPUM:\n")
 548        (describe-bindings-internal local)))
 549    "bindings for TPUM mode"))
 550
 551 (defun tpum-next (arg)
 552   "Goto ARG next visible items."
 553   (interactive "p")
 554
 555   (tpum-submenu-hide)
 556   (condition-case nil
 557       (tpum-move-point arg)
 558     (t (call-interactively 'tpum-goto-first)))
 559   (tpum-mi-help (tpum-get-mi))
 560   (when tpum-auto-submenu-mode
 561     (tpum-submenu-show)))
 562
 563 (defun tpum-prev (arg)
 564   "Goto ARG previous visible items."
 565   (interactive "p")
 566
 567   (tpum-submenu-hide)
 568   (condition-case nil
 569       (tpum-move-point (- arg))
 570     (t (call-interactively 'tpum-goto-last)))
 571   (tpum-mi-help (tpum-get-mi))
 572   (when tpum-auto-submenu-mode
 573     (tpum-submenu-show)))
 574
 575 (defun tpum-goto-first ()
 576   "Go to the first menu item."
 577   (interactive)
 578
 579   (tpum-submenu-hide)
 580   (while (condition-case nil
 581              (progn (tpum-move-point -1) t)
 582            (t nil)))
 583   (when tpum-auto-submenu-mode
 584     (tpum-submenu-show))
 585   (tpum-mi-help (tpum-get-mi)))
 586
 587 (defun tpum-goto-last ()
 588   "Go to the last menu item."
 589   (interactive)
 590
 591   (tpum-submenu-hide)
 592   (while (condition-case nil
 593              (progn (tpum-move-point 1) t)
 594            (t nil)))
 595
 596   (when tpum-auto-submenu-mode
 597     (tpum-submenu-show))
 598   (tpum-mi-help (tpum-get-mi)))
 599
 600 (defun tpum-auto-submenu-toggle ()
 601   "Toggle `tpum-auto-submenu-mode'."
 602   (interactive)
 603   (setq tpum-auto-submenu-mode (not tpum-auto-submenu-mode))
 604
 605   (if tpum-auto-submenu-mode
 606       (message "tpum: Auto submenus mode on.")
 607     (message "tpum: Auto submenus mode off."))
 608
 609   (when (interactive-p)
 610     (if tpum-auto-submenu-mode
 611         (tpum-submenu-show)
 612       (tpum-submenu-hide))))
 613
 614 (defun tpum-isearch-global-toggle ()
 615   "Toggle `tpum-isearch-global-scope'."
 616   (interactive)
 617   (setq tpum-isearch-global-scope (not tpum-isearch-global-scope))
 618   (if tpum-isearch-global-scope
 619       (message "tpum: Global isearch mode on.")
 620     (message "tpum: Global isearch mode off.")))
 621
 622 (defvar tpum-isearch-mode nil
 623   "Non nil mean that isearch uses tpum's searcher.")
 624
 625 (defun tpum-search-data (searcher what &optional bound noerror count)
 626   "Use SEARCHER to search WHAT in tpum menu after or before point.
 627 If SEARCHER contain 'backward' search performed before point.
 628 BOUND, NOERROR and COUNT are described in `search-forward'."
 629   (let* ((cctx (tpum-get-context))
 630          (origin (point))
 631          (cnt (or count 1))
 632          (step (cond ((= cnt 0) 0)
 633                      ((> cnt 0) 1)
 634                      (t (setq cnt (- cnt)) -1)))
 635          found next sstart send mi)
 636     (unless (zerop step)
 637       (while (and (not found)
 638                   (setq next (funcall searcher what bound t step)))
 639         (setq sstart (match-beginning 0)
 640               send (match-end 0)
 641               mi (tpum-get-mi))
 642
 643         (if (= sstart send)
 644             (setq found t)
 645           (goto-char next)
 646           (when (and (if tpum-isearch-global-scope
 647                          t
 648                        (eq (tpum-get-context) cctx))
 649                      mi (tpum-mi-active-p cctx mi))
 650             (setq found t)))))
 651
 652     (cond ((null found)
 653            (setq next origin
 654                  send origin))
 655           ((= step (if (string-match "backward" (symbol-name searcher)) 1 -1))
 656            (setq next send
 657                  send sstart))
 658           (t
 659            (setq next sstart)))
 660     (goto-char next)
 661     ;; Setup the returned value and the `match-data' or maybe fail!
 662     (funcall searcher what send noerror step)))
 663
 664 (defun tpum-search-forward (what &optional bound noerror count)
 665   "Search tpum menu item forward from point for string WHAT.
 666 For optional BOUND, NOERROR and COUNT see description for `search-forward'."
 667   (tpum-search-data #'search-forward what bound noerror count))
 668
 669 (defun tpum-search-backward (what &optional bound noerror count)
 670   "Search tpum menu item backward from point for string WHAT.
 671 For optional BOUND, NOERROR and COUNT see description for `search-backward'."
 672   (tpum-search-data #'search-backward what bound noerror count))
 673
 674 (defmacro tpum-define-search-advice (searcher)
 675   "Advice the built-in SEARCHER function to do tpum search.
 676 That is to call the tpum searcher when variables
 677 `isearch-mode' and `tpum-isearch-mode' are non-nil."
 678   (let ((tpum-searcher (intern (format "tpum-%s" searcher))))
 679     `(defadvice ,searcher (around unused activate)
 680        (if (and isearch-mode tpum-isearch-mode
 681                 ;; The following condition ensure to do a tpum
 682                 ;; search on the `isearch-string' only!
 683                 (string-equal (ad-get-arg 0) isearch-string))
 684            (let ((old-isearch-mode tpum-isearch-mode))
 685              (unwind-protect
 686                  ;; Temporarily set `tpum-isearch-mode' to
 687                  ;; nil to avoid an infinite recursive call of the
 688                  ;; tpum search function!
 689                  (setq tpum-isearch-mode nil
 690                        ad-return-value
 691                        (funcall #',tpum-searcher
 692                                 (ad-get-arg 0) ; string
 693                                 (ad-get-arg 1) ; bound
 694                                 (ad-get-arg 2) ; no-error
 695                                 (ad-get-arg 3))) ; count
 696                (setq tpum-isearch-mode old-isearch-mode)))
 697          ad-do-it))))
 698
 699 (tpum-define-search-advice search-forward)
 700 (tpum-define-search-advice search-backward)
 701
 702 (defun tpum-isearch-end-hook ()
 703   "To be used in `isearch-mode-end-hook'."
 704   (when tpum-isearch-mode
 705     ;; Hide submenu if needed
 706     (when (eq (tpum-get-context)
 707               (save-excursion
 708                 (goto-char isearch-opoint)
 709                 (tpum-get-context)))
 710       (save-excursion
 711         (goto-char isearch-opoint)
 712         (tpum-submenu-hide)))
 713
 714     (tpum-move-to-offset)
 715     (when tpum-auto-submenu-mode
 716       (tpum-submenu-show))
 717     (tpum-mi-help (tpum-get-mi))))
 718
 719 (defun tpum-search-symbol (chr)
 720   "Begin to search for CHR."
 721   (let ((executing-kbd-macro t))        ; do not make isearch to be modal
 722     (isearch-mode t nil nil (not (interactive-p)))
 723     (isearch-process-search-string
 724      (char-to-string chr)
 725      (isearch-text-char-description chr))))
 726
 727 (defun tpum-default-command (keys)
 728   "Search ahead after KEYS presses."
 729   (interactive (list (this-command-keys)))
 730   (let* ((evk (and (= (length keys) 1)
 731                    (key-press-event-p (aref keys 0))
 732                    (null (event-modifiers (aref keys 0)))
 733                    (event-key (aref keys 0))))
 734          (kchr evk))
 735     (if (and tpum-search-ahead-mode (characterp kchr))
 736         (tpum-search-symbol kchr)
 737
 738       (if (eq (event-type (aref keys 0)) 'button-release)
 739           ;; Button release event are ok
 740           nil
 741         (signal 'undefined-keystroke-sequence (list keys))))))
 742
 743 (defun tpum-quit (&optional ctx)
 744   "Exit tpum mode, using tpum CTX."
 745   (interactive)
 746   (let ((tpum-ctx (or ctx (tpum-get-context)))
 747         (buffer-read-only nil))
 748
 749     (unless (tpum-ctx-p ctx)
 750       (tpum-submenu-hide))
 751     (if (null tpum-ctx)
 752         (error "No tpum context at point")
 753
 754       (if (tpum-ctx-frame tpum-ctx)
 755           (select-frame (tpum-ctx-frame tpum-ctx))
 756
 757         ;; Restore things
 758         (tpum-restore-todel-atomics tpum-ctx))
 759
 760       (setq tpum-isearch-mode (cdr tpum-isearch-mode))
 761
 762       (setq post-command-hook (tpum-ctx-post-command-hooks tpum-ctx))
 763       (setq truncate-lines (tpum-ctx-truncate-lines tpum-ctx))
 764       (setq after-change-functions (tpum-ctx-after-change-functions tpum-ctx))
 765       (setq before-change-functions (tpum-ctx-before-change-functions tpum-ctx))
 766       (setq buffer-undo-list (tpum-ctx-undo-list tpum-ctx))
 767       (setq selective-display (tpum-ctx-selective-display tpum-ctx))
 768
 769       (setq overriding-local-map
 770             (tpum-ctx-overriding-local-map tpum-ctx))
 771       (use-local-map (tpum-ctx-local-mode-map tpum-ctx))
 772       (setq mode-name (tpum-ctx-local-mode-name tpum-ctx))
 773
 774       (goto-char (tpum-ctx-point tpum-ctx))
 775       (set-buffer-modified-p nil)
 776
 777       ;; ctl-arrow used by pseudo style
 778       (when (tpum-plist-get tpum-ctx 'ctl-arrow)
 779         (setq ctl-arrow (tpum-plist-get tpum-ctx 'ctl-arrow)))
 780
 781       (when (tpum-ctx-recursive-p tpum-ctx)
 782         (exit-recursive-edit))
 783
 784       ;; Generate fake misc-user event, to make imenu work
 785       (setq unread-command-event
 786             (make-event 'misc-user '(x 0 y 0 button 1 function ignore)))
 787
 788       (when (tpum-ctx-frame tpum-ctx)
 789         (delete-frame (tpum-ctx-frame tpum-ctx)))
 790
 791       ;; Select parent frame if any
 792       (let ((pctx (tpum-ctx-parent-ctx tpum-ctx)))
 793         (when (tpum-ctx-p pctx)
 794           ;; Unset child ctx and select parent's frame
 795           (setf (tpum-ctx-child-ctx pctx) nil)
 796           (when (tpum-ctx-frame pctx)
 797             (focus-frame (tpum-ctx-frame pctx)))))
 798
 799       (when (interactive-p)
 800         (message "TPUM exit.")))))
 801
 802 (defun tpum-global-quit ()
 803   "Globally quit tpum."
 804   (interactive)
 805   (while (tpum-get-context)
 806     (tpum-quit)))
 807
 808 (defun tpum-submenu-show ()
 809   "Show submenu if any."
 810   (interactive)
 811   (let ((tmi (tpum-get-mi))
 812         (tpum-auto-submenu-mode nil)
 813         nctx pctx)
 814     (when (and tmi (consp tmi))
 815       (save-excursion
 816         (tpum-select)
 817         (setq nctx (tpum-get-context)))
 818       (setq pctx (tpum-ctx-parent-ctx nctx))
 819       (when (and (tpum-ctx-p pctx) (tpum-ctx-frame pctx))
 820         (focus-frame (tpum-ctx-frame pctx))))))
 821
 822 (defun tpum-submenu-hide ()
 823   "Hide submenu if any."
 824   (interactive)
 825   (let* ((cctx (tpum-get-context))
 826          (smctx (tpum-ctx-child-ctx cctx)))
 827     (when (tpum-ctx-p smctx)
 828       (save-excursion
 829         (tpum-quit smctx)))))
 830
 831 (defun tpum-submenu-toggle ()
 832   "Show or hide submenu."
 833   (interactive)
 834   (if (tpum-ctx-child-ctx (tpum-get-context))
 835       (tpum-submenu-hide)
 836     (tpum-submenu-show)))
 837
 838 (defun tpum-submenu-select ()
 839   "Select submenu."
 840   (interactive)
 841   (let ((smctx (tpum-ctx-child-ctx (tpum-get-context))))
 842     (when (tpum-ctx-p smctx)
 843       (if (tpum-ctx-frame smctx)
 844           (focus-frame (tpum-ctx-frame smctx))
 845
 846         (goto-char (tpum-ctx-tmpoint smctx))
 847         (tpum-move-point 1 smctx)
 848         (tpum-move-to-offset smctx))
 849
 850       (when tpum-auto-submenu-mode
 851         (tpum-submenu-show)))))
 852
 853 (defun tpum-apply-callback (cbfun)
 854   "Apply menuitem's call back function CBFUN."
 855   (cond ((listp cbfun) (eval cbfun))
 856         ((commandp cbfun) (command-execute cbfun))
 857         ((symbolp cbfun) (funcall cbfun))
 858         (t nil)))
 859
 860 (defvar tpum-frame-y-offset 42 "Hack")
 861 (defvar tpum-frame-x-offset 6 "Hack")
 862
 863 (defun tpum-select ()
 864   "Select current menu item."
 865   (interactive)
 866   (let ((tpum-ctx (tpum-get-context))
 867         (mi (tpum-get-mi))
 868         nctx)
 869     (if (not mi)
 870         (progn
 871           (beep)
 872           (message "TPUM: No menu item under cursor."))
 873
 874       (cond ((listp mi)                 ;submenu
 875              (if (tpum-ctx-child-ctx tpum-ctx)
 876                  (call-interactively 'tpum-submenu-select)
 877
 878                (setq nctx
 879                      (if (tpum-ctx-frame tpum-ctx)
 880                          (let* ((tfr (tpum-ctx-frame tpum-ctx))
 881                                 (tpum-frame-y-offset 0) ; hack
 882                                 (tpum-frame-x-offset 2)) ; hack
 883                            (tpum-frame-do-menu
 884                             mi
 885                             (cons (+ (frame-property tfr 'left)
 886                                      (frame-pixel-width tfr)
 887                                      tpum-frame-x-offset)
 888                                   (+ (frame-property tfr 'top)
 889                                      (cdr (tpum-frame-get-coord))))))
 890
 891                        (tpum-do-menu mi (save-excursion
 892                                           (tpum-next-line -1)
 893                                           (tpum-forward-char
 894                                            (- (tpum-ctx-width tpum-ctx)
 895                                               (tpum-ctx-offset tpum-ctx) -1))
 896                                           (point)))))
 897                (setf (tpum-ctx-child-ctx tpum-ctx) nctx)
 898                (setf (tpum-ctx-parent-ctx nctx) tpum-ctx)))
 899
 900             ((vectorp mi)               ; Normal menu-item
 901              (tpum-global-quit)
 902              (tpum-apply-callback (cadr (append mi nil))))
 903
 904             (t (message "Unknown menu item type."))))))
 905
 906 (defun tpum-mode (tpum-ctx)
 907   "Enter tpum mode, using TPUM-CTX."
 908   (setf (tpum-ctx-local-mode-map tpum-ctx) (current-local-map))
 909   (setf (tpum-ctx-local-mode-name tpum-ctx) mode-name)
 910   (setf (tpum-ctx-overriding-local-map tpum-ctx)
 911         overriding-local-map)
 912
 913   (setq overriding-local-map tpum-mode-map)
 914   (use-local-map tpum-mode-map)
 915   (setq tpum-isearch-mode (cons t tpum-isearch-mode))
 916
 917   (set-buffer-modified-p nil)
 918
 919   (add-hook 'isearch-mode-end-hook 'tpum-isearch-end-hook))
 920
 921 (defun tpum-safe-delrec (tpum-ctx width height &optional startpoint)
 922   "In TPUM-CTX safe delete rectangle with sizes WIDTH HEIGHT.
 923 Starting from STARTPOINT, if ommited `point' will be used."
 924   (let (ccol ep)
 925     (save-excursion
 926       (and startpoint (goto-char startpoint))
 927       (setq ccol (tpum-current-column))
 928       (while (> height 0)
 929         ;; XXX Untabify line
 930         (funcall #'(lambda (beg end)
 931                      (save-excursion
 932                        (narrow-to-region beg end)
 933                        (goto-char beg)
 934                        (while (re-search-forward "\t" nil t)
 935                          (let ((indent-tabs-mode nil))
 936                            (replace-match (make-string tab-width ?\x20))))
 937                        (widen)))
 938                  (progn (beginning-of-line) (point))
 939                  (progn (end-of-line) (point)))
 940
 941         ;; Now we are at the end of line
 942         (setq ep (tpum-current-column))
 943         (when (< (- ep ccol) width)
 944           (end-of-line)
 945           (tpum-delete-region
 946            tpum-ctx
 947            (point-marker)
 948            (progn (insert (make-string (- width (- ep ccol)) ?\x20))
 949                   (point-marker))))
 950
 951         (beginning-of-line)
 952         (tpum-forward-char ccol)
 953         (push (cons (point-marker)
 954                     (save-excursion
 955                       (forward-char width)
 956                       (point-marker)))
 957               (tpum-ctx-atomics-list tpum-ctx))
 958
 959         (add-text-properties (point) (+ (point) width) '(invisible t))
 960
 961         (end-of-line)
 962         (when (eobp)
 963           (tpum-delete-region
 964            tpum-ctx
 965            (point-marker) (progn (insert "\n") (point-marker))))
 966         (forward-line)
 967         (setq height (1- height))))
 968     (goto-char (+ (point) width))))
 969
 970 (defun tpum-restore-todel-atomics (ctx)
 971   "Restore some stuff of tpum CTX."
 972   (mapc #'(lambda (el)
 973             (delete-region (marker-position (car el))
 974                            (marker-position (cdr el))))
 975         (tpum-ctx-todel-list ctx))
 976   (mapc #'(lambda (el)
 977             (add-text-properties (marker-position (car el))
 978                                  (marker-position (cdr el))
 979                                  '(invisible nil)))
 980         (tpum-ctx-atomics-list ctx)))
 981
 982 (defun tpum-insert-face (str faces)
 983   "Insert STR with FACES."
 984   (declare (special tpum-ctx))
 985   (cond ((stringp str)
 986          (set-text-properties (point) (progn (insert str) (point))
 987                               (list 'face faces)))
 988         ((glyphp str)
 989          ;; Insert glyph
 990          (let ((width (/ (glyph-width str) (font-width (face-font 'default)))))
 991            (tpum-delete-region tpum-ctx (point-marker)
 992                                (progn (insert (make-string width ?X))
 993                                       (point-marker)))
 994            (add-text-properties (- (point) width) (point)
 995                                 '(tpum-invisible t invisible t))
 996            (set-extent-begin-glyph (make-extent (point) (point)) str)))))
 997
 998 (defun tpum-insert-string (tpum-ctx tpum-string)
 999   "Using TPUM-CTX insert TPUM-STRING.
1000 TPUM-STRING is list of cons cells where car is string and cdr is face
1001 for string."
1002   (mapc #'(lambda (el)
1003             (let ((str (if (consp el) (car el) el))
1004                   (face (if (consp el) (cdr el) 'default)))
1005               (tpum-delete-region
1006                tpum-ctx (point-marker)
1007                (progn (tpum-insert-face str face)
1008                       (point-marker)))))
1009         tpum-string))
1010
1011 (defun tpum-insert-menu (tpum-menu tpum-ctx &optional startpoint)
1012   "Insert TPUM-MENU using TPUM-CTX at STARTPOINT.
1013 TPUM-MENU is list of conses which car is menu-item and cdr is tpum string."
1014   (let ((lines tpum-menu))
1015     (when startpoint
1016       (goto-char startpoint))
1017
1018     (while lines
1019       (save-excursion
1020         (add-text-properties (point)
1021                              (progn (tpum-insert-string tpum-ctx (cdar lines))
1022                                     (point))
1023                              (list 'tpum-ctx tpum-ctx 'tpum-menu-item
1024                                    (caar lines))))
1025       (setq lines (cdr lines))
1026       (when lines
1027         (tpum-next-line 1)))))
1028
1029 (defun tpum-get-keyword (menu-item keyword &optional defret)
1030   "From MENU-ITEM get KEYWORD value.
1031 If KEYWORD not found DEFRET returned."
1032   (let* ((mi-list (if (listp menu-item) menu-item (append menu-item nil)))
1033          (ckword (car mi-list))
1034          (kw-retval defret))
1035     (while mi-list
1036       (if (eq ckword keyword)
1037           (progn
1038             (setq kw-retval (cadr mi-list))
1039             (setq mi-list nil)))        ; break
1040       (setq mi-list (cdr mi-list))
1041       (setq ckword (car mi-list)))
1042     kw-retval))
1043
1044 ;; FSFmacs
1045 (unless (fboundp 'keywordp)
1046   (defun keywordp (sym)
1047     (eq (aref (symbol-name sym) 0) ?:)))
1048
1049 (defun tpum-get-suffix (menu-item)
1050   "Get suffix of MENU-ITEM."
1051   (if (vectorp menu-item)
1052       (let* ((mit (append menu-item nil))
1053              (sf1 (and (> (length mit) 3)
1054                        (not (keywordp (nth 2 mit)))
1055                        (not (keywordp (nth 3 mit)))
1056                        (nth 3 mit)))
1057              (sf2 (tpum-get-keyword menu-item :suffix)))
1058         (or sf2 sf1))
1059     nil))
1060
1061 (defun tpum-mi-active-p (tpum-ctx menu-item)
1062   "Return non-nil if in TPUM-CTX, MENU-ITEM is active."
1063   ;; Note that if :active uses current point position, strange things
1064   ;; will happen, so there a little work around to redefine `point' to
1065   ;; return saved point position.
1066   (save-excursion
1067     (set-buffer (tpum-ctx-buffer (tpum-get-global-context tpum-ctx)))
1068     (goto-char (tpum-ctx-point (tpum-get-global-context tpum-ctx)))
1069     (cond ((stringp menu-item) nil)     ; title or separator
1070           ((consp menu-item) t)         ; submenu
1071           ((vectorp menu-item)
1072            (let ((mit (append menu-item nil))
1073                  (at2 (tpum-get-keyword menu-item :active t)))
1074
1075              (cond ((and (> (length mit) 2) (not (keywordp (nth 2 mit))))
1076                     (nth 2 mit))
1077                    (at2 (eval at2))
1078                    (t t)))))))
1079
1080 (defun tpum-setup-ctx (menuspec tpum-ctx)
1081   "According to MENUSPEC setup TPUM-CTX."
1082   (let ((fel (car menuspec))
1083         (ret-wid 0)
1084         (ret-hei 0)
1085         (ret-off 1))                    ; XXX see tpum-move-to-offset
1086     (while fel
1087       (let* ((mistyle (cond ((vectorp fel) (tpum-get-keyword fel :style))
1088                             ((consp fel) nil)
1089                             (t nil)))
1090              (xpm-data (tpum-get-keyword fel :xpm-data))
1091              (glyph (and xpm-data (make-glyph xpm-data)))
1092              (offset (cond ((eq mistyle 'toggle)
1093                             (length (tpum-st-td)))
1094                            ((eq mistyle 'radio)
1095                             (length (tpum-st-rd)))
1096                            (glyph
1097                             (1+ (/ (glyph-width glyph)
1098                                    (font-width (face-font 'default)))))
1099                            (t 0)))
1100              (width (length
1101                      (cond ((vectorp fel) (car (append fel nil)))
1102                            ((consp fel) (concat (car fel) (tpum-st-sub)))
1103                            ((stringp fel) fel)
1104                            (t ""))))
1105              (suffix (tpum-get-suffix fel))
1106              (suflen (if suffix (1+ (length (eval suffix))) 0)))
1107
1108         (when (> (+ width suflen) ret-wid)
1109           (setq ret-wid (+ width suflen)))
1110         (setq ret-hei (1+ ret-hei))
1111         (when (> offset ret-off)
1112           (setq ret-off offset))
1113
1114         (setq menuspec (cdr menuspec))
1115         (setq fel (car menuspec))))
1116
1117     (setf (tpum-ctx-offset tpum-ctx) ret-off)
1118     (setf (tpum-ctx-width tpum-ctx) (+ ret-wid ret-off)) ; XXX
1119     (setf (tpum-ctx-height tpum-ctx) ret-hei)))
1120
1121 (defun tpum-make-delim (menu-item width)
1122   "Make delimiter string using MENU-ITEM.
1123 Delimeter shold be WIDTH chars length."
1124   (let (lb rb lin)
1125     (cond ((string= menu-item "--:singleLine")
1126            (setq lb (tpum-st-lsl))
1127            (setq rb (tpum-st-rsl))
1128            (setq lin (tpum-st-sl)))
1129           ((string= menu-item "--:doubleLine")
1130            (setq lb (tpum-st-ldl))
1131            (setq rb (tpum-st-rdl))
1132            (setq lin (tpum-st-dl)))
1133           ((string= menu-item "--:singleDashedLine")
1134            (setq lb (tpum-st-lsdl))
1135            (setq rb (tpum-st-rsdl))
1136            (setq lin (tpum-st-sdl)))
1137           ((string= menu-item "--:doubleDashedLine")
1138            (setq lb (tpum-st-lddl))
1139            (setq rb (tpum-st-rddl))
1140            (setq lin (tpum-st-ddl)))
1141
1142           ;; Default separator as is "--:singleLine"
1143           (t
1144            (setq lb (tpum-st-lsl))
1145            (setq rb (tpum-st-rsl))
1146            (setq lin (tpum-st-sl))))
1147
1148     (list
1149      (cons lb (tpum-st-bface))
1150      (substring
1151       (mapconcat 'identity
1152                  (make-list width lin) "")
1153       0 width)
1154      (cons rb (tpum-st-bface)))))
1155
1156 (defun tpum-fixate-name (name)
1157   "Remove accell stuff from NAME."
1158   (or (and (stringp name)
1159            (replace-in-string name "%_" ""))
1160       name))
1161
1162 (defun tpum-mitotmi (menu-item tpum-ctx)
1163   "Convert MENU-ITEM to tpum menu item using TPUM-CTX."
1164   (let ((width (tpum-ctx-width tpum-ctx))
1165 ;       (height (tpum-ctx-height tpum-ctx))
1166         (offset (tpum-ctx-offset tpum-ctx)))
1167
1168     (cond ((listp menu-item)            ;submenu
1169            (let ((iname (tpum-fixate-name (car menu-item))))
1170              (list (cons (tpum-st-l) (tpum-st-bface))
1171                    (concat (make-string offset ?\ ) iname)
1172                    (concat (make-string
1173                             (- width (length iname) offset
1174                                (length (tpum-st-sub))) ?\ ))
1175                    (tpum-st-sub)
1176                    (cons (tpum-st-r) (tpum-st-bface)))))
1177
1178           ((vectorp menu-item)
1179            (let* ((mi-list (append menu-item nil))
1180                   (iname (car mi-list))
1181                   (accel (tpum-get-keyword menu-item :accelerator))
1182                   (style (tpum-get-keyword menu-item :style))
1183                   (active (tpum-mi-active-p tpum-ctx menu-item))
1184                   (selected (eval (tpum-get-keyword menu-item :selected)))
1185                   (xpm-img (eval (tpum-get-keyword menu-item :xpm-data)))
1186                   (suffix (eval (tpum-get-suffix menu-item))))
1187
1188              (when suffix
1189                (setq iname (if (> (length iname) 0)
1190                                (concat iname " " suffix)
1191                              suffix)))
1192              (when xpm-img
1193                (setq xpm-img (make-glyph xpm-img))
1194                (when (or (not (= (glyph-height xpm-img)
1195                                  (font-height (face-font 'default))))
1196                          (not (member (glyph-width xpm-img)
1197                                       (list (font-width (face-font 'default))
1198                                             (* 2 (font-width
1199                                                   (face-font 'default)))))))
1200                  (error (format "Invalid xpm-img sizes %S"
1201                                 (cons (glyph-width xpm-img)
1202                                       (glyph-height xpm-img))))))
1203
1204              ;; Deal with accel key stuff
1205              (when (string-match "%_\\(.\\)" iname)
1206                (setq accel (string-to-char (match-string 1 iname))))
1207              (setq iname (tpum-fixate-name iname))
1208
1209              (cond ((eq style 'toggle)
1210                     (list
1211                      (cons (tpum-st-l) (tpum-st-bface))
1212                      (cons (tpum-style-toggle selected) (tpum-da-face active))
1213                      (cons iname (if selected
1214                                      (list (tpum-da-face active)
1215                                            'tpum-toggled-face)
1216                                    (tpum-da-face active)))
1217                      (make-string (- width (length iname) offset) ?\x20)
1218                      (cons (tpum-st-r) (tpum-st-bface))))
1219
1220                    ((eq style 'radio)
1221                     (list
1222                      (cons (tpum-st-l) (tpum-st-bface))
1223                      (cons (tpum-style-radio selected) (tpum-da-face active))
1224                      (cons iname (if selected
1225                                      (list (tpum-da-face active)
1226                                            'tpum-toggled-face)
1227                                    (tpum-da-face active)))
1228                      (make-string (- width (length iname) offset) ?\ )
1229                      (cons (tpum-st-r) (tpum-st-bface))))
1230                    ;; TODO: radio, normal, etc
1231                    (t
1232                     (list
1233                      (cons (tpum-st-l) (tpum-st-bface))
1234                      (when xpm-img
1235                        (cons xpm-img nil))
1236                      (make-string
1237                       (if xpm-img
1238                           (- offset (/ (glyph-width xpm-img)
1239                                        (font-width (face-font 'default))))
1240                         offset)
1241                       ?\x20)
1242                      (cons iname (tpum-da-face active))
1243                      (make-string (- width (length iname) offset) ?\ )
1244                      (cons (tpum-st-r) (tpum-st-bface)))))
1245              ))
1246
1247           ((stringp menu-item)
1248            (cond ((and (> (length menu-item) 1)
1249                        (string= "--" (substring menu-item 0 2)))
1250                   (tpum-make-delim menu-item width))
1251
1252                  (t (list
1253                      (cons (tpum-st-l) (tpum-st-bface))
1254                      (make-string offset ?\ )
1255                      (cons menu-item 'tpum-deactive-face)
1256                      (make-string (- width (length menu-item) offset) ?\x20)
1257                      (cons (tpum-st-r) (tpum-st-bface))))))
1258
1259           ((symbolp menu-item)
1260            (cond ((eq menu-item 'menu-begin)
1261                   (list
1262                    (cons (tpum-st-lt) (tpum-st-bface))
1263                    (cons (substring
1264                           (mapconcat 'identity
1265                                      (make-list width (tpum-st-t)) "")
1266                           0 width) (tpum-st-bface))
1267                    (cons (tpum-st-rt) (tpum-st-bface))))
1268                  ((eq menu-item 'menu-title)
1269                   (list
1270                    (cons (tpum-st-l) (tpum-st-bface))
1271                    (cons (eval menu-item) 'tpum-title-face)
1272                    (make-string (- width (length (eval menu-item))) ?\x20)
1273                    (cons (tpum-st-r) (tpum-st-bface))))
1274
1275                  ((eq menu-item 'menu-separator)
1276                   (list
1277                    (cons (tpum-st-tsl) (tpum-st-bface))
1278                    (cons (substring
1279                           (mapconcat 'identity
1280                                      (make-list width (tpum-st-ts)) "")
1281                           0 width) (tpum-st-bface))
1282                    (cons (tpum-st-tsr) (tpum-st-bface))))
1283
1284                  ((eq menu-item 'menu-end)
1285                   (list
1286                    (cons (tpum-st-lb) (tpum-st-bface))
1287                    (cons (substring
1288                           (mapconcat 'identity
1289                                      (make-list width (tpum-st-b)) "")
1290                           0 width) (tpum-st-bface))
1291                    (cons (tpum-st-rb) (tpum-st-bface))))
1292                  (t nil)))
1293
1294           (t (list
1295               (cons (tpum-st-l) (tpum-st-bface))
1296               "defstring"
1297               (cons (tpum-st-r) (tpum-st-bface)))))))
1298
1299 (defun tpum-menu-title (menuspec)
1300   "Return title of MENUSPEC or nil, if there no title."
1301   (let ((postit (car menuspec)))
1302     (if (and (not (keywordp postit))
1303              (not (listp postit)))
1304         (tpum-fixate-name postit)
1305       nil)))
1306
1307 (defun tpum-menu-process-keywords (menuspec)
1308   "Cut off all keywords in MENUSPEC."
1309   (while (keywordp (car menuspec))
1310     (setq menuspec (cddr menuspec)))
1311   menuspec)
1312
1313 (defun tpum-apply-filter (menuspec)
1314   "Apply filter function to MENUSPEC and return new MENU."
1315   (let* ((filter (tpum-get-keyword menuspec :filter))
1316          (nm (if filter (funcall filter menuspec) menuspec)))
1317     nm))
1318
1319 (defun tpum-do-modal (ctx)
1320   "Do modal mode using CTX."
1321
1322   (setf (tpum-ctx-recursive-p ctx) t)
1323   (recursive-edit))
1324
1325 (defun tpum-do-menu (menuspec &optional spoint frame-coords)
1326   "Insert menu specified by MENUSPEC at the SPOINT.
1327 If FRAME-COORDS is given, then popup Emacs frame at FRAME-COORDS.
1328 Return tpum context."
1329   ;; XXX TPUM-CTX-FRAME will hold frame coords temporary.
1330   (let* ((tpum-ctx (make-tpum-ctx :frame frame-coords))
1331          (filter (tpum-get-keyword menuspec :filter))
1332          (menu-title (tpum-menu-title menuspec))
1333          (desc (tpum-menu-process-keywords
1334                 (if menu-title (cdr menuspec) menuspec)))
1335          (inrec nil)
1336          (buffer-read-only nil))
1337
1338     (setf (tpum-ctx-buffer tpum-ctx) (current-buffer))
1339     (setf (tpum-ctx-post-command-hooks tpum-ctx) post-command-hook)
1340     (setq post-command-hook nil)
1341     (setf (tpum-ctx-truncate-lines tpum-ctx) truncate-lines)
1342     (setq truncate-lines tpum-truncate-lines)
1343     (setf (tpum-ctx-after-change-functions tpum-ctx) after-change-functions)
1344     (setq after-change-functions nil)
1345     (setf (tpum-ctx-before-change-functions tpum-ctx) before-change-functions)
1346     (setq before-change-functions nil)
1347     (setf (tpum-ctx-undo-list tpum-ctx) buffer-undo-list)
1348
1349     (setf (tpum-ctx-selective-display tpum-ctx) selective-display)
1350     (setq selective-display nil)
1351
1352     ;; pseudo stlye uses ctl-arrow
1353     (when (eq tpum-cstyle 'tpum-style-pseudo)
1354       (tpum-plist-put tpum-ctx 'ctl-arrow ctl-arrow)
1355       (setq ctl-arrow 11))
1356
1357     ;; Apply filter function
1358     (when filter
1359       (setq desc (funcall filter desc)))
1360
1361     (tpum-setup-ctx (cons menu-title desc) tpum-ctx)
1362
1363     ;; Save position before moving point
1364     (setf (tpum-ctx-point tpum-ctx) (point-marker))
1365
1366     ;; Construct list of strings to insert
1367     (unless (tpum-ctx-frame tpum-ctx)
1368       (setq inrec (cons (cons nil (tpum-mitotmi 'menu-begin tpum-ctx)) inrec))
1369       (setf (tpum-ctx-height tpum-ctx) (+ 1 (tpum-ctx-height tpum-ctx))))
1370
1371     (when popup-menu-titles
1372       (setq inrec (cons (cons nil (tpum-mitotmi 'menu-title tpum-ctx)) inrec)
1373             inrec (cons (cons nil
1374                               (tpum-mitotmi 'menu-separator tpum-ctx)) inrec))
1375       (setf (tpum-ctx-height tpum-ctx) (+ 2 (tpum-ctx-height tpum-ctx))))
1376
1377     ;; Construct tpum-menu
1378     (while desc
1379       (let ((inc (tpum-get-keyword (car desc) :included))
1380             (conf (tpum-get-keyword (car desc) :config)))
1381         (setq inc (if inc (eval inc) t))
1382         (setq inc (if conf (memq conf menubar-configuration) inc))
1383
1384         (when inc
1385           (setq inrec (cons (cons (car desc)
1386                                   (tpum-mitotmi (car desc) tpum-ctx))
1387                             inrec))))
1388       (setq desc (cdr desc)))
1389
1390     (unless (tpum-ctx-frame tpum-ctx)
1391       (setq inrec (cons (cons nil (tpum-mitotmi 'menu-end tpum-ctx)) inrec)))
1392     (setq inrec (nreverse inrec))
1393
1394     ;; Configure frame if needed
1395     (when (tpum-ctx-frame tpum-ctx)
1396       (let ((coord (tpum-ctx-frame tpum-ctx))
1397             (blv (buffer-local-variables))
1398             buf tcf)
1399         (setf (tpum-ctx-frame tpum-ctx)
1400               (tpum-frame-make (car coord) (cdr coord)
1401                                (+ 2 (tpum-ctx-width tpum-ctx))
1402                                (tpum-ctx-height tpum-ctx)))
1403         (setq tcf (tpum-ctx-frame tpum-ctx))
1404         (set-frame-size tcf (+ 2 (tpum-ctx-width tpum-ctx))
1405                         (tpum-ctx-height tpum-ctx))
1406         (setq buf (generate-new-buffer
1407                    (concat "*tpum*" (if menu-title menu-title "empty*"))))
1408         (set-window-buffer (frame-selected-window tcf) buf)
1409         ;; Make it dedicated?
1410         (set-buffer-dedicated-frame buf tcf)
1411         (make-frame-visible tcf)
1412         (focus-frame tcf)
1413         (switch-to-buffer buf)
1414         ;; Setup buffer local variables
1415         (mapc #'(lambda (vv)
1416                   (ignore-errors
1417                     (set (car vv) (cdr vv))))
1418               blv)))
1419
1420     ;; Save position before moving point
1421     (setf (tpum-ctx-point tpum-ctx) (point-marker))
1422
1423     ;; Move point to start location
1424     (when spoint
1425       (goto-char spoint))
1426
1427     ;; XXX Delete rectangle
1428     (tpum-safe-delrec tpum-ctx (+ (length (concat (tpum-st-l) (tpum-st-r)))
1429                                   (tpum-ctx-width tpum-ctx))
1430                       (length inrec))
1431
1432     (save-excursion
1433       (tpum-insert-menu inrec tpum-ctx))
1434
1435     ;; Save column and point
1436     (setf (tpum-ctx-tmpoint tpum-ctx) (point))
1437     (setf (tpum-ctx-column tpum-ctx)
1438           (+ (tpum-current-column) (length (tpum-st-l))))
1439
1440     (condition-case nil
1441         (progn
1442           (tpum-move-point 1)
1443           (tpum-move-to-offset tpum-ctx))
1444       (t nil))
1445
1446     (tpum-mode tpum-ctx)
1447
1448     (when tpum-auto-submenu-mode
1449       (tpum-submenu-show))
1450
1451     tpum-ctx))
1452
1453 ;;;###autoload
1454 (defun tpum-popup-menu (menu &optional event)
1455   "Popup MENU in text mode.
1456 EVENT is not used."
1457   (tpum-do-menu menu))
1458
1459 ;;; Ballooning support
1460 (defun tpum-frame-make (x y width height &optional buffer)
1461   "At X Y using WIDTH HEIGHT size make balloon frame to be used by tpum.
1462 Optionally you may specify BUFFER to select in newly created frame.
1463 Return Emacs frame."
1464   (let ((frame (make-frame `((top-toolbar-visible-p . nil)
1465                              (left-toolbar-visible-p . nil)
1466                              (right-toolbar-visible-p . nil)
1467                              (bottom-toolbar-visible-p . nil)
1468                              (has-modeline-p . nil)
1469                              (modeline-shadow-thickness . 0)
1470                              (vertical-scrollbar-visible-p . nil)
1471                              (horizontal-scrollbar-visible-p . nil)
1472                              (menubar-visible-p . nil)
1473                              (text-cursor-visible-p . t)
1474                              (left-margin-width . 1)
1475                              (initially-unmapped . t)
1476                              (internal-border-width . 1)
1477                              (name . "*tpum frame*")
1478                              (border-width . 2)
1479                              (border-color . ,(face-foreground-name
1480                                                (tpum-st-bface)))
1481                              (top . ,y)
1482                              (left . ,x)
1483                              (popup . ,(selected-frame))
1484                              (minibuffer . nil)
1485                              (width . ,width)
1486                              (height . ,height)))))
1487     (when buffer
1488       (set-window-buffer (frame-selected-window frame) buffer)
1489       (set-buffer-dedicated-frame buffer frame))
1490
1491     frame))
1492
1493 (defun tpum-frame-get-coord ()
1494   "Get coordinates of point."
1495   (let ((edgs (window-pixel-edges))
1496         (lw (/ (window-text-area-pixel-width) (window-width)))
1497         (lh (/ (window-text-area-pixel-height) (window-height))))
1498     (cons (+ tpum-frame-x-offset (* lw (current-column)) (car edgs))
1499           (+ tpum-frame-y-offset
1500              (* lh (count-lines (window-start) (window-point)))
1501              (cadr edgs)))))
1502
1503 (defun tpum-frame-do-menu (menu coor)
1504   "Popup MENU in separate frame at COOR.
1505 COOR is cons cell where car is X and cdr is Y."
1506 ;  (let ((tfr (tpum-frame-make (car coor) (cdr coor) 3 1)))
1507 ;    (tpum-do-menu menu nil tfr)))
1508   (tpum-do-menu menu nil coor))
1509
1510 ;;;###autoload
1511 (defun tpum-frame-popup-menu (menu &optional event)
1512   "Popup MENU in separate frame.
1513 EVENT is some mouse event."
1514   (tpum-frame-do-menu
1515    menu
1516    (if event
1517        (cons (event-x-pixel event) (event-y-pixel event))
1518      (tpum-frame-get-coord))))
1519
1520 ;;; TPUM minor mode
1521 ;; Suggested by Uwe Brauer <oub@mat.ucm.es>
1522
1523 (defvar tpum-minor-mode nil
1524   "Non-nil if tpum minor mode enabled.")
1525 (make-variable-buffer-local 'tpum-minor-mode)
1526
1527 ;; Save old `popup-menu' function
1528 (defun old-popup-menu (menu &optional event))
1529 (fset 'old-popup-menu (symbol-function 'popup-menu))
1530
1531 ;; Redefine standart `popup-menu'
1532 (defun popup-menu-redefined-by-tpum (menu &optional event)
1533   "Text mode `popup-menu' replacement.
1534 Poup MENU at point.
1535 Optionally mouse EVENT can be specified."
1536   (if (or tpum-minor-mode tpum-global-mode)
1537       (if (eq tpum-menu-type 'inline)
1538           (tpum-popup-menu menu event)
1539
1540         ;; TODO:
1541         ;;   - Maybe change `tpum-cstyle' to `tpum-style-frame'?
1542         (tpum-frame-popup-menu menu event))
1543
1544     ;; Use old popup menu function
1545     (funcall #'old-popup-menu menu event)))
1546
1547 (fset 'popup-menu (symbol-function 'popup-menu-redefined-by-tpum))
1548
1549 ;;;###autoload
1550 (defun tpum-minor-mode (&optional arg)
1551   "Toggle tpum minor mode.
1552 With prefix ARG, turn on if positive, otherwise off."
1553   (interactive (list (or (and current-prefix-arg
1554                               (prefix-numeric-value current-prefix-arg))
1555                          (if tpum-minor-mode 0 1))))
1556   (setq tpum-minor-mode (> arg 0)))
1557
1558 ;;;###autoload
1559 (defun tpum-global-mode (&optional arg)
1560   "Toggle tpum global mode.
1561 With prefix ARG, turn on if positive, otherwise off."
1562   (interactive (list (or (and current-prefix-arg
1563                               (prefix-numeric-value current-prefix-arg))
1564                          (if tpum-global-mode 0 1))))
1565   (setq tpum-global-mode (> arg 0)))
1566
1567 (add-minor-mode 'tpum-minor-mode " Tpum")
1568
1569 (defun define-tpum-key (map tkeys rkeys)
1570   "In keymap MAP define keys TKEYS that emulates press of RKEYS."
1571   (define-key map tkeys
1572     `(lambda ()
1573        (interactive "_")
1574        (let* ((nevents (aref (key-sequence-list-description ,rkeys) 0))
1575               (mods (and (> (length nevents) 0) (butlast nevents)))
1576               (buname (symbol-name (car (last nevents))))
1577               (button (- (char-to-int (aref buname (1- (length buname)))) 48)))
1578          (setq unread-command-events
1579                (append (list (make-event
1580                               'button-press
1581                               (list 'modifiers mods 'button button)))
1582                        unread-command-events))))))
1583
1584 \f
1585 (provide 'tpum)
1586
1587 ;; Finally run load hooks
1588 (run-hooks 'tpum-load-hook)
1589
1590 ;;; tpum.el ends here