590 lines
20 KiB
Plaintext
590 lines
20 KiB
Plaintext
;; fvwm-menu.gwm --- Menu constructors for the FVWM profile
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1999 Anders Holst
|
|
;; Last change: 2/5 1999
|
|
;;
|
|
;; 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 is mainly just a copy of vtwm-menu.gwm, with slight adjustment
|
|
;; of the menu look. Note that the menu constructors defined at the end
|
|
;; collides with the same functions in vtwm-menu.gwm, so only one of
|
|
;; the files should be loaded.
|
|
;;
|
|
;; 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 fvwmrc.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 'fvwm-pop-menu'.
|
|
;;
|
|
|
|
|
|
(declare-screen-dependent
|
|
fvwm-menu-color
|
|
fvwm-menu-text-color
|
|
fvwm-menu-font
|
|
fvwm-menu-label-font
|
|
fvwm-menu-item-height
|
|
fvwm-menu-min-width
|
|
)
|
|
|
|
;;
|
|
;; USER CUSTOMIZABLE VARIABLES
|
|
;; ---------------------------
|
|
;; Adjust these in your own profile
|
|
;;
|
|
(for screen (list-of-screens)
|
|
(defaults-to
|
|
fvwm-menu-color "gray" ; Foreground of menus
|
|
fvwm-menu-text-color "black" ; Background of menus
|
|
fvwm-menu-font "8x13" ; Menu item font
|
|
fvwm-menu-label-font () ; Menu label font (defaults to above)
|
|
fvwm-menu-item-height 22 ; Height of a menu item
|
|
fvwm-menu-min-width 100 ; Minimum width of menu
|
|
)
|
|
)
|
|
|
|
;;=============================================================
|
|
|
|
(require 'fvwm-window)
|
|
|
|
(defun fvwm-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 fvwm-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 fvwm-menu-root ()
|
|
(with (wob wob mf ())
|
|
(while (setq mf (fvwm-menu-father))
|
|
(setq wob mf))
|
|
wob))
|
|
|
|
(defun fvwm-pop-cascade ()
|
|
(if (# 'menu-expr wob)
|
|
(setq wob-menu (eval (# 'menu-expr wob))))
|
|
(with (cascademenu (menu-wob wob-menu)
|
|
cascaderoot (fvwm-menu-root)
|
|
wm wob-menu)
|
|
(ungrab-server)
|
|
(grab-server cascaderoot)
|
|
(with (wob (fvwm-menu-father))
|
|
(## 'cascademenu wob cascademenu))
|
|
(## 'poped cascademenu t)
|
|
(with (wob (fvwm-menu-father-item))
|
|
(fvwm-pop-menu wm (+ wob-x (width wob)) wob-y))
|
|
(ungrab-server)
|
|
(grab-server cascaderoot)))
|
|
|
|
(defun fvwm-unpop-cascade ()
|
|
(if (# 'cascademenu wob)
|
|
(with (wob (# 'cascademenu wob))
|
|
(fvwm-unpop-cascade)
|
|
(with (wob (fvwm-menu-father-item))
|
|
(send-user-event 'inactive wob))
|
|
(## 'poped wob nil)
|
|
(fvwm-unpop-menu)))
|
|
(## 'cascademenu wob nil))
|
|
|
|
(defun fvwm-unpop-old-cascade ()
|
|
(with (thiswob (if wob-menu (menu-wob wob-menu))
|
|
wob (fvwm-menu-father))
|
|
(if (not (= (# 'cascademenu wob) thiswob))
|
|
(fvwm-unpop-cascade))))
|
|
|
|
(defun fvwm-unpop-all-cascade ()
|
|
(with (wob (fvwm-menu-root))
|
|
(fvwm-unpop-cascade)
|
|
(## 'poped wob nil)
|
|
(fvwm-unpop-menu)))
|
|
|
|
(defun fvwm-unpop-menu ()
|
|
(unpop-menu wob))
|
|
|
|
|
|
(setq fvwm-menu-item-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (fvwm-menu-root)) wob-parent)
|
|
action (# 'action wob-property))
|
|
(send-user-event 'inactive wob)
|
|
(wob wob-parent)
|
|
(fvwm-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
|
|
(fvwm-unpop-old-cascade)
|
|
(send-user-event 'active wob)
|
|
(if (if wob-menu
|
|
(not (# 'poped (menu-wob wob-menu)))
|
|
(# 'menu-expr wob-property))
|
|
(fvwm-pop-cascade))
|
|
))
|
|
(on leave-window
|
|
(if (not (or (# 'menu-expr wob-property)
|
|
wob-menu))
|
|
(send-user-event 'inactive wob)))
|
|
(on (user-event 'active)
|
|
(wob-tile (# 'atile wob)))
|
|
(on (user-event 'inactive)
|
|
(wob-tile (# 'tile wob))))))
|
|
|
|
(setq fvwm-menu-item-inner-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (user-event 'active)
|
|
(wob-tile (# 'atile wob)))
|
|
(on (user-event 'inactive)
|
|
(wob-tile (# 'tile wob))))))
|
|
|
|
(setq fvwm-menu-label-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on enter-window
|
|
(progn
|
|
(fvwm-unpop-old-cascade)
|
|
)))))
|
|
|
|
(setq fvwm-menu-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (fvwm-menu-root)) wob-parent))
|
|
(fvwm-unpop-all-cascade)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus (with (wob calling-wob) window)))))
|
|
)))
|
|
|
|
(defun fvwm-menu-topbar ()
|
|
(with (tile ()
|
|
background (# 0 color-scheme)
|
|
foreground background
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
pix (pixmap-make 2 2)
|
|
foreground (# 2 color-scheme))
|
|
(draw-line pix 1 1 1 1)
|
|
(bar-make () (plug-make pix))))
|
|
|
|
(defun fvwm-menu-bottombar ()
|
|
(with (tile ()
|
|
background (# 2 color-scheme)
|
|
foreground (# 0 color-scheme)
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
pix (pixmap-make 2 2)
|
|
foreground background)
|
|
(draw-line pix 1 1 1 1)
|
|
(with (background (# 2 color-scheme))
|
|
(bar-make (plug-make pix) ()))))
|
|
|
|
(defun fvwm-menu-labeltile (size)
|
|
(with (tile ()
|
|
pix (with (foreground background) (pixmap-make 1 size)))
|
|
(draw-line pix 0 (- size 3) 0 (- size 3))
|
|
(draw-line pix 0 (- size 1) 0 (- size 1))
|
|
pix))
|
|
|
|
(defun fvwm-menu-itemtile (size active)
|
|
(with (fsm fvwm-menu-item-inner-fsm
|
|
background (# 1 color-scheme)
|
|
tile ()
|
|
foreground background
|
|
pix (pixmap-make 1 size))
|
|
(if active
|
|
(progn
|
|
(with (foreground (# 0 color-scheme))
|
|
(draw-line pix 0 0 0 1))
|
|
(with (foreground (# 2 color-scheme))
|
|
(draw-line pix 0 (- size 2) 0 (- size 1)))))
|
|
pix))
|
|
|
|
(defun fvwm-menu-vplug (size side)
|
|
(with (fsm fvwm-menu-item-inner-fsm
|
|
tile ()
|
|
foreground (# 1 color-scheme)
|
|
pix (pixmap-make 1 size)
|
|
foreground (# (if (= side 'left) 0 2) color-scheme)
|
|
apix (pixmap-make 1 size))
|
|
(if (= side 'left)
|
|
(with (foreground (# 2 color-scheme))
|
|
(draw-line apix 0 (- size 1) 0 (- size 1)))
|
|
(with (foreground (# 0 color-scheme))
|
|
(draw-line apix 0 0 0 0)))
|
|
(with (property (list 'tile pix 'atile apix))
|
|
(plug-make pix))))
|
|
|
|
(defun fvwm-menu-subarrow (size)
|
|
(with (fsm fvwm-menu-item-inner-fsm
|
|
tile ()
|
|
foreground (# 1 color-scheme)
|
|
size (- size 4)
|
|
pix (pixmap-make size size)
|
|
apix (pixmap-make size size)
|
|
x1 (/ size 3)
|
|
x2 (- size x1 (% size 2) -1)
|
|
h (/ size 2))
|
|
(with (foreground (# 0 color-scheme))
|
|
(draw-line pix x1 x1 x1 x2)
|
|
(draw-line pix x1 x1 x2 h)
|
|
(draw-line apix x1 x2 x2 h))
|
|
(with (foreground (# 2 color-scheme))
|
|
(draw-line apix x1 x1 x1 x2)
|
|
(draw-line apix x1 x1 x2 h)
|
|
(draw-line pix x1 x2 x2 h))
|
|
(with (property (list 'tile pix 'atile apix))
|
|
(plug-make pix))))
|
|
|
|
(defun fvwm-menu-separator-make ()
|
|
(with (fsm ()
|
|
tile ()
|
|
borderwidth 0
|
|
color-scheme (make-color-scheme fvwm-menu-color fvwm-menu-text-color)
|
|
background (# 2 color-scheme)
|
|
foreground (# 0 color-scheme)
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
left (pixmap-make 1 2)
|
|
right (pixmap-make 1 2)
|
|
tile (pixmap-make 1 2)
|
|
foreground background
|
|
)
|
|
(draw-line tile 0 0 0 0)
|
|
(draw-line right 0 0 0 1)
|
|
(bar-make (plug-make left) () (plug-make right))))
|
|
|
|
(defun fvwm-menu-item-make (label action)
|
|
(with (borderwidth 0
|
|
color-scheme (make-color-scheme fvwm-menu-color fvwm-menu-text-color)
|
|
font (if (= (type fvwm-menu-font) 'string)
|
|
(font-make fvwm-menu-font)
|
|
fvwm-menu-font)
|
|
background (# 1 color-scheme)
|
|
foreground (# 3 color-scheme)
|
|
fsm fvwm-menu-item-fsm
|
|
menu (if (= (type action) 'menu) action)
|
|
menu-expr (if (member (type action) '(expr subr fexpr fsubr))
|
|
(list action))
|
|
bar-min-width fvwm-menu-item-height
|
|
bar-max-width bar-min-width
|
|
plug-separator 0
|
|
ntile (label-make label)
|
|
left0 (with (fsm ()
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
background (# 0 color-scheme))
|
|
(bar-make ))
|
|
right0 (with (fsm ()
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
background (# 2 color-scheme))
|
|
(bar-make ))
|
|
left (fvwm-menu-vplug fvwm-menu-item-height 'left)
|
|
right (fvwm-menu-vplug fvwm-menu-item-height 'right)
|
|
atile (fvwm-menu-itemtile fvwm-menu-item-height t)
|
|
tile (fvwm-menu-itemtile fvwm-menu-item-height ())
|
|
arrow (if (or menu menu-expr)
|
|
(fvwm-menu-subarrow fvwm-menu-item-height))
|
|
property (+ (if (not (or menu menu-expr))
|
|
(list 'action action))
|
|
(if menu-expr
|
|
(list 'menu-expr menu-expr))
|
|
(list 'tile tile 'atile atile)))
|
|
(bar-make
|
|
left0
|
|
left
|
|
(with (borderwidth 0
|
|
fsm ()
|
|
property ())
|
|
(plug-make ntile))
|
|
()
|
|
arrow
|
|
right
|
|
right0)))
|
|
|
|
(defun fvwm-menu-label-make (label)
|
|
(with (borderwidth 0
|
|
color-scheme (make-color-scheme fvwm-menu-color fvwm-menu-text-color)
|
|
background (# 1 color-scheme)
|
|
foreground (# 3 color-scheme)
|
|
bar-min-width fvwm-menu-item-height
|
|
bar-max-width bar-min-width
|
|
plug-separator 0
|
|
fsm fvwm-menu-label-fsm
|
|
left (with (fsm ()
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
background (# 0 color-scheme))
|
|
(bar-make ))
|
|
right (with (fsm ()
|
|
bar-max-width 2
|
|
bar-min-width bar-max-width
|
|
background (# 2 color-scheme))
|
|
(bar-make ))
|
|
tile (fvwm-menu-labeltile fvwm-menu-item-height)
|
|
menu ())
|
|
(bar-make
|
|
left
|
|
()
|
|
(with (borderwidth 0
|
|
fsm ()
|
|
font (if (= (type fvwm-menu-label-font) 'string)
|
|
(font-make fvwm-menu-label-font)
|
|
fvwm-menu-label-font
|
|
fvwm-menu-label-font
|
|
(= (type fvwm-menu-font) 'string)
|
|
(font-make fvwm-menu-font)
|
|
fvwm-menu-font))
|
|
(plug-make (label-make label)))
|
|
()
|
|
right)))
|
|
|
|
(defun fvwm-menu-make args
|
|
(if args
|
|
(with (menu ()
|
|
fsm fvwm-menu-fsm
|
|
menu-min-width fvwm-menu-min-width
|
|
borderwidth 0
|
|
bar-separator 0
|
|
direction vertical
|
|
property ()
|
|
color-scheme (make-color-scheme fvwm-menu-color
|
|
fvwm-menu-text-color)
|
|
top (fvwm-menu-topbar)
|
|
bottom (fvwm-menu-bottombar)
|
|
res ())
|
|
(apply 'menu-make (+ (list top) args (list bottom))))))
|
|
|
|
(defunq fvwm-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)
|
|
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 (/ fvwm-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))))
|
|
(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)
|
|
(= (type 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 'fvwm-menu-make
|
|
(+ (list (fvwm-menu-label-make name))
|
|
(with (name (machine-name hostname))
|
|
(list (fvwm-menu-item-make name
|
|
(` (with (host "." name (, name))
|
|
(, expr))))))
|
|
(mapfor host machine-list
|
|
(with (name (machine-name host))
|
|
(fvwm-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))
|
|
(fvwm-menu-item-make name
|
|
(` (with (host (, host) name (, name))
|
|
(, expr)))))))
|
|
|
|
(defun construct-window-menu (name expr)
|
|
(apply 'fvwm-menu-make
|
|
(+ (list (fvwm-menu-label-make name))
|
|
(remove-nil
|
|
(mapfor wob (list-of-windows 'window)
|
|
(if (not (= window-client-class 'Gwm))
|
|
(fvwm-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)
|
|
(fvwm-menu-item-make window-name
|
|
(` (if (wob-is-valid (, wob))
|
|
(with (wob (, wob))
|
|
(, expr)))))))))
|
|
|
|
(defun construct-menu item-lists
|
|
(apply 'fvwm-menu-make
|
|
(apply '+
|
|
(mapfor items item-lists
|
|
(if (= (type items) 'string)
|
|
(list (fvwm-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 (fvwm-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 (fvwm-menu-item-make (# 0 items)
|
|
(eval (# 1 items))))
|
|
(and (= (type (# 1 items)) 'list)
|
|
(member (type (# 0 (# 1 items)))
|
|
'(string list)))
|
|
(list (fvwm-menu-item-make (# 0 items)
|
|
(apply construct-menu
|
|
(# 1 items))))
|
|
(list (fvwm-menu-item-make (# 0 items)
|
|
(# 1 items))))
|
|
())))))
|
|
|