400 lines
14 KiB
Plaintext
400 lines
14 KiB
Plaintext
;; edit-plug.gwm --- Code for general editable plug
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1996 Anders Holst
|
|
;; Last change: 19/1 1996
|
|
;;
|
|
;; 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 code implements a simple editable plug, which can be used in
|
|
;; various places in GWM. Simple examples include dialogues where the
|
|
;; user can feed in some text string to GWM (eg. the name of a new
|
|
;; virtual door to create or a machine to log into), or editable name
|
|
;; plugs in window and icon decorations.
|
|
;;
|
|
;; To create an editable plug, you just call '(edit-plug-make "string")'
|
|
;; where it would otherwise have said '(plug-make (label-make "string"))'.
|
|
;; Most communication with the plug is done via user events. To enable
|
|
;; editing you send it the event 'edit-plug-start'. To finish or abort
|
|
;; editing (that is, go into the passive state) you send 'edit-plug-done'
|
|
;; or 'edit-plug-abort' depending on whether the edit should have any
|
|
;; effect or not. To find out the new string in an editable plug, you can
|
|
;; send the event 'edit-plug-query' and then look at the variable
|
|
;; 'edit-plug-result', or you can use the function '(edit-plug-query)'
|
|
;; which does exactly this.
|
|
;;
|
|
;; When the plug is in its active state it obeys several editing keys,
|
|
;; including RETURN which finishes editing, and C-c or ESC which aborts
|
|
;; editing. (Unfortunately there is no keymap mechanism to allow the
|
|
;; user to redefine the meaning of the different keys, other than
|
|
;; modifying the fsm:s, see below.)
|
|
;;
|
|
;; 'edit-plug-make' considers several context variables. In addition to
|
|
;; the ones considered by 'plug-make' and 'label-make' it considers
|
|
;; 'font-slant' (which if defined determines the slant of the small bar
|
|
;; indicating the edit point in the string), 'active-foreground',
|
|
;; 'active-background', 'active-borderpixel' (which determines the colors
|
|
;; of the plug when in its active state), 'edit-plug-start-hook',
|
|
;; 'edit-plug-done-hook', and 'edit-plug-abort-hook' (which contains
|
|
;; code to run when starting, finishing, and aborting edit respectively).
|
|
;;
|
|
;; The fsm is built from the states 'edit-plug-normal-state' and
|
|
;; 'edit-plug-active-state'. To specify which events should start and stop
|
|
;; the editing, more events can be added to these states.
|
|
;; NOTE: Only change these variables in a with-statement and not
|
|
;; globally, since edit-plugs might be used in more than one place,
|
|
;; and the same behavior might not be appropriate everywhere.
|
|
;;
|
|
;; As an example of how the edit-plug can be used, there is a function
|
|
;; '(simple-dialogue "prompt")' defined, which prompts the user for a
|
|
;; string that is then returned. The color and appearance of the simple
|
|
;; dialogue box is affected by many of the above mentioned context
|
|
;; variables.
|
|
;;
|
|
|
|
|
|
(defun edit-plug-make (str)
|
|
(with (cnx (list 'foreground foreground 'background background
|
|
'borderpixel borderpixel 'font font
|
|
'active-foreground (default active-foreground foreground)
|
|
'active-background (default active-background background)
|
|
'active-borderpixel (default active-borderpixel ())
|
|
'font-slant (default font-slant 0)
|
|
'label-horizontal-margin label-horizontal-margin
|
|
'label-vertical-margin label-vertical-margin)
|
|
property (+ (list 'internals (list str () ())
|
|
'context cnx
|
|
'start-hook (default edit-plug-start-hook ())
|
|
'done-hook (default edit-plug-done-hook ())
|
|
'abort-hook (default edit-plug-abort-hook ()))
|
|
property)
|
|
fsm (fsm-make edit-plug-normal-state edit-plug-active-state))
|
|
(plug-make (edit-plug-label str ()))))
|
|
|
|
(defun edit-plug-label (str1 str2)
|
|
(with (str (if (and (= str1 "") (or (not str2) (= str2 "")))
|
|
" "
|
|
(+ str1 str2))
|
|
xoff (if (not str2)
|
|
()
|
|
(= str1 "")
|
|
(- label-horizontal-margin 1)
|
|
(- (# 2 (dimensions str1)) label-horizontal-margin 1))
|
|
lab ())
|
|
(setq lab (label-make str))
|
|
(if xoff
|
|
(draw-line lab
|
|
(+ xoff (- font-slant (/ font-slant 2)))
|
|
label-vertical-margin
|
|
(- xoff (/ font-slant 2))
|
|
(- (# 3 (dimensions " ")) label-vertical-margin 1)))
|
|
lab))
|
|
|
|
(defun edit-plug-update ()
|
|
(with (ilist (# 'internals wob-property)
|
|
cnx (# 'context wob-property))
|
|
(with cnx
|
|
(if (# 1 ilist)
|
|
(progn
|
|
(setq background active-background)
|
|
(setq foreground active-foreground)
|
|
(if active-borderpixel
|
|
(setq borderpixel active-borderpixel))))
|
|
(wob-tile (edit-plug-label (# 0 ilist) (# 1 ilist)))
|
|
(if active-borderpixel
|
|
(wob-borderpixel borderpixel)))))
|
|
|
|
(defun edit-plug-start ()
|
|
(with (ilist (# 'internals wob-property)
|
|
hook (# 'start-hook wob-property))
|
|
(eval hook)
|
|
(if (not (# 1 ilist))
|
|
(## 1 ilist ""))
|
|
(if (not (# 2 ilist))
|
|
(## 2 ilist (# 0 ilist)))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-start-dialogue ()
|
|
(with (ilist (# 'internals wob-property)
|
|
hook (# 'start-hook wob-property))
|
|
(eval hook)
|
|
(if (not (# 1 ilist))
|
|
(## 1 ilist ""))
|
|
(if (not (# 2 ilist))
|
|
(## 2 ilist (# 0 ilist)))
|
|
(edit-plug-update)
|
|
(with (grab-keyboard-also 1) (grab-server wob))))
|
|
|
|
(defun edit-plug-done ()
|
|
(with (ilist (# 'internals wob-property)
|
|
hook (# 'done-hook wob-property))
|
|
(if (# 1 ilist)
|
|
(## 0 ilist (+ (# 0 ilist) (# 1 ilist))))
|
|
(## 1 ilist ())
|
|
(## 2 ilist ())
|
|
(edit-plug-update)
|
|
(ungrab-server wob)
|
|
(setq edit-plug-result (# 0 ilist))
|
|
(eval hook)))
|
|
|
|
(defun edit-plug-abort ()
|
|
(with (ilist (# 'internals wob-property)
|
|
hook (# 'abort-hook wob-property))
|
|
(if (# 2 ilist)
|
|
(progn
|
|
(## 0 ilist (# 2 ilist))
|
|
(## 1 ilist ())
|
|
(## 2 ilist ())))
|
|
(edit-plug-update)
|
|
(ungrab-server wob)
|
|
(setq edit-plug-result ())
|
|
(eval hook)))
|
|
|
|
(defun edit-plug-insert (ch)
|
|
(with (ilist (# 'internals wob-property))
|
|
(## 0 ilist (+ (# 0 ilist) ch))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-delete ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist)
|
|
(## 1 ilist (match ".\\(.*\\)$" (# 1 ilist) 1)))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-backspace ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (not (= (# 0 ilist) ""))
|
|
(## 0 ilist (match "\\(.*\\).$" (# 0 ilist) 1)))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-delete-rest ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist)
|
|
(## 1 ilist ""))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-clear ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist)
|
|
(## 1 ilist ""))
|
|
(## 0 ilist "")
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-undo ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist)
|
|
(## 1 ilist ""))
|
|
(if (# 2 ilist)
|
|
(## 0 ilist (# 2 ilist)))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-eol ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist)
|
|
(progn
|
|
(## 0 ilist (+ (# 0 ilist) (# 1 ilist)))
|
|
(## 1 ilist "")))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-bol ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(## 1 ilist (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist)))
|
|
(## 0 ilist "")
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-backward ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (not (= (# 0 ilist) ""))
|
|
(progn
|
|
(## 1 ilist (+ (match ".*\\(.\\)$" (# 0 ilist) 1)
|
|
(or (# 1 ilist) "")))
|
|
(## 0 ilist (match "\\(.*\\).$" (# 0 ilist) 1))))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-forward ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist)
|
|
(progn
|
|
(## 0 ilist (+ (# 0 ilist)
|
|
(match "\\(.\\).*$" (# 1 ilist) 1)))
|
|
(## 1 ilist (match ".\\(.*\\)$" (# 1 ilist) 1))))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-fit-text (str wdt)
|
|
(with (ctx (# 'context wob-property)
|
|
wdt (+ wdt label-horizontal-margin 1)
|
|
pair () rest "")
|
|
(with ctx
|
|
(while (and (> (width str) wdt) (> (length str) 0))
|
|
(setq pair (match "\\(.*\\)\\(.\\)$" str 1 2))
|
|
(setq rest (+ (# 1 pair) rest))
|
|
(setq str (# 0 pair)))
|
|
(list str rest))))
|
|
|
|
(defun edit-plug-midstring (pair1 pair2 tot)
|
|
(with (n1 (length (# 0 pair1))
|
|
n2 (length (# 0 pair2))
|
|
n (length tot)
|
|
m (min n1 n2)
|
|
d (abs (- n1 n2))
|
|
reg ())
|
|
(if (= n1 n2) ""
|
|
(= n1 0) (# 0 pair2)
|
|
(= n2 0) (# 0 pair1)
|
|
(= n1 n) (# 1 pair2)
|
|
(= n2 n) (# 1 pair1)
|
|
t (progn
|
|
(setq reg (+ (apply + (list-make m ".")) "\\("
|
|
(apply + (list-make d ".")) "\\)"))
|
|
(match reg tot 1)))))
|
|
|
|
(defun edit-plug-xposition (pos)
|
|
(with (ilist (# 'internals wob-property)
|
|
str (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist))
|
|
pair (edit-plug-fit-text str pos))
|
|
(## 0 ilist (# 0 pair))
|
|
(## 1 ilist (# 1 pair))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-xposcopy (pos)
|
|
(with (ilist (# 'internals wob-property)
|
|
str (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist))
|
|
pair (edit-plug-fit-text str pos))
|
|
(if (not (= (# 0 pair) (# 0 ilist)))
|
|
(progn
|
|
(setq cut-buffer (edit-plug-midstring ilist pair str))
|
|
(## 0 ilist (# 0 pair))
|
|
(## 1 ilist (# 1 pair))
|
|
(edit-plug-update)))))
|
|
|
|
(defun edit-plug-change (str)
|
|
(with (ilist (# 'internals wob-property))
|
|
(## 0 ilist str)
|
|
(if (# 1 ilist)
|
|
(## 1 ilist ""))
|
|
(edit-plug-update)))
|
|
|
|
(defun edit-plug-get ()
|
|
(with (ilist (# 'internals wob-property))
|
|
(if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist))))
|
|
|
|
(defun edit-plug-query ()
|
|
(with (edit-plug-result ())
|
|
(send-user-event 'edit-plug-query wob)
|
|
edit-plug-result))
|
|
|
|
(defun edit-plug-reply ()
|
|
(setq edit-plug-result (edit-plug-get)))
|
|
|
|
(defun edit-plug-dialogue ()
|
|
(with (edit-plug-result t)
|
|
(send-user-event 'edit-plug-dialogue)
|
|
(while (= edit-plug-result t) (process-events))
|
|
edit-plug-result))
|
|
|
|
|
|
(setq edit-plug-active-state
|
|
(state-make
|
|
(on (user-event 'edit-plug-query)
|
|
(edit-plug-reply))
|
|
(on (user-event 'edit-plug-done)
|
|
(edit-plug-done)
|
|
edit-plug-normal-state)
|
|
(on (user-event 'edit-plug-abort)
|
|
(edit-plug-abort)
|
|
edit-plug-normal-state)
|
|
(on (user-event 'edit-plug-take-focus)
|
|
(set-focus wob))
|
|
(on (keypress (key-make "Return") alone)
|
|
(edit-plug-done)
|
|
edit-plug-normal-state)
|
|
(on (keypress (key-make "Left") alone)
|
|
(edit-plug-backward))
|
|
(on (keypress (key-make "Right") alone)
|
|
(edit-plug-forward))
|
|
(on (keypress (key-make "Home") alone)
|
|
(edit-plug-bol))
|
|
(on (keypress (key-make "End") alone)
|
|
(edit-plug-eol))
|
|
(on (keypress (key-make "Delete") alone)
|
|
(edit-plug-backspace))
|
|
(on (keypress (key-make "BackSpace") alone)
|
|
(edit-plug-backspace))
|
|
(on (keypress (key-make "Escape") alone)
|
|
(edit-plug-abort)
|
|
edit-plug-normal-state)
|
|
(on (keypress (key-make "c") with-control)
|
|
(edit-plug-abort)
|
|
edit-plug-normal-state)
|
|
(on (keypress (key-make "d") with-control)
|
|
(edit-plug-delete))
|
|
(on (keypress (key-make "f") with-control)
|
|
(edit-plug-forward))
|
|
(on (keypress (key-make "b") with-control)
|
|
(edit-plug-backward))
|
|
(on (keypress (key-make "e") with-control)
|
|
(edit-plug-eol))
|
|
(on (keypress (key-make "a") with-control)
|
|
(edit-plug-bol))
|
|
(on (keypress (key-make "k") with-control)
|
|
(edit-plug-delete-rest))
|
|
(on (keypress (key-make "w") with-control)
|
|
(edit-plug-clear))
|
|
(on (keypress (key-make "u") with-control)
|
|
(edit-plug-undo))
|
|
(on (keypress any any)
|
|
(with (code (keycode-to-keysym (current-event-code) (current-event-modifier)))
|
|
(if (and (> code 31) (< code 256))
|
|
(edit-plug-insert (last-key)))))
|
|
(on (buttonpress 1 alone)
|
|
(edit-plug-xposition (current-event-relative-x)))
|
|
(on (buttonrelease 1 alone)
|
|
(edit-plug-xposcopy (current-event-relative-x)))
|
|
(on (buttonpress 2 alone)
|
|
(progn
|
|
(edit-plug-xposition (current-event-relative-x))
|
|
(if cut-buffer (edit-plug-insert cut-buffer))))))
|
|
|
|
(setq edit-plug-normal-state
|
|
(state-make
|
|
(on (user-event 'edit-plug-query)
|
|
(edit-plug-reply))
|
|
(on (user-event 'edit-plug-dialogue)
|
|
(edit-plug-start-dialogue)
|
|
edit-plug-active-state)
|
|
(on (user-event 'edit-plug-start)
|
|
(edit-plug-start)
|
|
edit-plug-active-state)
|
|
(on (user-event 'edit-plug-take-focus)
|
|
(set-focus wob))))
|
|
|
|
(defun simple-dialogue args
|
|
(with (prompt (or (# 0 args) "")
|
|
def (or (# 1 args) "")
|
|
reenter-on-opening ()
|
|
old-borderwidth borderwidth
|
|
old-borderpixel borderpixel
|
|
bordertile ()
|
|
borderpixel background
|
|
borderwidth 1
|
|
res ()
|
|
mn (with (direction vertical)
|
|
(menu-make
|
|
(bar-make (with (borderwidth old-borderwidth)
|
|
(plug-make (label-make prompt))))
|
|
(bar-make (with (borderwidth old-borderwidth
|
|
borderpixel old-borderpixel)
|
|
(edit-plug-make def))))))
|
|
(if mn
|
|
(with (dim (dimensions mn)
|
|
x (/ (- screen-width (# 2 dim)) 2)
|
|
y (/ (- screen-height (# 3 dim)) 2)
|
|
wob (place-menu 'dialogue mn x y))
|
|
(setq res (edit-plug-dialogue))
|
|
(delete-window)
|
|
res))))
|