emacs_el/tiny-tools/tiny/tinylibmenu.el

   1 ;;; tinylibmenu.el --- Library for echo-area menu
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1996-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x ti::menu-version.
  13 ;; Look at the code with folding.el
  14
  15 ;; COPYRIGHT NOTICE
  16 ;;
  17 ;; This program is free software; you can redistribute it and/or modify it
  18 ;; under the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2 of the License, or (at your option)
  20 ;; any later version.
  21 ;;
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  24 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with program; see the file COPYING. If not, write to the
  29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 ;; Boston, MA 02110-1301, USA.
  31 ;;
  32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  33
  34 ;;}}}
  35 ;;{{{ Install
  36
  37 ;; ....................................................... &t-install ...
  38 ;; Put this file on your Emacs-Lisp load path, add following into your
  39 ;; ~/.emacs startup file
  40 ;;
  41 ;;      (require 'tinylibmenu)
  42 ;;
  43 ;;  Or use autoload, which is prefered. Your ~/.emacs loads faster
  44 ;;
  45 ;;      (autoload 'ti::menu-menu-default "tinylibmenu" "" t)
  46 ;;
  47 ;;  To bring up the menu (or menus), bind the main function into some key.
  48 ;;  This s only a demonstration. Configure your own menus using the
  49 ;;  example in this file.
  50 ;;
  51 ;;      (global-set-key "\C-cM"   'ti::menu-menu-default)
  52 ;;
  53 ;;  Make sure you have defined the variables `my-menu1' and `my-menu2'
  54 ;;  which hold the menu information.
  55 ;;
  56 ;;  If you have any questions, use this function to contact author
  57 ;;
  58 ;;      M-x ti::menu-submit-bug-report
  59
  60 ;;}}}
  61 ;;{{{ docs
  62
  63 ;;; Commentary:
  64
  65 ;;  Overview of features
  66 ;;
  67 ;;      o   This package is a library.
  68 ;;          Store key bindings behind echo area menu, which is similar to
  69 ;;          menu bar.
  70 ;;      o   Regular Emacs user can also put less used binding to guided
  71 ;;          echo menu by just defining couple of menu variables.
  72 ;;
  73 ;;  Customizing menus
  74 ;;
  75 ;;      If some package defines echo area menus and you only want to make
  76 ;;      small modifications and not to copy the whole 'defvar MENU' to your
  77 ;;      .emacs, you can use following functions to manipulate the menu
  78 ;;      items
  79 ;;
  80 ;;          ti::menu-add
  81 ;;          ti::menu-set-doc-string
  82 ;;
  83 ;;      For example, if there is menu item:
  84 ;;
  85 ;;          (defconst my-menu-sample
  86 ;;          '("?)help, 1)test1, 2)test2"
  87 ;;            ((?1 . (  (some-menu-test1 1 2 3)))
  88 ;;             (?2 . (  (some-menu-test2 1 2 3))))))
  89 ;;
  90 ;;      and you don't like keybinding '?2'. You first delete the menu item,
  91 ;;      then add yours and lastly you update the doc string that is printed
  92 ;;      in echo area. Here is how you do all these three steps.
  93 ;;
  94 ;;          (ti::menu-add 'my-menu-sample ?2  nil 'delete)
  95 ;;          (ti::menu-add 'my-menu-sample ?t '( (my-test 1 2 3)))
  96 ;;          (ti::menu-set-doc-string 'my-menu-sample
  97 ;;                                    "?)help, 1)test1, t)myTest")
  98 ;;
  99 ;;      And the modified menu looks like this
 100 ;;
 101 ;;          (defconst my-menu-sample
 102 ;;          '("?)help, 1)test1, t)myTest"
 103 ;;            ((?1 . (  (some-menu-test1 1 2 3)))
 104 ;;             (?t . (  (my-test2 1 2 3))))))
 105 ;;
 106 ;;      If you want to replace _many_ commands from the menu, it is lot
 107 ;;      easier if you copy the menu `defvar' and make direct changes there.
 108 ;;      If you want to make it all with lisp, here is example which
 109 ;;      replaces 2 items from the menu
 110 ;;
 111 ;;          (mapcar
 112 ;;            '(lambda (x)
 113 ;;               (let ((key (car x)))
 114 ;;                 (ti::menu-add
 115 ;;                   'ti::menu-:menu-sample nil 'delete) ;; Remove old
 116 ;;                 ;; Add new
 117 ;;                 (ti::menu-add 'ti::menu-:menu-sample key (cdr x))))
 118 ;;          '((?1 . ( (my-1 1 2 3)))     ;; New menu item replacements
 119 ;;            (?2 . ( (my-2 1 2 3)))))
 120 ;;
 121 ;;          (ti::menu-set-doc-string
 122 ;;            'ti::menu-:menu-sample "?)help, 1)my1 2)my2")
 123 ;;
 124 ;;  Having a test run
 125 ;;
 126 ;;      The easiest way to get a hold on the echo menu is that you try it.
 127 ;;      Follow these steps. Then you're ready to make your own menus.
 128 ;;
 129 ;;      .   Load this file. M-x load-library tinylibmenu.el
 130 ;;      .   Start menu with `M-x' `ti::menu-menu-default'
 131 ;;      .   Press key `?' or `h' to get help and `q' to quit menu.
 132 ;;      .   Try offered choices
 133
 134 ;;; Change Log:
 135
 136 ;;; Code:
 137
 138 ;;}}}
 139 ;;{{{ setup: require
 140
 141 (eval-when-compile
 142   (autoload 'ignore-errors "cl-macs" nil 'macro))
 143
 144 ;;}}}
 145 ;;{{{ setup: variables
 146
 147 (defvar ti::menu-:load-hook nil
 148   "*Hook that is run when package has been loaded.")
 149
 150 (defvar ti::menu-:prefix-arg  nil
 151   "Prefix arg when menu is called.")
 152
 153 ;;  This is just an example, not a user variable.
 154 ;;  This is how you use the package
 155 ;;  NOTE: put the help into the documentation string. Like
 156 ;;        in variable ti::menu-:menu-mode.
 157
 158 (defconst ti::menu-:menu-sample
 159   '("?)help, 1)test1, 2)test2, m)ode, u)ndefined , e)val. q)uit"
 160     ((?1 . (  (ti::menu-test1 1 2 3)))      ;this does not have FLAG
 161      (?2 . (t (ti::menu-test2)))            ;FLAG used.
 162      (?m . ti::menu-:menu-mode)
 163      (?u . ti::menu-:menu-not-exist) ;this variable does not exist :-)
 164      (?e . (t (progn
 165                 (message "menu item evaled. Pfx: '%s' "
 166                          (prin1-to-string ti::menu-:prefix-arg))
 167                 (sleep-for 1))))))
 168   "*This is documentation string of variable `ti::menu-:menu-sample'.
 169 The menu help is put here.
 170
 171 Reserved menu keys (characters)
 172
 173     `q' and `Q' are reserved for quitting the menu prompt.
 174     `?' anf `h' are reserved for help.
 175
 176 Menu structure is as follows
 177
 178     FLAG is optional. If non-nil, menu should be shown after
 179     function has completed. If FLAG is missing, the menu is not displayed
 180     after the function call. (that is: call function and exit menu)
 181
 182     The DISPLAYED-MENU-STRING is evaled, so it can contain any lisp expression
 183     yielding a string.
 184
 185     Below you see 3 different ways to define one menu element.
 186
 187     (defconst my-meny
 188      '(
 189       DISPLAYED-MENU-STRING
 190       ((CHARACTER-KEY  . ANOTHER-MENU-VARIABLE-SYMBOL)
 191        (CHARACTER-KEY  . ([FLAG] (FUNCTION-NAME PARAMETER PARAMETER...)))
 192        (CHARACTER-KEY  . ([FLAG] (FORM-TO-EVAL)))
 193        ..))
 194     \" MENU HELP RESIDES IN THE DOCUMENTATION STRING\")")
 195
 196 ;; This is just an example how you could utilize the prefix arguments.
 197 ;;
 198 ;;(defconst ti::menu-:menu-mail
 199 ;;  '((if current-prefix-arg
 200 ;;        "View mailbox read-only:  E)macs M)ailbox P)erl   R)ead/write"
 201 ;;      "View mailbox:  E)macs M)ailbox P)erl   R)ead-only")
 202 ;;    ((?e . ( (vm-visit-folder "~/mail/emacs" current-prefix-arg)))
 203 ;;     (?m . ( (call-interactively 'vm)))
 204 ;;     (?p . ( (vm-visit-folder "~/mail/perl" current-prefix-arg)))
 205 ;;     (?r . (t(setq current-prefix-arg (if current-prefix-arg nil '(4)))))
 206 ;;     ))
 207 ;;  "Select a mailbox to visit")
 208
 209 ;; This is just an example, not a user variable.
 210
 211 (defconst ti::menu-:menu-mode
 212   '("Press ?/ cC)++ l)isp tT)ext f)undamental p)icture F0ill O)font"
 213     ((?c . ( (c-mode)))
 214      (?C . ( (cc-mode)))
 215      (?l . ( (lisp-mode)))
 216      (?t . ( (text-mode)))
 217      (?T . ( (indented-text-mode)))
 218      (?f . ( (fundamental-mode)))
 219      (?p . ( (picture-mode)))
 220      (?F . (t (auto-fill-mode)))
 221      (?O . (t (font-lock-mode)))
 222      (?/ . ti::menu-:menu-sample)))     ;back to ROOT menu
 223   "*Menu help.
 224 Major modes:
 225
 226   c = turn on `c-mode'
 227   C = turn on C++ mode
 228   l = turn on lisp mode
 229   t = turn on text mode
 230   T = turn on indented text mode
 231   f = turn on fundamental mode
 232   p = turn on picture mode
 233
 234 Minor modes:
 235
 236   F = turn on auto fill mode
 237   O = turn on f(o)nt lock mode
 238
 239 Special keys
 240   / = Return to root menu")
 241
 242 (defvar ti::menu-:menu 'ti::menu-:menu-sample
 243   "*Variable holding the default root menu.")
 244
 245 ;;}}}
 246
 247 ;;; ########################################################### &Funcs ###
 248
 249 ;;{{{ code: test funcs
 250
 251 (defun ti::menu-test1 (&optional arg1 arg2 arg3)
 252   "Sample Menu test function with ARG1 ARG2 ARG3."
 253   (message (format "function 1 called with args: %s %s %s" arg1 arg2 arg3)))
 254
 255 (defun ti::menu-test2 ()
 256   "Sample Menu test function."
 257   (message (format "function 2 called"))
 258   (sleep-for 1))
 259
 260 ;;}}}
 261 ;;{{{  menu item add, delete
 262
 263 ;;; ------------------------------------------------------------- &add ---
 264 ;;;
 265 ;;;###autoload
 266 (defun ti::menu-add (menu-symbol ch cell &optional delete)
 267   "Add to menu MENU-SYMBOL elt (CH . CELL). Optionally DELETE.
 268
 269 Example:
 270
 271   (ti::menu-add 'ti::menu-:menu-sample ?2  nil 'delete)
 272   (ti::menu-add 'ti::menu-:menu-sample ?t '( (my-test 1 2 3)))
 273
 274 Return:
 275
 276   nil       no add done due to existing CELL
 277             no remove due to non-existing CELL"
 278   (let* ((menu  (symbol-value menu-symbol))
 279          (doc   (nth 0 menu))
 280          (list  (nth 1 menu))
 281          elt
 282          ret)
 283     (setq elt (assq ch list))
 284     (cond
 285      (delete
 286       (when elt
 287         (setq ret elt)
 288         (setq list (delete elt list))
 289         (set menu-symbol (list doc list))))
 290      ((and (null delete)
 291            (not elt))                   ;not already exist?
 292       (setq ret (cons ch cell))
 293       (push ret list)
 294       (set menu-symbol (list doc list))))
 295     ret))
 296
 297 ;;; ----------------------------------------------------------------------
 298 ;;;
 299 ;;;###autoload
 300 (defun ti::menu-set-doc-string (menu-symbol doc-string)
 301   "Use  MENU-SYMBOL and set its DOC-STRING.
 302
 303 Example:
 304
 305   (ti::menu-set-doc-string 'ti::menu-:menu-sample \"?=help, 1=test1, t=myTest\")"
 306   (let* ((menu (symbol-value menu-symbol)))
 307     ;;  It's better to check that the arg is right; setcar won't
 308     ;;  do that
 309     (if (not (stringp doc-string))
 310         (error "timu: need string."))
 311     (setcar menu doc-string)
 312     (set menu-symbol menu)))
 313
 314 ;;}}}
 315
 316 ;;{{{ code: menu
 317
 318 ;;; ----------------------------------------------------------------------
 319 ;;;
 320 (defun ti::menu-read-char-exclusive (msg)
 321   "Aa `read-char-exclusive', but for Emacs and XEmacs. Display MSG."
 322   (if (fboundp 'read-char-exclusive)
 323       (cond
 324        ((featurep 'xemacs)
 325         (message msg)
 326         (read-char-exclusive))
 327        (t
 328         (read-char-exclusive msg)))
 329     (read-char msg)))
 330
 331 ;;; ----------------------------------------------------------------------
 332 ;;;
 333 (defun ti::menu-help-output  (variable-symbol)
 334   "Write doctring, ie Menu help, to the *Help* buffer"
 335   (with-output-to-temp-buffer "*Help*"
 336     (princ
 337      (documentation-property
 338       variable-symbol
 339       'variable-documentation))))
 340
 341 ;;; ----------------------------------------------------------------------
 342 ;;; - This is only simple help. You can't resize the window etc...
 343 ;;;
 344 (defun ti::menu-help (menu-sym)
 345   "Show menu help of MENU-SYM.
 346 MENU-SYM can variable symbol, whose documentaion is displayed or
 347 a function symbol.
 348
 349 The help commands are:
 350   n or space   = next
 351   p or del     = previous
 352   q            = end help"
 353   (let* ((msg     "Help: space or n = next, backspace or p = prev, q = quit")
 354          (oframe  (selected-frame))
 355          (buffer  "*help*")
 356          (docs    (or (documentation-property
 357                        menu-sym 'variable-documentation)
 358                       (and (fboundp menu-sym)
 359                            (documentation menu-sym))))
 360          step
 361          ch)
 362     (cond
 363      ((stringp docs)
 364       (unwind-protect            ;make sure the help buffer is deleted
 365           (save-excursion
 366             (save-window-excursion
 367               ;;  We have to save the source window config above
 368               ;;  Be sure this frame is non-dedicated.
 369               (if (window-dedicated-p (selected-window))
 370                   (raise-frame
 371                    (select-frame
 372                     (car (delq
 373                           (window-frame
 374                            (get-buffer-window (current-buffer)))
 375                           (frame-list))))))
 376               ;; now we may be in another frame; save it's configuration
 377               ;; too
 378               (save-window-excursion
 379                 (with-output-to-temp-buffer buffer (princ docs))
 380                 (select-window  (get-buffer-window buffer))
 381                 ;;  This is simplest way to resize help window
 382                 (balance-windows)
 383                 (setq step (1- (window-height)))
 384                 ;;  Now scroll the help
 385                 (while (not
 386                         (member
 387                          (setq ch (char-to-string
 388                                    (ti::menu-read-char-exclusive msg)))
 389                          '("q" "\e")))
 390                   (cond
 391                    ;;  127  = backspace in windowed
 392                    ;;
 393                    ((member ch '("p" "P" "\177" "\b"))
 394                     (ignore-errors (scroll-down step)))
 395
 396                    ((member ch '("n" "N" " "))
 397                     (ignore-errors (scroll-up step))))))))
 398         (if (and (not (null oframe))
 399                  (framep oframe))
 400             (if (framep (setq oframe (raise-frame oframe)))
 401                 (select-frame oframe)))
 402         (kill-buffer buffer)))
 403      (t
 404       (message "Sorry, no help defined.")
 405       (sleep-for 1)
 406       (message "")))
 407     (discard-input)))
 408
 409 ;;; ----------------------------------------------------------------------
 410 ;;;
 411 ;;;###autoload
 412 (defun ti::menu-menu (menu-symbol &optional pfx-arg)
 413   "The menu navigation engine.
 414
 415 Input:
 416
 417   MENU-SYMBOL           variable symbol containing menu items
 418   PFX-ARG               the prefix arg user ppossibly passed to menu
 419
 420 References:
 421
 422   `ti::menu-:menu-sample'   Show how the menu is constructed.
 423   `ti::menu-:prefix-arg'    Copy of current prefix arg"
 424   (let* ((var           menu-symbol)
 425          (m             (eval var))     ;menu content
 426          (loop          t)
 427          (current-prefix-arg  pfx-arg)  ;set for menu functions
 428          prompt flag
 429          alist
 430          ch
 431          elt
 432          eval-form)
 433     (setq ti::menu-:prefix-arg pfx-arg)
 434     (while loop
 435       (setq prompt      (eval (nth 0 m))
 436             prompt      (and prompt
 437                              (replace-regexp-in-string "\r" "" prompt))
 438             alist       (nth 1 m))
 439       (when (or (not (stringp prompt))
 440                 (not (string-match "[^ \t\r\n]" prompt)))
 441         (error "Menu structure error; no prompt: %s" m))
 442       ;;  moving the mouse and reading with read-char would break. Use above.
 443       (setq ch (char-to-string (ti::menu-read-char-exclusive prompt)))
 444       (setq eval-form nil)              ;clear this always
 445       ;; .................................................. what ch ? ...
 446       (cond
 447        ((member ch '("q" "Q" "\e"))     ;quit
 448         (setq loop nil))
 449        ((string= ch "?")                ;handle help
 450         (ti::menu-help var))
 451        ((string= ch "h")                ;handle help
 452         (ti::menu-help-output var)
 453         (setq loop nil))
 454        ((setq elt (assq (string-to-char ch) alist))
 455         (setq elt (cdr elt))
 456         ;; ................................. new menu or call function ...
 457         (cond
 458          ((symbolp elt)
 459           (if (not (boundp elt))
 460               (error (format "Menu variable does not exist: %s" elt))
 461             ;;  replace with another menu
 462             (setq var elt
 463                   m   (symbol-value elt))))
 464          ;; ..................................................... list ...
 465          ((and (not (null elt))
 466                (listp elt))
 467           (cond                         ;See if there is flag.
 468            ((and (eq 2 (length elt))
 469                  (equal 'quote (car elt)))
 470             ;;  A menu entry is not right
 471             ;;
 472             ;;  '(?x . 'my-symbol)
 473             ;;  --> (quote my-symbol)
 474             (error
 475              "Menu error, not a symbol. Use cons or list: %s" elt))
 476            ((eq 2 (length elt))
 477             (setq flag t)
 478             (setq elt (nth 1 elt)))
 479            (t
 480             (setq flag nil)
 481             (setq elt (nth 0 elt))))
 482           (cond
 483            ((fboundp (car elt))         ;is first element a function ?
 484             (setq eval-form elt)
 485             (setq loop flag))
 486            (t
 487             (error "Menu structure error %s %s"
 488                    (assq (string-to-char ch) alist)
 489                    elt))))))
 490        (t
 491         ;;  ch not found from list, keep looping
 492         (sit-for 0.3)))                 ;flash the echo area
 493       (message "")                      ;clear echo area
 494       (when eval-form
 495         (eval eval-form)))))
 496
 497 ;;; ----------------------------------------------------------------------
 498 ;;; - This is user function
 499 ;;;
 500 (defun ti::menu-menu-default (&optional arg)
 501   "Call echo area menu with prefix ARG.
 502 Please read the documentation of variable `ti::menu-:menu-sample' to see
 503 the structure of menu.
 504
 505 Menu pointed by `ti::menu-:menu' is used and PREFIX-ARG is passed to menu engine
 506 'ti::menu-:menu'.
 507
 508 References:
 509   `ti::menu-:menu-sample'"
 510   (interactive "P")
 511   (ti::menu-menu ti::menu-:menu arg))
 512
 513 ;;}}}
 514
 515 (provide   'tinylibmenu)
 516 (run-hooks 'ti::menu-:load-hook)
 517
 518 ;;; tinylibmenu.el ends here