🚀 go-pugleaf

The file appended below implements and Epoch interface to the "xmenu",
"xprompt", and "xmessage" utility programs.

				  		- Mark Kolb
						  kolb@crd.ge.com

;;;  -*- Mode: Emacs-Lisp -*-

;;;  File written by Mark A. Kolb, Mon, Jan 14 1991.
;;;  Code for calling the xmenu, xmessage, and xprompt utility programs.
;;;  The original xmenu implementation was by Gill Derge.
;;;  Please send any enhancements, bug reports, or feature requests
;;;  to kolb@crd.ge.com.

(provide 'x-utils)

;;;;  XMENU

(defvar xmenu-program "/usr/bin/X11/xmenu"
  "Location of the xmenu utility program.")

(defun xmenu (heading choices &optional choice-list)
  "Pops up an XMENU menu to select a string from among CHOICES.
Returns the selected string or NIL if the abort option is selected.
If CHOICE-LIST is provided, then instead of returning a string from
CHOICES, the corresponding item from CHOICE-LIST is returned."
  (let* ((screen-info (epoch::screen-information))
	 (width (caddr screen-info)))
    (let ((filtered-choices (xmenu-string-items choices))
	  (choice-count (length choices))
	  (abort-string "Abort Menu")
	  (xmenu-output nil)		; Note reliance on dynamic scoping
	  (xmenu-process nil))
      (epoch::warp-pointer (- width 10) 10)
      (set-process-filter
       (setq xmenu-process
	     (apply 'start-process "xmenu" nil xmenu-program
		    "-heading" heading "-fn" (car (epoch::font))
		    "-geometry" (xgeometry-from-mouse nil nil -40 -25)
		    (nconc filtered-choices
			   (list "-line" (format "%s=%d"
						 abort-string choice-count)))))
       'xmenu-filter)
      (while (eq (process-status xmenu-process) 'run) (sleep-for 1))
      (let* ((result-int (string-to-int xmenu-output))
	     (result (if (= result-int choice-count)
			 nil
		       (nth result-int (or choice-list choices)))))
	result))))

(defun xmenu-filter (process output)
  (setq xmenu-output (strip-last-char output)))



;;;;  XMESSAGE

(defvar xmessage-program "/usr/bin/X11/xmessage"
  "Location of the xmessage utility program.")

(defun xmessage (message &optional buttons width height)
  "Pops up an XMESSAGE window to display MESSAGE, with dimensions WIDTHxHEIGHT.
If specified, BUTTONS should be a list of strings representing possible
responses to MESSAGE.  If BUTTONS is non-NIL, this function returns the
string corresponding to the selected button."
  (let ((xmessage-output nil)		; Note reliance on dynamic scoping 
	(xmessage-process nil)
	(xgeom (xgeometry-from-mouse width height -110 -10)))
    (if (null buttons)
	(start-process "xmessage" nil xmessage-program
		       "-geometry" xgeom "-print"
		       "-message" message)
	(progn
	  (set-process-filter
	   (setq xmessage-process
		 (start-process "xmessage" nil xmessage-program
				"-geometry" xgeom "-print"
				"-buttons" (format-xmessage-buttons buttons)
				"-message" message))
	   'xmessage-filter)
	  (while (eq (process-status xmessage-process) 'run) (sleep-for 1))
	  xmessage-output))))

(defun xmessage-filter (process output)
  (setq xmessage-output (strip-last-char output)))

(defun format-xmessage-buttons (button-strings)
  "Parses the list of BUTTON-STRINGS into a format acceptable to XMESSAGE."
  (let ((button-names (car button-strings)))
    (dolist (a-button (cdr button-strings))
       (setq button-names (concat button-names "," a-button)))
    button-names))



;;;;  XPROMPT

(defvar xprompt-program "/usr/bin/X11/xprompt"
  "Location of the xprompt utility program.")

(defun xprompt (fields default-responses &optional response-length)
  "Pops up an XPROMPT window to prompt the user for values for FIELDS.
DEFAULT-RESPONSES should be a list of default responses for the prompts
in FIELDS, where a null entry corresponds to no default response.
RESPONSE-LENGTH, if specified, indicates the amount of space (in characters)
to reserve for the user's responses.
This function returns a list of those responses to the FIELDS prompts."
  (when (null response-length) (setq response-length 20))
  (let ((xprompt-arglist nil)
	(xprompt-output nil)		; Note reliance on dynamic scoping
	(xprompt-process nil))
    (do ((remaining-fields fields (cdr remaining-fields))
	 (remaining-responses default-responses (cdr remaining-responses)))
	((null remaining-fields))
      (let ((field (car remaining-fields))
	    (default-response (car remaining-responses)))
	(setq xprompt-arglist (cons field
				    (cons "-p" xprompt-arglist)))
	(when default-response
	  (setq xprompt-arglist (cons default-response
				      (cons "-r" xprompt-arglist))))))
    (set-process-filter
     (setq xprompt-process
	   (apply 'start-process "xprompt" nil xprompt-program
		  "-geometry" (xgeometry-from-mouse nil nil -100 -10)
		  "-grab" "-rlen" (format "%d" response-length)
		  (nreverse xprompt-arglist)))
     'xprompt-filter)
    (while (eq (process-status xprompt-process) 'run)
      (sleep-for 1))
    (nreverse xprompt-output)))

(defun xprompt-filter (process output)
  (setq xprompt-output (cons (strip-last-char output) xprompt-output)))



;;;  Auxiliary functions for filtering XMENU choice strings.
;;;  This munging is necessary because we're passing out arbitrary
;;;  strings to the shell.  Much of this code is also courtesy Gill Derge.

(defvar xmenu-max-width 20)

(defun xmenu-string-items (strings)
  "Transform STRINGS into a list of menu choices suitable for XMENU,
tacking on an equals sign and a count onto the end of each transformed string."
  (%xmenu-string-items strings 0))

(defun %xmenu-string-items (strings count)
  (if (null strings) nil
    (cons (xmenu-string-item (car strings) count)
	  (%xmenu-string-items (cdr strings) (1+ count)))))

(defun xmenu-string-item (string count)
  "Transforms STRING into a choice-item for XMENU.
This function will also tack on the the number of the item.
Thus, (xmenu-string-item \"This string\") will yield \"This string=0\"
if COUNT is zero.  Truncation is also performed here--menu items are of
finite width."
  (let ((shortened-string (if (< (length string) xmenu-max-width)
			      string
			    (concat (substring string 0 (- xmenu-max-width 3))
				    "..."))))
    (format "%s=%d"
	    (quote-regexp (quote-regexp shortened-string "\\\\") "=")
	    count)))

(defun quote-regexp (string regexp)
  "Quote anything in STRING that matches REGEXP with '\'."
  (let ((str-len (length string))
	(work-str string)
	last-match)
    (setq last-match 0)
    (while (< last-match str-len)
      (if (string-match regexp (substring work-str last-match nil))
	  (progn (setq last-match (+ last-match (match-end 0)))
		 (setq work-str
		       (concat
			(substring work-str 0 (- last-match 1)) "\\"
			(substring work-str (- last-match 1) nil)))
		 (setq last-match (+ last-match 2))
		 (setq str-len (+ str-len 2)))
	(setq last-match str-len)))
    work-str))




;;;;  Auxiliary functions for processing output and geometry.

(defun strip-last-char (string)
  (substring string 0 (- (length string) 1)))

(defun xgeometry-from-mouse (&optional width height x-offset y-offset)
  (when (null x-offset) (setq x-offset 0))
  (when (null y-offset) (setq y-offset 0))
  (let* ((screen-info (epoch::screen-information))
	 (screen-x (car screen-info))
	 (screen-y (cadr screen-info))
	 (mouse-state (epoch::query-pointer))
	 (pointer-x (car mouse-state))
	 (pointer-y (cadr mouse-state))
	 (x-pos (+ screen-x pointer-x x-offset))
	 (y-pos (+ screen-y pointer-y y-offset)))
;    (message "Geometry at (%d,%d) + (%d,%d) + (%d,%d) = (%d,%d)."
;	     screen-x screen-y pointer-x pointer-y x-offset y-offset
;	     x-pos y-pos)
    (if (and width height)
	(format "%dx%d+%d+%d" width height x-pos y-pos)
	(format "+%d+%d" x-pos y-pos))))
    



;;;;  Test Code

;(xmenu "Test" '("Yes" "No" "Maybe"))
;(xmenu "Number Test" '("one" "two" "three") '(1 2 3))
;(xmessage "How's this?" '("Fine" "Terrible"))
;(xmessage "The favor of a reply is not necessary.")
;(xprompt '("Name" "Host" "Color") (list (getenv "USER") (getenv "HOST")))



;;;  End of file