545 lines
20 KiB
Plaintext
545 lines
20 KiB
Plaintext
;; vtwm-menu.gwm --- Menu constructors for the VTWM profile
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1995 Anders Holst
|
|
;; Version: vtwm-1.0
|
|
;; Last change: 17/6 1995
|
|
;;
|
|
;; This file is copyrighted under the same terms as the rest of GWM
|
|
;; (see the X Inc license for details). There is no warranty that it
|
|
;; works.
|
|
;;
|
|
;; ---------------------------------------------------------------------
|
|
;;
|
|
;; This file defines how the pop-up menus behave and look. It also
|
|
;; defines a set of convenient menu constructors. To customize your
|
|
;; menus, don't change this file. Instead set the variables and call
|
|
;; the constructors from vtwmrc.gwm .
|
|
;;
|
|
;; To define a menu, you can use the following constructors:
|
|
;;
|
|
;; (construct-menu ENTRY ...)
|
|
;; where ENTRY can be a string denoting a menu label, a list
|
|
;; with a string and an action denoting a menu item, or the
|
|
;; output from the functions 'construct-machine-menu-items' or
|
|
;; 'construct-window-menu-items' below.
|
|
;;
|
|
;; (construct-window-menu NAME ACTION)
|
|
;; This constructs a menu with all current windows (except GWM
|
|
;; menu windows), which when invoked runs the ACTION on the
|
|
;; selected window.
|
|
;;
|
|
;; (construct-machine-menu NAME MACHINE-LIST ACTION)
|
|
;; Constructs a menu with entries for each of the machines in
|
|
;; MACHINE-LIST plus the local host, which when invoked runs
|
|
;; the ACTION with 'host' bound to the corresponding element
|
|
;; from MACHINE-LIST and 'name' bound to the capitalized first
|
|
;; part of the host name.
|
|
;;
|
|
;; (construct-xrsh-menu MACHINE-LIST COMMAND)
|
|
;; Constructs a menu with entries for each of the machines in
|
|
;; MACHINE-LIST plus the local host, which when invoked runs
|
|
;; "xrsh" on the selected host and COMMAND. COMMAND can be a
|
|
;; list of command tokens, or the command tokens can all be
|
|
;; inserted directly at COMMAND. The first command token will
|
|
;; be used as the name of the menu.
|
|
;;
|
|
;; (construct-window-menu-items WINDOW-TYPE ACTION)
|
|
;; Returns a list of menu items to be used by 'construct-menu'.
|
|
;; There is one item for each window matching WINDOW-TYPE, which
|
|
;; can be an atom denoting a client class, a string denoting a
|
|
;; window name regexp, or an arbitrary wool expression.
|
|
;;
|
|
;; (construct-machine-menu-items MACHINE-LIST ACTION)
|
|
;; Returns a list of menu items to be used by 'construct-menu'.
|
|
;; There is one item for each machine in MACHINE-LIST, and the
|
|
;; ACTION will be run with 'host' and 'name' bound as for
|
|
;; 'construct-machine-menu' above.
|
|
;;
|
|
;; To pop a menu, use 'vtwm-pop-menu'.
|
|
;;
|
|
|
|
|
|
(declare-screen-dependent
|
|
vtwm-menu-foreground
|
|
vtwm-menu-background
|
|
vtwm-menu-borderwidth
|
|
vtwm-menu-border-color
|
|
vtwm-menu-label-foreground
|
|
vtwm-menu-label-background
|
|
vtwm-menu-label-borderwidth
|
|
vtwm-menu-hilite-bordercolor
|
|
vtwm-menu-hilite-borderwidth
|
|
vtwm-menu-hilite-foreground
|
|
vtwm-menu-hilite-background
|
|
vtwm-menu-shadow
|
|
vtwm-menu-shadow-color
|
|
vtwm-menu-shadow-offset
|
|
vtwm-menu-font
|
|
vtwm-menu-label-font
|
|
vtwm-menu-item-height
|
|
vtwm-menu-min-width
|
|
)
|
|
|
|
;;
|
|
;; USER CUSTOMIZABLE VARIABLES
|
|
;; ---------------------------
|
|
;; Adjust these in your own profile
|
|
;;
|
|
(for screen (list-of-screens)
|
|
(defaults-to
|
|
vtwm-menu-foreground black ; Foreground of menus
|
|
vtwm-menu-background white ; Background of menus
|
|
vtwm-menu-borderwidth 2 ; Border width of menus
|
|
vtwm-menu-border-color black ; Border color of menus
|
|
vtwm-menu-label-foreground () ; Foreground of menu labels
|
|
vtwm-menu-label-background () ; Background of menu labels
|
|
vtwm-menu-label-borderwidth 1 ; Border width of menu labels
|
|
vtwm-menu-hilite-bordercolor black ; Border color of current menu item
|
|
vtwm-menu-hilite-borderwidth 1 ; Border width of current menu item
|
|
vtwm-menu-hilite-foreground () ; Text color of current menu item
|
|
vtwm-menu-hilite-background () ; Background color of current menu item
|
|
vtwm-menu-shadow t ; Whether the menu has a shadow
|
|
vtwm-menu-shadow-color black ; Color of shadow
|
|
vtwm-menu-shadow-offset 6 ; Offset of shadow from menu
|
|
vtwm-menu-font (font-make "8x13") ; Menu item font
|
|
vtwm-menu-label-font () ; Menu label font (defaults to above)
|
|
vtwm-menu-item-height 10 ; Minimum height of an item
|
|
vtwm-menu-min-width 100 ; Minimum width of menu
|
|
)
|
|
)
|
|
|
|
|
|
(defun vtwm-menu-father ()
|
|
(with (wob wob)
|
|
(while (and wob-parent
|
|
(not (member (with (wob wob-parent) wob-status) '(menu root))))
|
|
(setq wob wob-parent))
|
|
(if (= (with (wob wob-parent) wob-status) 'menu)
|
|
wob-parent
|
|
())))
|
|
|
|
(defun vtwm-menu-father-item ()
|
|
(with (wob wob)
|
|
(while (and wob-parent
|
|
(not (member (with (wob wob-parent) wob-status) '(menu root))))
|
|
(setq wob wob-parent))
|
|
(if (= (with (wob wob-parent) wob-status) 'menu)
|
|
wob
|
|
())))
|
|
|
|
(defun vtwm-menu-root ()
|
|
(with (wob wob mf ())
|
|
(while (setq mf (vtwm-menu-father))
|
|
(setq wob mf))
|
|
wob))
|
|
|
|
(defun vtwm-pop-cascade ()
|
|
(if (# 'menu-expr wob)
|
|
(setq wob-menu (eval (# 'menu-expr wob))))
|
|
(with (cascademenu (menu-wob wob-menu)
|
|
cascaderoot (vtwm-menu-root)
|
|
wm wob-menu)
|
|
(ungrab-server)
|
|
(grab-server cascaderoot)
|
|
(with (wob (vtwm-menu-father))
|
|
(## 'cascademenu wob cascademenu))
|
|
(## 'poped cascademenu t)
|
|
(with (wob (vtwm-menu-father-item))
|
|
(vtwm-pop-menu wm (+ wob-x (width wob)) wob-y))
|
|
(ungrab-server)
|
|
(grab-server cascaderoot)))
|
|
|
|
(defun vtwm-unpop-cascade ()
|
|
(if (# 'cascademenu wob)
|
|
(with (wob (# 'cascademenu wob))
|
|
(vtwm-unpop-cascade)
|
|
(with (wob (vtwm-menu-father-item))
|
|
(send-user-event 'inactive wob))
|
|
(## 'poped wob nil)
|
|
(vtwm-unpop-menu)))
|
|
(## 'cascademenu wob nil))
|
|
|
|
(defun vtwm-unpop-old-cascade ()
|
|
(with (thiswob (if wob-menu (menu-wob wob-menu))
|
|
wob (vtwm-menu-father))
|
|
(if (not (= (# 'cascademenu wob) thiswob))
|
|
(vtwm-unpop-cascade))))
|
|
|
|
(defun vtwm-unpop-all-cascade ()
|
|
(with (wob (vtwm-menu-root))
|
|
(vtwm-unpop-cascade)
|
|
(## 'poped wob nil)
|
|
(vtwm-unpop-menu)))
|
|
|
|
(defun vtwm-unpop-menu ()
|
|
(if vtwm-menu-shadow
|
|
(unpop-menu (# 'shadow wob-property)))
|
|
(unpop-menu wob))
|
|
|
|
|
|
(setq vtwm-menu-item-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (vtwm-menu-root)) wob-parent)
|
|
action (# 'action wob-property))
|
|
(send-user-event 'inactive wob)
|
|
(wob wob-parent)
|
|
(vtwm-unpop-all-cascade)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus (with (wob calling-wob) window)))
|
|
(wob calling-wob)
|
|
(eval action)
|
|
))
|
|
(on enter-window
|
|
(progn
|
|
(vtwm-unpop-old-cascade)
|
|
(send-user-event 'active wob)
|
|
(if (if wob-menu
|
|
(not (# 'poped (menu-wob wob-menu)))
|
|
(# 'menu-expr wob-property))
|
|
(vtwm-pop-cascade))
|
|
))
|
|
(on leave-window
|
|
(if (not (or (# 'menu-expr wob-property)
|
|
wob-menu))
|
|
(send-user-event 'inactive wob)))
|
|
(on (user-event 'active)
|
|
(progn
|
|
(if (# 0 (# 'cols wob-property))
|
|
(wob-borderpixel (# 0 (# 'cols wob-property))))
|
|
(if (# 1 (# 'cols wob-property))
|
|
(wob-background (# 1 (# 'cols wob-property))))))
|
|
(on (user-event 'inactive)
|
|
(progn
|
|
(if (# 0 (# 'cols wob-property))
|
|
(wob-borderpixel (# 2 (# 'cols wob-property))))
|
|
(if (# 1 (# 'cols wob-property))
|
|
(wob-background (# 2 (# 'cols wob-property)))))))))
|
|
|
|
(setq vtwm-menu-item-inner-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (user-event 'active)
|
|
(if (# 'atile wob-property)
|
|
(wob-tile (# 'atile wob-property))))
|
|
(on (user-event 'inactive)
|
|
(if (# 'ntile wob-property)
|
|
(wob-tile (# 'ntile wob-property)))))))
|
|
|
|
(setq vtwm-menu-label-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on enter-window
|
|
(progn
|
|
(vtwm-unpop-old-cascade)
|
|
)))))
|
|
|
|
(defun vtwm-menu-item-make (label action)
|
|
(list
|
|
(with (borderwidth vtwm-menu-hilite-borderwidth
|
|
borderpixel vtwm-menu-background
|
|
background vtwm-menu-background
|
|
foreground vtwm-menu-foreground
|
|
font vtwm-menu-font
|
|
fsm vtwm-menu-item-fsm
|
|
menu (if (= (type action) 'menu) action)
|
|
menu-expr (if (member (type action) '(expr subr fexpr fsubr))
|
|
(list action))
|
|
bar-min-width vtwm-menu-item-height
|
|
cdiff (or (and vtwm-menu-hilite-background
|
|
(not (= vtwm-menu-hilite-background
|
|
vtwm-menu-background)))
|
|
(and vtwm-menu-hilite-foreground
|
|
(not (= vtwm-menu-hilite-foreground
|
|
vtwm-menu-foreground))))
|
|
bdiff (and (> vtwm-menu-hilite-borderwidth 0)
|
|
vtwm-menu-hilite-bordercolor
|
|
(not (= vtwm-menu-hilite-bordercolor
|
|
vtwm-menu-background)))
|
|
ntile (label-make label)
|
|
atile (with (background (or vtwm-menu-hilite-background
|
|
vtwm-menu-background)
|
|
foreground (or vtwm-menu-hilite-foreground
|
|
vtwm-menu-foreground))
|
|
(label-make label))
|
|
cols (list (if bdiff (or vtwm-menu-hilite-bordercolor
|
|
vtwm-menu-background))
|
|
(if cdiff (or vtwm-menu-hilite-background
|
|
vtwm-menu-foreground))
|
|
(if (or cdiff bdiff) vtwm-menu-background))
|
|
property (+ (if (not (or menu menu-expr))
|
|
(list 'action action))
|
|
(if menu-expr
|
|
(list 'menu-expr menu-expr))
|
|
(list 'cols cols)
|
|
property))
|
|
(bar-make
|
|
()
|
|
(with (borderwidth 0
|
|
fsm vtwm-menu-item-inner-fsm
|
|
property (if cdiff (list 'ntile ntile 'atile atile)))
|
|
(plug-make ntile))
|
|
()))
|
|
(if vtwm-menu-shadow
|
|
(with (borderwidth vtwm-menu-hilite-borderwidth
|
|
borderpixel vtwm-menu-shadow-color
|
|
foreground vtwm-menu-shadow-color
|
|
background vtwm-menu-shadow-color
|
|
fsm ()
|
|
bar-min-width vtwm-menu-item-height
|
|
property ())
|
|
(bar-make
|
|
()
|
|
(with (borderwidth 0
|
|
fsm ()
|
|
font vtwm-menu-font)
|
|
(plug-make (label-make label)))
|
|
())))))
|
|
|
|
(defun vtwm-menu-label-make (label)
|
|
(list
|
|
(with (borderwidth (or vtwm-menu-label-borderwidth 0)
|
|
background (or vtwm-menu-label-background vtwm-menu-background)
|
|
foreground (or vtwm-menu-label-foreground vtwm-menu-foreground)
|
|
borderpixel foreground
|
|
fsm vtwm-menu-label-fsm
|
|
menu ())
|
|
(bar-make
|
|
()
|
|
(with (borderwidth 0
|
|
fsm ()
|
|
font (or vtwm-menu-label-font vtwm-menu-font))
|
|
(plug-make (label-make label)))
|
|
()))
|
|
(if vtwm-menu-shadow
|
|
(with (borderwidth (or vtwm-menu-label-borderwidth 0)
|
|
borderpixel vtwm-menu-shadow-color
|
|
background vtwm-menu-shadow-color
|
|
foreground vtwm-menu-shadow-color
|
|
fsm ())
|
|
(bar-make
|
|
()
|
|
(with (borderwidth 0
|
|
font (or vtwm-menu-label-font vtwm-menu-font))
|
|
(plug-make (label-make label)))
|
|
())))))
|
|
|
|
(: vtwm-menu-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (vtwm-menu-root)) wob-parent))
|
|
(vtwm-unpop-all-cascade)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus (with (wob calling-wob) window)))))
|
|
)))
|
|
|
|
(defun vtwm-menu-make args
|
|
(if args
|
|
(with (fsm ()
|
|
menu ()
|
|
bar-list (list menu-make)
|
|
back-list (list menu-make)
|
|
menu-min-width vtwm-menu-min-width
|
|
borderwidth vtwm-menu-borderwidth
|
|
bar-separator 0
|
|
direction vertical)
|
|
(for item args
|
|
(setq bar-list (+ bar-list (list (# 0 item))))
|
|
(setq back-list (+ back-list (list (# 1 item)))))
|
|
(with (shadow (if vtwm-menu-shadow
|
|
(with (borderpixel vtwm-menu-shadow-color)
|
|
(eval back-list)))
|
|
fsm vtwm-menu-fsm
|
|
borderpixel vtwm-menu-border-color
|
|
property (+ (list 'shadow shadow
|
|
'cascademenu ()
|
|
'poped ())
|
|
property))
|
|
(eval bar-list)))))
|
|
|
|
(defunq vtwm-pop-menu args
|
|
(with (pmenu (if (= (length args) 0)
|
|
(wob-menu)
|
|
(eval (# 0 args)))
|
|
pos (if (= (length args) 3)
|
|
(list (eval (# 1 args)) (eval (# 2 args)))
|
|
())
|
|
calling-wob wob
|
|
wob (menu-wob pmenu)
|
|
shadow (# 'shadow wob-property)
|
|
bw wob-borderwidth
|
|
wdt wob-width
|
|
hgt wob-height
|
|
wob calling-wob
|
|
xm (current-event-x)
|
|
ym (current-event-y)
|
|
xpos (if pos (# 0 pos) (- xm (/ wdt 2) bw))
|
|
ypos (if pos (# 1 pos) (- ym (/ vtwm-menu-item-height 2) bw)))
|
|
(if (< xpos 0)
|
|
(setq xpos 0)
|
|
(> (+ xpos wdt) screen-width)
|
|
(setq xpos (- screen-width wdt)))
|
|
(if (< ypos 0)
|
|
(setq ypos 0)
|
|
(> (+ ypos hgt) screen-height)
|
|
(setq ypos (max 0 (- screen-height hgt))))
|
|
(if (and vtwm-menu-shadow shadow)
|
|
(progn
|
|
(move-window (menu-wob shadow)
|
|
(+ xpos vtwm-menu-shadow-offset)
|
|
(+ ypos vtwm-menu-shadow-offset))
|
|
(pop-menu shadow 'here)
|
|
(ungrab-server (menu-wob shadow))))
|
|
(move-window (menu-wob pmenu) xpos ypos)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus ()))
|
|
(pop-menu pmenu 'here)
|
|
))
|
|
|
|
|
|
;;
|
|
;; Some useful routines
|
|
;;
|
|
|
|
(defun append-sublists (lists)
|
|
(eval (+ '(+) (mapfor lst lists (list 'quote lst)))))
|
|
|
|
(defun remove-nil (lst)
|
|
(with (ele ())
|
|
(while (setq ele (member () lst))
|
|
(delete-nth ele lst))
|
|
lst))
|
|
|
|
(defun upchar (char)
|
|
(or (# (atom char) '(a "A" b "B" c "C" d "D" e "E" f "F" g "G"
|
|
h "H" i "I" j "J" k "K" l "L" m "M" n "N"
|
|
o "O" p "P" q "Q" r "R" s "S" t "T" u "U"
|
|
v "V" w "W" x "X" y "Y" z "Z"))
|
|
char))
|
|
|
|
(defun capitalize (str)
|
|
(if (= (length str) 0)
|
|
" "
|
|
(with (pair (match "^\\(.\\)\\(.*\\)" str 1 2))
|
|
(+ (upchar (# 0 pair)) (# 1 pair)))))
|
|
|
|
(defun is-menu-item (obj)
|
|
(and (= (type obj) 'list)
|
|
(= (length obj) 2)
|
|
(= (type (# 0 obj)) 'bar)
|
|
(or (not (# 1 obj))
|
|
(= (type (# 1 obj)) 'bar))))
|
|
|
|
(defun is-sub-menu (obj)
|
|
(and (= (type obj) 'list)
|
|
()))
|
|
|
|
;;
|
|
;; Remote machine command menus
|
|
;;
|
|
|
|
(defun machine-name (host)
|
|
(capitalize (match "^\\([^.]*\\)" host 1)))
|
|
|
|
(setq xrsh-program "xrsh")
|
|
|
|
(defun xrsh-command (host command)
|
|
(if (equal host ".")
|
|
(with (host hostname)
|
|
(eval (+ '(!) command)))
|
|
(eval (+ (list '! xrsh-program host) command))))
|
|
|
|
(defun do-command (command)
|
|
(eval (+ '(!) command)))
|
|
|
|
(defun construct-machine-menu (name machine-list expr)
|
|
(apply 'vtwm-menu-make
|
|
(+ (list (vtwm-menu-label-make name))
|
|
(with (name (machine-name hostname))
|
|
(list (vtwm-menu-item-make name
|
|
(` (with (host "." name (, name))
|
|
(, expr))))))
|
|
(mapfor host machine-list
|
|
(with (name (machine-name host))
|
|
(vtwm-menu-item-make name
|
|
(` (with (host (, host) name (, name))
|
|
(, expr)))))))))
|
|
|
|
(defun construct-xrsh-menu args
|
|
(with (machine-list (# 0 args)
|
|
command (if (= (type (# 1 args)) 'list)
|
|
(# 1 args)
|
|
(sublist 1 (length args) args)))
|
|
(construct-machine-menu (capitalize (# 0 command))
|
|
machine-list
|
|
(` (xrsh-command host (quote (, command)))))))
|
|
|
|
(defun construct-machine-menu-items (machine-list expr)
|
|
(mapfor host machine-list
|
|
(with (name (machine-name host))
|
|
(vtwm-menu-item-make name
|
|
(` (with (host (, host) name (, name))
|
|
(, expr)))))))
|
|
|
|
(defun construct-window-menu (name expr)
|
|
(apply 'vtwm-menu-make
|
|
(+ (list (vtwm-menu-label-make name))
|
|
(remove-nil
|
|
(mapfor wob (list-of-windows 'window)
|
|
(if (not (= window-client-class 'Gwm))
|
|
(vtwm-menu-item-make window-name
|
|
(` (if (wob-is-valid (, wob))
|
|
(with (wob (, wob))
|
|
(, expr)))))))))))
|
|
|
|
(defun construct-window-menu-items (wlst expr)
|
|
(remove-nil
|
|
(mapfor wob (list-of-windows 'window)
|
|
(if (matches-token wlst)
|
|
(vtwm-menu-item-make window-name
|
|
(` (if (wob-is-valid (, wob))
|
|
(with (wob (, wob))
|
|
(, expr)))))))))
|
|
|
|
(defun construct-menu item-lists
|
|
(apply 'vtwm-menu-make
|
|
(apply '+
|
|
(mapfor items item-lists
|
|
(if (= (type items) 'string)
|
|
(list (vtwm-menu-label-make items))
|
|
(is-menu-item items)
|
|
(list items)
|
|
(and (= (type items) 'list)
|
|
(is-menu-item (# 0 items)))
|
|
items
|
|
(and (= (type items) 'list)
|
|
(= (type (# 0 items)) 'string))
|
|
(if (and (= (type (# 1 items)) 'atom)
|
|
(boundp (# 1 items))
|
|
(= (type (eval (# 1 items))) 'list))
|
|
(list (vtwm-menu-item-make (# 0 items)
|
|
(apply construct-menu
|
|
(eval (# 1 items)))))
|
|
(and (= (type (# 1 items)) 'atom)
|
|
(boundp (# 1 items))
|
|
(member (type (eval (# 1 items)))
|
|
'(expr subr fexpr fsubr)))
|
|
(list (vtwm-menu-item-make (# 0 items)
|
|
(eval (# 1 items))))
|
|
(and (= (type (# 1 items)) 'list)
|
|
(member (type (# 0 (# 1 items)))
|
|
'(string list)))
|
|
(list (vtwm-menu-item-make (# 0 items)
|
|
(apply construct-menu
|
|
(# 1 items))))
|
|
(list (vtwm-menu-item-make (# 0 items)
|
|
(# 1 items))))
|
|
())))))
|
|
|