* RE: cl-extra not loaded
2003-06-06 17:02 ` Richard Stallman
@ 2003-06-06 21:09 ` Kenneth Evans, Jr.
0 siblings, 0 replies; 5+ messages in thread
From: Kenneth Evans, Jr. @ 2003-06-06 21:09 UTC (permalink / raw)
Cc: Ken Evans
[-- Attachment #1: Type: text/plain, Size: 1449 bytes --]
Richard,
The error message appears from the following function. err is
(void-variable cl-builtin-gethash). The rest of eserve.el and workshop.el,
both supplied by Sun, are attached. My elisp is not good enough to trace
exactly how cl-builtin-gethash is used. There are no occurences of cl-* in
these two files. It works in 20.3.2 and before. Thanks,
-Ken
(defun eserve-connection-filter (process output)
"Process filter to handle output from the eserve process."
(if eserve-connection
(set-process-filter eserve-connection t))
(unwind-protect
(condition-case err
(progn
(eserve-log-message "Eserve --> Emacs: %s" output)
(eserve-eval-cmds output))
(error
(message "Error during eserve msg evaluation: %s" err)
(eserve-log-message "Error during eserve msg evaluation: %s %s" err
output)))
(when eserve-connection
(set-process-filter eserve-connection 'eserve-connection-filter)))
(when eserve-connection
(set-process-filter eserve-connection 'eserve-connection-filter)))
-----Original Message-----
From: Richard Stallman [mailto:rms@gnu.org]
Sent: Friday, June 06, 2003 12:03 PM
To: Kevin Rodgers; Ken Evans
Cc: gnu-emacs-bug@moderators.isc.org
Subject: Re: cl-extra not loaded
cl-builtin-gethash seems to be entirely unused. It does not occur
anywhere except in cl-extra.el. Is it used in some other obscure way?
How exactly does it happen that eserve.el uses that variable?
[-- Attachment #2: eserve.el --]
[-- Type: application/octet-stream, Size: 69720 bytes --]
;; eserve.el --- Implements Emacs side of EditServer-Emacs interface.
;; Copyright (C) 10/11/00 Sun Microsystems, Inc.
;; Created: July 1994
;; Version: 1.136
;; Header: @(#) eserve.el: v1.136 01/05/15 22:59:43
;; Keywords: Edit Server GNU Emacs XEmacs integration
;;; To Do:
;;
;; User settable variables
;;
;; NOTE: If the user would rather the fkeys be left alone,
;; then the variable eserve-bind-fkeys should be set to nil (before
;; the application elisp files are loaded)
;;
(defvar eserve-bind-fkeys t
"*If t, add bindings for function keys.")
;; NOTE: IF the user would rather not have Emacs save all files
;; before starting a build, then the variable eserve-save-files
;; should be set to nil (before the application elisp files are
;; loaded)
(defvar eserve-save-files t
"*If t, save files before building.")
;; Timeout to be used for the Balloon Expression Evaluation (in
;; milliseconds). This is the default value; it might be overridden by
;; eserve's messages, and eserve stores this information in .eserverc.
(defvar eserve-balloon-eval-delay 600
"*Delay for the Balloon Expression Evaluation, in milliseconds.")
;; Whether or not balloon evaluation is currently on. This is the
;; default value; it might be overridden by eserve's messages, and
;; eserve stores this information in .eserverc.
(defvar eserve-balloon-evaluation t
"*If t, WorkShop balloon expression evaluation is on.")
(defvar eserve-path nil
"*The path to the eserve binary. Used to override use of PATH variable.")
(defvar eserve-toolbar-orientation 'top
"*Which frame edge to place the WorkShop toolbar.
Possible values are 'top (default), 'left, 'right, 'bottom, or nil
If you specify a value other than 'top, you will be able to simultaneously
have both the default XEmacs toolbar and the WorkShop toolbar.
If you specifiy nil, the WorkShop toolbar will not be shown.")
(defvar eserve-toolbar-visible-p t
"*Whether the WorkShop toolbar is visible.")
(defvar eserve-extent-priority 1
"*Priority of the extents for the eserve line marks.
Set this to 0 to allow font-lock and other default-priority
extents to be visible within an eserve-marked line.")
;;
;; %%%%%%%%%%%%%%%%%%%%%%% user section ends %%%%%%%%%%%%%%%%%%%
;;
(require 'cl) ;Common Lisp compatibility
;;
;; Global variables
;;
;; Create and initialize global variables
;;
(defvar eserve-connection nil "eserve process object")
(defvar eserve-app-name nil "Name of application attached to emacs")
(defvar eserve-app-cb nil "Function to call after application launched")
(defvar eserve-started-by-emacs nil "If t, eserve started from emacs")
(defvar eserve-protocol-version 4 "Version of the protocol to eserve")
(defvar eserve-protocol-version-minor 0 "Minor version of the protocol to eserve")
(defvar eserve-protocol-version-micro 0 "Micro version of the protocol to eserve")
;; Determine whether we are running GNU Emacs v19 or XEmacs.
(defvar running-xemacs nil "t if we're running XEmacs")
(defvar running-emacs nil "t if we're running GNU Emacs 19")
(if (string-match "XEmacs" emacs-version)
(setq running-xemacs t)
(setq running-emacs t))
;; We need to use prime numbers here (e.g. 127, 509, ...)
;; to reduce the likelihood of collisions.
(defvar eserve-buffers-marks-size 127
"Initial size of buffers-mark vectors list")
(defvar eserve-mark-vector-chunk 127
"Size of eserve-mark-vector chunk")
(defvar eserve-buffers-marks-hash
(make-hash-table :test 'eq :size eserve-buffers-marks-size)
"Hash table containing buffers and their associated mark vectors")
(defvar eserve-message-leftover nil
"Contains partial message saved across buffer sends from eserve")
(defvar eserve-mark-type-list nil
"List of mark types which describe the visible properties of a mark")
(defvar eserve-toolbar-specifier nil)
(defvar eserve-toolbar-size-specifier nil)
(defvar eserve-toolbar-visible-p-specifier nil)
(defvar eserve-current-toolbar nil "The current eserve toolbar")
(defvar eserve-toolbar-icon-size 25 "Size of WorkShop toolbar icons, in pixels")
(defvar eserve-toolbar-table nil
"A vector of vectors which holds the descriptions of toolbar items.
Each toolbar item comprises
0 file..........(string) the pixmap filename
1 verb..........(string) the verb (action) to be performed
2 help..........(string) the help text to display when over the icon
3 needsFilePos..(boolean) indicates if selection contents and position
should also be sent with the verb
4 offset........(integer) the spacing (in pixels) to the previous icon
or edge. This is treated as a hint by Emacs and
may be rounded up or down modulo
pixels/default-character-width.
5 label.........(string) a label to use if an icon can't be created.")
(defvar eserve-startup-file nil
"File containing code to connect app/emacs")
(defvar eserve-startup-envvar "SPRO_EDITOR_RENDEZVOUS_FILE"
"Env var whose value indicates the startup file")
(defvar eserve-menus nil "List of app-defined menus")
(defvar eserve-verb-hash-size 127 "Initial size of eserve-verb-button-hash table")
(defvar eserve-verb-button-hash
(make-hash-table :test 'equal :size eserve-verb-hash-size)
"Hash table containing verb strings and their associated buttons")
;;; We should uncomment the following, when WorkShop no longer unconditionally
;;; saves files it knows about. See EOU 1234353
;;(defvar eserve-ask-about-save t
;; "*If not nil, WorkShop asks which buffers to save before compiling.
;;Otherwise, it saves all modified buffers without asking.")
(defvar eserve-save-verbs
'("build.build"
"build.build-file"
"debug.fix"
"debug.fix-all")
"List of verbs known to eserve which trigger a call to `save-some-buffers'.")
;;
;; Emacs-specific variables
;;
(defvar eserve-launch-process nil)
(defvar eserve-launch-timer-max 180)
(defvar eserve-launch-timer-increment 5)
(defvar eserve-launch-timer-process nil)
(defvar eserve-launch-current-time 0)
(defvar eserve-launch-abort nil)
;;
;; Debugging and tracing
;;
(defvar eserve-log-buffer nil
"Log for eserve/emacs message traffic")
(eval-and-compile
(fset 'eserve-log-message 'ignore))
(when (getenv "SPRO_ELISP_DEBUG")
(setq debug-on-error t)
;;(setq debug-on-signal t)
(setq eserve-log-buffer (get-buffer-create "*eserve-log*"))
(defun eserve-log-message (&rest format-args)
(when (and eserve-log-buffer (buffer-name eserve-log-buffer))
(save-excursion
(set-buffer eserve-log-buffer)
(goto-char (point-max))
(insert (apply 'format format-args) "\n"))))
)
;; Restore EMACSLOADPATH, modified in eserve/src/Emacs.cc
(when running-xemacs
(setenv "EMACSLOADPATH" (getenv "SPRO_SAVE_EMACSLOADPATH"))
(setenv "SPRO_SAVE_EMACSLOADPATH" nil))
;;
;; Suppress compiler warnings
;;
(eval-when-compile
;; define functions conditionally available
(loop for fun in
'(set-process-input-coding-system
set-process-output-coding-system
iconify-or-deiconify-frame
make-overlay overlay-put delete-overlay) do
(when (not (fboundp fun)) (defalias fun 'ignore)))
(defvar sunpro-dir) ; XEmacs > 19.14
(defvar pathname-coding-system) ; XEmacs Mule
(defvar menu-bar-final-items)) ; GNU Emacs
;;
;; eserve initialization
;;
(defun eserve-init ()
"Initialize Emacs for communication with eserve.
This function is called from the command line which invokes Emacs."
(eserve-log-message "%s started." emacs-version)
(eserve-log-message "%s" command-line-args)
;; GNU Emacs 19 - XEmacs compatibility
(unless (fboundp 'raise-frame) (fset 'raise-frame 'raise-screen))
(unless (fboundp 'window-frame) (fset 'window-frame 'window-screen))
;; Choose the correct overlay-or-extent creation & deletion functions.
(when running-xemacs
(defalias 'eserve-set-menus 'eserve-xemacs-set-menus)
(defalias 'eserve-add-menu 'eserve-xemacs-add-menu)
(defalias 'eserve-delete-menus 'eserve-xemacs-delete-menus)
(defalias 'eserve-create-overlay-or-extent 'eserve-xemacs-create-extent)
(defalias 'eserve-delete-overlay-or-extent 'eserve-xemacs-delete-extent)
;; Apparently unused
;;(defalias 'eserve-set-overlay-or-extent 'eserve-xemacs-set-extent)
(setq find-file-compare-truenames t))
(when running-emacs
(defalias 'eserve-set-menus 'eserve-emacs-set-menus)
(defalias 'eserve-add-menu 'eserve-emacs-add-menu)
(defalias 'eserve-delete-menus 'eserve-emacs-delete-menus)
(defalias 'eserve-create-overlay-or-extent 'eserve-emacs-create-overlay)
(defalias 'eserve-delete-overlay-or-extent 'eserve-emacs-delete-overlay)
;; Apparently unused
;;(defalias 'eserve-set-overlay-or-extent 'eserve-emacs-set-overlay)
)
(eserve-xpm-setup)
(eserve-vc-setup)
(eserve-toolbar-setup)
;; load startup file if it exists
(when (setq eserve-startup-file (getenv eserve-startup-envvar))
(eserve-load-startup-file)
(setenv eserve-startup-envvar nil)))
;;
;; eserve process communication functions
;;
(defun eserve-connection-filter (process output)
"Process filter to handle output from the eserve process."
(if eserve-connection
(set-process-filter eserve-connection t))
(unwind-protect
(condition-case err
(progn
(eserve-log-message "Eserve --> Emacs: %s" output)
(eserve-eval-cmds output))
(error
(message "Error during eserve msg evaluation: %s" err)
(eserve-log-message "Error during eserve msg evaluation: %s %s" err output)))
(when eserve-connection
(set-process-filter eserve-connection 'eserve-connection-filter)))
(when eserve-connection
(set-process-filter eserve-connection 'eserve-connection-filter)))
(defun eserve-connection-sentinel (process status)
"Handle changes in status to eserve process."
(when (memq (process-status process) '(signal exit closed))
;; Emacs is in a weird state within save-some-buffers
;; a message written to the echo area is not removed as
;; it would be with a normal prompt if there are files to be saved.
(unless inhibit-quit
(message "Connection to edit server terminated"))
(eserve-connection-cleanup)
(eserve-cleanup)))
(defun eserve-connection-cleanup ()
"Clean up after eserve connection is broken."
(setq eserve-connection nil))
(defun eserve-cleanup ()
"Clean up eserve related information."
(eserve-clear-all-marks)
(remove-hook 'kill-buffer-hook 'eserve-kill-buffer-hook)
(remove-hook 'find-file-hooks 'eserve-find-file-hook)
(remove-hook 'after-save-hook 'eserve-after-save-hook)
(remove-hook (if (boundp 'after-set-visited-file-name-hooks)
'after-set-visited-file-name-hooks
'write-file-hooks)
'eserve-after-set-visited-file-name-hook)
(remove-hook 'first-change-hook 'eserve-first-change-hook)
(clrhash eserve-buffers-marks-hash)
(setq eserve-mark-type-list nil)
(setq eserve-message-leftover nil)
(setq eserve-app-name nil)
(setq eserve-app-cb nil)
(setq eserve-started-by-emacs nil)
(eserve-delete-menus eserve-menus)
(clrhash eserve-verb-button-hash)
(eserve-xpm-cleanup)
(eserve-toolbar-cleanup)
(when running-emacs ; menu removal bug
(redraw-display)))
(defun eserve-quit ()
"Abort currently launching application and disconnect from it."
(interactive)
(unless (or eserve-launch-timer-process
eserve-launch-process
eserve-connection)
(error "Edit server has not been started, use M-x eserve-start to connect"))
(when eserve-launch-timer-process
(eserve-launch-timer-reset))
(when eserve-launch-process
(delete-process eserve-launch-process)
(eserve-launch-process-cleanup))
(when eserve-connection
(delete-process eserve-connection)
(eserve-connection-cleanup))
(eserve-cleanup))
(defun eserve-xpm-setup ()
"Set up the xpm-color-symbols list."
(when (and (boundp 'xpm-color-symbols)
(null (assoc "FgColor" xpm-color-symbols)))
(setq xpm-color-symbols
(append '(("FgColor" (face-foreground 'default))
("BgColor" (face-background 'default)))
xpm-color-symbols))))
(defun eserve-xpm-cleanup ()
"Restore the xpm-color-symbols list."
(when (boundp 'xpm-color-symbols)
(setq xpm-color-symbols (remassoc "BgColor" xpm-color-symbols))
(setq xpm-color-symbols (remassoc "FgColor" xpm-color-symbols))))
(defun eserve-eval-cmds (msg)
"Read and evaluate commands from eserve message stream.
Eserve commands are newline-separated strings of lisp code."
(when eserve-message-leftover
(setq msg (concat eserve-message-leftover msg))
(setq eserve-message-leftover nil))
(let ((index 0) read-data)
(condition-case nil
(while t
(setq read-data (read-from-string msg index))
(eval (car read-data))
(setq index (cdr read-data)))
(end-of-file
(when (< index (1- (length msg)))
(setq eserve-message-leftover (substring msg index)))))))
(defun eserve-connect (eserve-portnum)
"Connect to the eserve process."
(condition-case err
(progn
(setq eserve-connection
(open-network-stream
"eserve connection" nil "localhost" eserve-portnum))
(set-process-filter eserve-connection 'eserve-connection-filter)
(set-process-sentinel eserve-connection 'eserve-connection-sentinel)
(process-kill-without-query eserve-connection)
(when (and (fboundp 'set-process-input-coding-system)
(boundp 'pathname-coding-system))
;; XEmacs Mule - convert process I/O using appropriate coding system
(set-process-input-coding-system eserve-connection pathname-coding-system)
(set-process-output-coding-system eserve-connection pathname-coding-system))
(eserve-event-connected)
(eserve-initial-files)
(add-hook 'kill-buffer-hook 'eserve-kill-buffer-hook)
(add-hook 'find-file-hooks 'eserve-find-file-hook)
(add-hook 'after-save-hook 'eserve-after-save-hook)
;; Use after-set-visited-file-name-hooks, if available.
(add-hook (if (boundp 'after-set-visited-file-name-hooks)
'after-set-visited-file-name-hooks
'write-file-hooks)
'eserve-after-set-visited-file-name-hook)
(add-hook 'first-change-hook 'eserve-first-change-hook)
(when eserve-app-name
(let ((app-process (eserve-launch-app eserve-app-name)))
(when eserve-app-cb
(funcall eserve-app-cb app-process))
(setq eserve-app-name nil)
(setq eserve-app-cb nil))))
(error "Could not connect to edit server: %s" err)))
(defun eserve-load-startup-file ()
"Load the file containing code to start the connection between eserve/emacs."
(when (and eserve-startup-file
(stringp eserve-startup-file)
(> (length eserve-startup-file) 0)
(file-exists-p eserve-startup-file))
(load eserve-startup-file nil t)
(delete-file eserve-startup-file)
(setq eserve-startup-file nil)))
(defun eserve-connection-message (&rest format-args)
"Send formatted string to the eserve process over the connection to eserve."
(when eserve-connection
(let ((str (apply 'format format-args)))
(process-send-string eserve-connection str)
;; Debugging trace
(eserve-log-message "Emacs --> Eserve: %s" str))))
(defsubst eserve-one-based (int)
"Take a lineno/column number, if it's -1 return -1, else make 1 based."
(if (= int -1) int (+ int 1)))
(defvar eserve-file-position-verbs
'("debug.stop-at"
"debug.clear-at"
"debug.disable-at"
"debug.enable-at")
"List of verbs known to eserve which require a filename and a position.")
(defvar eserve-selection-verbs
'("debug.stop-in"
"debug.evaluate-expr"
"debug.evaluate-expr-star")
"List of verbs known to eserve which require a non-empty selection.")
(defun eserve-send-verb (verb needsFilePos)
"Send a tool verb to eserve."
(when eserve-connection
(let ((filename (or (buffer-file-name (current-buffer)) "NULL"))
(selection "")
(sel-beg-line -1)
(sel-beg-col -1)
(sel-end-line -1)
(sel-end-col -1))
(when needsFilePos
(when (and (x-selection-exists-p)
(x-selection-owner-p))
(setq selection (eserve-current-selection))
(save-excursion
(condition-case nil
(progn
(let ((beg (region-beginning))
(end (region-end)))
(goto-char beg)
(setq sel-beg-col (current-column))
(setq sel-beg-line (eserve-cursor-line))
(goto-char end)
(setq sel-end-col (current-column))
(setq sel-end-line (eserve-cursor-line))))
(error nil)))))
(when (and (null (buffer-file-name (current-buffer)))
(member verb eserve-file-position-verbs))
(error "Error: %s only works in buffers attached to files" this-command))
(when (and (equal selection "")
(member verb eserve-selection-verbs))
(setq selection
(read-from-minibuffer
"Empty selection - please enter an argument: ")))
(when eserve-save-files
(when (member verb eserve-save-verbs)
(save-some-buffers t)
;; See EOU 1234353
;;(save-some-buffers (not eserve-ask-about-save))
))
(eserve-connection-message
"toolVerb %s %s %d,%d %d,%d %d,%d %d %s\n"
verb filename
(eserve-one-based (eserve-cursor-line))
(eserve-one-based (current-column))
(eserve-one-based sel-beg-line)
(eserve-one-based sel-beg-col)
(eserve-one-based sel-end-line)
(eserve-one-based sel-end-col)
(length selection) selection))))
(defun eserve-send-ack (ack-num)
"Send an ack to eserve."
(eserve-connection-message "ack %d\n" ack-num))
;;
;; Functions to check on eserve status
;;
(defvar eserve-ping-timer-process nil)
(defvar eserve-ping-timer-max 8)
(defvar eserve-got-ping nil)
(defvar eserve-need-ping nil)
(defun eserve-ping (refnum)
"Received ping from edit server."
(when eserve-need-ping
(setq eserve-got-ping t)
(eserve-ping-timer-timeout)
(when eserve-ping-timer-process
(eserve-ping-timer-cleanup))))
(defun eserve-ping-timer-sentinel (proc str)
(let ((stat (process-status proc)))
(when (memq stat '(exit signal))
(setq eserve-ping-timer-process nil)
(when eserve-need-ping
(eserve-ping-timer-timeout)))))
(defun eserve-ping-timer-cleanup ()
(when eserve-ping-timer-process
(delete-process eserve-ping-timer-process)
(setq eserve-ping-timer-process nil)))
(defun eserve-start-ping-timer ()
(if eserve-ping-timer-process
(message "Edit server ping already in progress")
(setq eserve-need-ping t)
;; send eserve ack message
(eserve-connection-message "ping 1\n")
(setq eserve-ping-timer-process
(start-process "ping timer process" nil "sleep"
(int-to-string eserve-ping-timer-max)))
(set-process-sentinel eserve-ping-timer-process
'eserve-ping-timer-sentinel)
(message "Waiting for response from edit server...")))
(defun eserve-ping-timer-timeout ()
(cond
((and eserve-need-ping eserve-got-ping)
(message "Received response from edit server, connection is up"))
(eserve-need-ping
(message "No response from edit server, use M-x eserve-quit to bring it down")))
(setq eserve-need-ping nil)
(setq eserve-got-ping nil))
(defun eserve-status ()
"Find out if emacs is connected to eserve."
(interactive)
(if eserve-connection
(eserve-start-ping-timer)
(message "Edit server has not been started, use M-x eserve-start to connect")))
;;
;; Functions to invoke eserve/workshop from emacs
;;
(defun eserve-path-search (file path)
;; Search PATH, a list of directory names, for FILE.
;; Return the element of PATH that contains FILE concatenated with
;; FILE, or nil if not found.
(while (and path (not (file-executable-p (expand-file-name file (car path)))))
(setq path (cdr path)))
(when (car path)
(expand-file-name file (car path))))
(defun eserve-get-app-path (app-name)
"Return the path to the application binary."
(cond
((eq (aref app-name 0) ?\/)
app-name)
((eserve-path-search app-name exec-path))
((and running-xemacs (boundp 'sunpro-dir) sunpro-dir)
(dolist (dir '("WS6U2/bin" "WS6U1/bin/" "WS6/bin/" "WS5.0/bin" "WS4.0/bin" "bin/"))
(let ((app (concat sunpro-dir dir app-name)))
(when (file-executable-p app) (return app)))))))
(defun eserve-get-path-to-eserve ()
"Return the path to the eserve binary."
(cond
(eserve-path
(if (and (stringp eserve-path) (file-executable-p eserve-path))
eserve-path
(error "Error: bad value for eserve-path variable")))
((eserve-path-search "eserve" exec-path))
((and running-xemacs (boundp 'sunpro-dir) sunpro-dir)
(dolist (dir '("WS6U2/bin" "WS6U1/lib/" "WS6/lib/" "WS5.0/lib" "WS4.0/lib" "lib/"))
(let ((eserve-path (concat sunpro-dir dir "eserve")))
(when (file-executable-p eserve-path) (return eserve-path)))))))
(defun eserve-start ()
"Invoke edit server from emacs."
(interactive)
(if eserve-connection
(error "Edit server connection exists - use M-x eserve-quit to bring it down")
(let ((path-to-eserve (eserve-get-path-to-eserve)))
(if (not path-to-eserve)
(error "Cannot find eserve in PATH environment variable")
(eserve-init)
(eserve-launch-server path-to-eserve)
t))))
(defun eserve-app-start (app-name started-cb)
"Invoke an application from emacs."
(unless (stringp app-name)
(error "Invalid application name specified"))
(if eserve-connection
(let (app-process)
(setq eserve-app-name app-name)
(setq eserve-app-cb started-cb)
(setq app-process (eserve-launch-app eserve-app-name))
(when eserve-app-cb
(funcall eserve-app-cb app-process))
(setq eserve-app-name nil)
(setq eserve-app-cb nil))
(let ((app-path (eserve-get-app-path app-name))
(path-to-eserve (eserve-get-path-to-eserve)))
(unless app-path
(error "Cannot find %s in PATH environment variable" app-name))
(unless path-to-eserve
(error "Cannot launch %s because eserve is not in PATH environment variable"
app-name))
(setq eserve-app-name app-path)
(setq eserve-app-cb started-cb)
(eserve-init)
(eserve-launch-server path-to-eserve))))
(defun eserve-launch-timer-sentinel (proc str)
(when (memq (process-status proc) '(exit signal))
(setq eserve-launch-timer-process nil)
(eserve-launch-timer-timeout)))
(defun eserve-launch-timer-reset ()
(setq eserve-launch-current-time 0)
(when eserve-launch-timer-process
(setq eserve-launch-abort t)
(eserve-kill-launch-timer)))
(defun eserve-kill-launch-timer ()
(when (and eserve-launch-timer-process
(eq (process-status eserve-launch-timer-process) 'run))
(delete-process eserve-launch-timer-process))
(setq eserve-launch-timer-process nil))
(defun eserve-setup-launch-timer ()
(setq eserve-launch-timer-process
(start-process "launch timer process" nil "sleep"
(int-to-string eserve-launch-timer-increment)))
(set-process-sentinel eserve-launch-timer-process 'eserve-launch-timer-sentinel))
(defun eserve-launch-timer-timeout ()
(incf eserve-launch-current-time eserve-launch-timer-increment)
(cond
(eserve-launch-abort
(message "Connection aborted.")
(setq eserve-launch-abort nil))
((file-readable-p eserve-startup-file)
(eserve-load-startup-file)
(eserve-launch-timer-reset)
(setq eserve-started-by-emacs t)
(message "Connection to edit server established"))
((>= eserve-launch-current-time eserve-launch-timer-max)
(eserve-launch-timer-reset)
(when eserve-launch-process
(delete-process eserve-launch-process))
(eserve-launch-process-cleanup)
(error "Error: Could not connect to edit server"))
(t
(message "Starting connection to edit server...")
(eserve-setup-launch-timer))))
(defun eserve-launch-server (path-to-eserve)
(setq eserve-startup-file (make-temp-name "/tmp/emacs"))
(setenv "SPRO_EDITOR_RENDEZVOUS_FILE" eserve-startup-file)
(condition-case err
(progn
(setq eserve-launch-process
(start-process "eserve launch" nil path-to-eserve))
(message "Starting connection to edit server..."))
(file-error
(error "Could not start eserve: check your PATH: %s" err)))
(setenv "SPRO_EDITOR_RENDEZVOUS_FILE" nil)
(when eserve-launch-process
(eserve-setup-launch-timer)
(set-process-sentinel eserve-launch-process
'eserve-launch-process-sentinel)))
(defun eserve-launch-app (app-name)
(let (app-process)
(condition-case err
(progn
(setq app-process (start-process app-name nil app-name))
(message "%s started" app-name))
(file-error
(error "Could not find %s, check your PATH: %s" app-name err)))
app-process))
(defun eserve-launch-process-cleanup ()
"Clean up after eserve process has terminated."
(setq eserve-launch-process nil))
(defun eserve-launch-process-sentinel (process status)
"Handle changes in status to ESERVE process."
(when (memq (process-status process) '(signal exit closed))
(eserve-launch-process-cleanup)))
;;
;; eserve protocol functions for file and marker management
;;
(defun eserve-quit-emacs ()
"Exit emacs on behalf of eserve."
;; reset filter to get around xemacs bug
(set-process-filter eserve-connection 'eserve-connection-filter)
;; ask to save unsaved buffers and leave
(save-buffers-kill-emacs))
(defun eserve-open-file (file-to-open)
"Open a file into a buffer."
(find-file file-to-open))
(defun eserve-load-file (filename)
"Load a file into a buffer on behalf of eserve."
(message "")
(eserve-show-buffer (or (eserve-file-to-buffer filename)
(eserve-open-file filename)))
;; Add balloon evaluation to any buffer eserve asks us to show
(eserve-add-ballooneval-buffer filename))
(defun eserve-reload-file (filename)
"Reload a file into a buffer on behalf of eserve."
(let ((file-buffer (or (eserve-file-to-buffer filename)
(eserve-open-file filename))))
(save-excursion
(set-buffer file-buffer)
(cond
(running-xemacs (revert-buffer t t))
(running-emacs (revert-buffer nil t))))
(message "")
(eserve-show-buffer file-buffer)))
(defun eserve-save-file (filename)
"Save file FILENAME on behalf of eserve."
(let ((file-buffer (eserve-file-to-buffer filename)))
(when file-buffer
(save-excursion
(set-buffer file-buffer)
(save-buffer))
(message ""))))
(defun eserve-front-file (file-to-front)
"Switch to a buffer, and raise its window to the front on behalf of eserve."
(let ((file-buffer (eserve-file-to-buffer file-to-front)))
(when file-buffer
(switch-to-buffer file-buffer)
(eserve-raise-buffer file-buffer))))
(defun eserve-show-file (file-to-show)
"Switch a buffer to the front on behalf of eserve."
(eserve-show-buffer (eserve-file-to-buffer file-to-show)))
(defun eserve-minimize ()
"Iconify all frames."
(mapcar #'iconify-frame (frame-list)))
(defun eserve-maximize ()
"Deiconify all frames."
(if running-xemacs
(mapcar #'deiconify-frame (frame-list))
;; Emacs
(save-excursion
(dolist (frame (frame-list))
(select-frame frame)
(iconify-or-deiconify-frame)))))
(defun eserve-set-mark (filename line-num mark-id mark-type)
"Create a mark in FILENAME at line LINE-NUM of type MARK-TYPE."
(let ((file-buffer (eserve-file-to-buffer-create filename)))
(when file-buffer
(let ((eserve-mark (eserve-make-eserve-mark file-buffer line-num mark-id mark-type)))
(eserve-add-mark eserve-mark)
(if (/= mark-type 0)
(eserve-mark-change-mark-type eserve-mark mark-type)))
;; Add balloon evaluation to any buffer eserve asks us to show
(eserve-add-ballooneval-buffer filename))))
(defun eserve-delete-mark (filename mark-id)
"Delete a MARKID from FILENAME."
(let ((file-buffer (eserve-file-to-buffer-create filename)))
(when file-buffer
(eserve-remove-mark file-buffer mark-id))))
(defun eserve-goto-mark (filename mark-id msg)
"Warp to the mark associated with MARK-ID in FILENAME showing MSG."
(let ((file-buffer (eserve-file-to-buffer filename)))
(when file-buffer
(let* ((eserve-mark (eserve-get-mark file-buffer mark-id))
(emark (eserve-mark-mark eserve-mark)))
(when running-xemacs
(x-disown-selection))
(goto-char (marker-position emark))
(switch-to-buffer file-buffer)
(when (> (length msg) 0)
(message (eserve-replace-in-string msg "\n" "\\n")))))))
(defun eserve-goto-line (filename line-num)
"Warp to line LINE-NUM in FILENAME."
(let ((file-buffer (eserve-file-to-buffer filename)))
(when file-buffer
(when running-xemacs
(x-disown-selection))
(goto-char (eserve-line-to-pos file-buffer line-num))
(switch-to-buffer file-buffer))))
(defun eserve-get-mark-type (pos mark-type-list)
;; Return the mark-type in position POS in MARK-TYPE-LIST.
(aref mark-type-list pos))
(defun eserve-change-mark-type (filename mark-id new-type)
;; Change in FILE NAME the type of mark MARK-ID to NEW-TYPE.
(eserve-mark-change-mark-type
(eserve-get-mark (eserve-file-to-buffer filename) mark-id) new-type))
(defun eserve-set-mark-type-list (mark-type-list)
;; Set eserve-mark-type-list to MARK-TYPE-LIST and perform any needed
;; initializations. Return TBD if successful or signal an error.
;; Sanity checks ...
(unless (vectorp mark-type-list)
(signal 'wrong-type-argument (list 'vectorp mark-type-list)))
(mapcar #'eserve-add-mark-type mark-type-list))
(defun eserve-add-mark-type (mark-type)
(eserve-log-message "Add mark type: %s" mark-type)
(eserve-init-mark-type mark-type)
(setq eserve-mark-type-list
(vconcat eserve-mark-type-list (make-vector 1 mark-type))))
(defun eserve-post-notification (msg severity)
"Post a message to the editor message area."
(message "%s" (eserve-replace-in-string msg "\n" "\\n")))
;;
;; editor state message functions
;;
(defmacro eserve-connection-counted-string-message (label string)
`(let ((s ,string))
(eserve-connection-message ,(format "%s %%d %%s\n" label) (length s) s)))
(defun eserve-get-cursor-row-text ()
"Send the text of the line the cursor is on to ESERVE."
(eserve-connection-counted-string-message
"cursorRowText"
(save-excursion (buffer-substring (progn (beginning-of-line) (point))
(progn (end-of-line) (point))))))
(defun eserve-get-cursor-row ()
"Send the row number of the line the cursor is on to ESERVE."
(eserve-connection-message "cursorRow %d\n" (eserve-cursor-line)))
(defun eserve-get-cursor-col ()
"Send the column number of the cursor on the line the cursor is on to ESERVE."
(eserve-connection-message "cursorCol %d\n" (current-column)))
(defun eserve-get-selected-text ()
"Send the text of the current selection to ESERVE."
(eserve-connection-counted-string-message
"selectedText" (or (eserve-current-selection) "")))
(defun eserve-get-current-file ()
"Send the name of the file in the current buffer on to ESERVE."
(eserve-connection-counted-string-message
"currentFile" (or (buffer-file-name (current-buffer)) "")))
;; Poor man's defstruct
(defmacro eserve-def-member (struct-name member-name index)
(let ((struct-member-symbol
(intern (format "%s-%s" struct-name member-name))))
`(progn
(defun ,struct-member-symbol (,struct-name)
,(format "Return the %s of %s."
member-name (upcase (symbol-name struct-name)))
(aref ,struct-name ,index))
(defsetf ,struct-member-symbol (,struct-name) (store)
(list 'aset ,struct-name ,index store)))))
;; An eserve-mark object has the form:
;; [eserve-mark ID TYPE MARK RENDERER]
;; 'eserve-mark : symbol, identifies this vector as an eserve-mark
;; id : integer, used by eserve
;; type : integer, index into the vector eserve-mark-type-list
;; mark : mark, the mark itself
;; renderer : overlay or extent
(defun eserve-mark-p (object)
"Return t if OBJECT is an eserve-mark."
(and (vectorp object)
(= (length object) 5)
(eq (aref object 0) 'eserve-mark)))
(eserve-def-member eserve-mark id 1)
(eserve-def-member eserve-mark type 2)
(eserve-def-member eserve-mark mark 3)
(eserve-def-member eserve-mark renderer 4)
(defun eserve-mark-buffer (eserve-mark)
"Return the buffer of ESERVE-MARK."
(marker-buffer (eserve-mark-mark eserve-mark)))
(defun eserve-make-eserve-mark (buffer line-num mark-id mark-type)
"Create an eserve-mark object at line LINE-NUM in buffer BUFFER."
(vector 'eserve-mark
mark-id
mark-type
(set-marker (make-marker) (eserve-line-to-pos buffer line-num) buffer)
nil))
;; An eserve-mark-type object has the form
;; [FGCOLOR BGCOLOR GLYPHFILE GLYPH FACE]
;; fgColor : string the foreground color of the mark
;; bgColor : string the background color of the mark
;; glyphFile : string the pathname of the XPM/XBM glyph of this mark
;; glyph : glyph the glyph itself
;; face : face the face of the highlighted line
(eserve-def-member eserve-mark-type fgColor 0)
(eserve-def-member eserve-mark-type bgColor 1)
(eserve-def-member eserve-mark-type glyphFile 2)
(eserve-def-member eserve-mark-type glyph 3)
(eserve-def-member eserve-mark-type face 4)
(defun eserve-mark-type-p (object)
"Return t if OBJECT is an eserve-mark-type."
(and (vectorp object) (= (length object) 5)))
(defun eserve-glyphFile-to-face-name (filename)
(intern (format "workshop-%s"
(file-name-sans-extension
(file-name-nondirectory filename)))))
(defun eserve-init-mark-type (mark-type)
;; Make a pixmap out of the glyphFile specified and store it in the glyph
;; object. Create a new face and set its foreground and background
;; colors. Then append the mark-type to the eserve-mark-type-list.
;; TBD: file checks for glyphFile
;; TBD: protect against errors in making the pixmap (incorrect format, etc.)
;; if there is not an existing face and either a foreground or background
;; color, then create a face and set its foreground and background colors
(when (and (null (eserve-mark-type-face mark-type))
(eserve-mark-type-glyphFile mark-type))
(let ((face (make-face (eserve-glyphFile-to-face-name
(eserve-mark-type-glyphFile mark-type)))))
(setf (eserve-mark-type-face mark-type) face)
(unless (face-differs-from-default-p face)
(set-face-foreground face (or (eserve-mark-type-fgColor mark-type) "black"))
(set-face-background face (or (eserve-mark-type-bgColor mark-type) "white")))))
;; set up glyph (for xemacs) and create a face
;; for it so that we don't get color bleeding
(when (and running-xemacs
(eserve-mark-type-glyphFile mark-type))
(let ((glyph (make-glyph (eserve-mark-type-glyphFile mark-type))))
(setf (eserve-mark-type-glyph mark-type) glyph)
(set-glyph-contrib-p glyph nil)
(set-glyph-face glyph (eserve-mark-type-face mark-type)))))
;; An eserve-menu object has the form:
;; [eserve-menu LABEL NUMITEMS ITEMS HANDLE]
;; 'eserve-menu : symbol, identifies this vector as an eserve-menu
;; label : string, displayed in menu bar
;; numitems : integer, number of menu items in items array
;; items : array of menu items
;; handle : editor specific handle to menu
(defun eserve-menu-p (object)
"Return t if OBJECT is an eserve-menu."
(and (vectorp object)
(= (length object) 5)
(eq (aref object 0) 'eserve-menu)))
(eserve-def-member eserve-menu label 1)
(eserve-def-member eserve-menu numitems 2)
(eserve-def-member eserve-menu items 3)
(eserve-def-member eserve-menu handle 4)
;; An eserve-button object has the form:
;; [eserve-button LABEL VERB NEEDSFILEPOS HELP ACCELERATOR
;; SENSE SENSESYM ICONFILE OFFSET CMD]
;; 'eserve-button : symbol, identifies this vector as an eserve-button
;; label : string, displayed in button
;; verb : string, verb (action) sent when button is selected
;; needsfilepos : bool, if t, send selection contents and position with verb
;; help : string, documents button for user
;; accelerator : string, key binding to invoke button (unused)
;; sense : bool, if t, button is enabled
;; sensesym : symbol, used to store sense value
;; iconfile : string, file containing icon definition
;; offset : integer, offset in pixels from previous button
;; cmd : function, function to call on button up if not nil
(defun eserve-button-p (object)
"Return t if OBJECT is an eserve-button."
(and (vectorp object)
(= (length object) 11)
(eq (aref object 0) 'eserve-button)))
(eserve-def-member eserve-button label 1)
(eserve-def-member eserve-button verb 2)
(eserve-def-member eserve-button needsfilepos 3)
(eserve-def-member eserve-button help 4)
(eserve-def-member eserve-button accelerator 5)
(eserve-def-member eserve-button sense 6)
(eserve-def-member eserve-button sensesym 7)
(eserve-def-member eserve-button iconfile 8)
(eserve-def-member eserve-button offset 9)
(eserve-def-member eserve-button cmd 10)
;;
;; eserve button support functions
;;
(defun eserve-button-create-cmd (eserve-button name-prefix)
"Create a command function to be invoked when ESERVE-BUTTON is selected."
(when (and name-prefix eserve-button)
(eval `(defun ,(intern (concat name-prefix
(eserve-button-label eserve-button)))
()
(interactive)
(eserve-send-verb ,(eserve-button-verb eserve-button)
,(eserve-button-needsfilepos eserve-button))))))
(defun eserve-button-create-sensesym (eserve-button name-prefix)
"Return the symbol which when evaluated determines button sense."
(when (and name-prefix eserve-button)
(intern (concat name-prefix "-"
(eserve-button-label eserve-button) "-sense"))))
(defun eserve-register-button (button)
"Add BUTTON to the verb button hash table."
(let ((verb (eserve-button-verb button)))
(when verb
(setf (gethash verb eserve-verb-button-hash)
(cons button (gethash verb eserve-verb-button-hash))))))
(defun eserve-set-sensitivity (verb-sense)
"Set the sensitivity of the buttons corresponding VERB-SENSE pair."
(dolist (button (gethash (aref verb-sense 0) eserve-verb-button-hash))
(set (eserve-button-sensesym button) (aref verb-sense 1))))
(defun eserve-set-sensitivities (verb-sense-array)
"Apply the sense values in VERB-SENSE-ARRAY to the existing eserve buttons."
(mapcar #'eserve-set-sensitivity verb-sense-array)
(when (featurep 'toolbar)
(eserve-refresh-toolbars)))
;;;
;;; protocol support functions
;;;
(defun eserve-add-mark (eserve-mark)
"Add ESERVE-MARK to the list of marks for the corresponding buffer."
(let* ((buffer (eserve-mark-buffer eserve-mark))
(mark-list (or (eserve-get-buffer-marks buffer)
(eserve-create-buffer-marks buffer)))
(mark-id (eserve-mark-id eserve-mark)))
(when (>= mark-id (length mark-list))
(setq mark-list (eserve-grow-vector mark-list mark-id eserve-mark-vector-chunk))
(eserve-set-buffer-marks buffer mark-list))
;; check for old mark not deleted
(when (aref mark-list mark-id)
(eserve-mark-clear-renderer (aref mark-list mark-id)))
(aset mark-list mark-id eserve-mark)))
(defun eserve-remove-mark (buffer mark-id)
"Remove mark corresponding to MARK-ID from BUFFER's list of marks."
(let ((mark-list (eserve-get-buffer-marks buffer)))
(when mark-list
(let ((eserve-mark (aref mark-list mark-id)))
(when eserve-mark
(eserve-mark-clear-renderer eserve-mark)
(aset mark-list mark-id nil))))))
(defun eserve-get-mark (buffer mark-id)
"Return the eserve-mark associated with BUFFER and MARK-ID."
(let ((mark-list (eserve-get-buffer-marks buffer)))
(when (< mark-id (length mark-list))
(aref mark-list mark-id))))
(defun eserve-get-buffer-marks (buffer)
"Return the marks associated with BUFFER."
(car-safe (gethash buffer eserve-buffers-marks-hash)))
(defun eserve-get-buffer-visited-file-name (buffer)
"Return the original file name associated with BUFFER."
(cdr-safe (gethash buffer eserve-buffers-marks-hash)))
(defun eserve-set-buffer-marks (buffer mark-list)
"Associate MARK-LIST with BUFFER."
(setf (gethash buffer eserve-buffers-marks-hash)
(cons mark-list (buffer-file-name buffer))))
(defun eserve-delete-buffer-marks (buffer)
"Dis-associate MARKLIST with BUFFER, delete buffer from list."
(remhash buffer eserve-buffers-marks-hash))
(defun eserve-create-buffer-marks (buffer)
"Create a marks list and associate it with BUFFER. Return mark list."
(let ((mark-list (make-vector eserve-mark-vector-chunk nil)))
(eserve-set-buffer-marks buffer mark-list)
mark-list))
(defun eserve-grow-vector (vector-to-grow max-index chunk-size)
"Extend VECTOR-TO-GROW to contain MAX-INDEX. Return extended vector."
(vconcat vector-to-grow
(make-vector (- (* chunk-size (+ (/ max-index chunk-size) 1))
(length vector-to-grow))
nil)))
(defun eserve-mark-change-mark-type (eserve-mark mark-type-index)
"Change ESERVE-MARK to new mark type."
(save-excursion
(set-buffer (eserve-mark-buffer eserve-mark))
(goto-char (marker-position (eserve-mark-mark eserve-mark)))
(let ((new-mark-type
(eserve-get-mark-type mark-type-index eserve-mark-type-list))
(beg-point (progn (beginning-of-line) (point)))
(end-point (progn (end-of-line) (point))))
;; clear out old visual if it exists
(eserve-mark-clear-renderer eserve-mark)
(if (eserve-mark-type-face new-mark-type)
(setf (eserve-mark-renderer eserve-mark)
(eserve-create-overlay-or-extent
new-mark-type beg-point end-point))))))
(defun eserve-mark-clear-renderer (eserve-mark)
"Remove visual remains of ESERVE-MARK."
(when eserve-mark
(let ((old-renderer (eserve-mark-renderer eserve-mark)))
(when old-renderer
(save-excursion
(set-buffer (eserve-mark-buffer eserve-mark))
(eserve-delete-overlay-or-extent old-renderer)
(setf (eserve-mark-renderer eserve-mark) nil))))))
(defun eserve-clear-all-marks ()
"Removes visuals backing all ESERVE marks in all buffers."
(when (hash-table-p eserve-buffers-marks-hash)
(maphash
(lambda (buffer marks-info)
(mapcar #'eserve-mark-clear-renderer (car marks-info)))
eserve-buffers-marks-hash))
(when (fboundp 'remove-specifier)
;; Restore left-margin-width
(remove-specifier left-margin-width 'buffer 'eserve)))
;;
;; menu support functions
;;
(defun eserve-emacs-set-menus (menus)
"Add menu list MENUS to the menu bar."
(mapcar #'eserve-emacs-menu-create (reverse menus))
(redraw-display))
(defun eserve-emacs-add-menu (menu)
"Add MENU to the emacs menu bar."
(eserve-emacs-menu-create menu)
(setq eserve-menus (append eserve-menus (list menu))))
(defun eserve-emacs-delete-menus (menus)
"Delete menus in the menu list MENUS from the menu bar."
(when menus
(mapcar #'eserve-emacs-menu-delete menus)
(setq eserve-menus nil)
(redraw-display)))
(defun eserve-xemacs-set-menus (menus)
"Add menu list MENUS to the menu bar."
(mapcar #'eserve-xemacs-menu-create menus))
(defun eserve-xemacs-add-menu (menu)
"Add MENU to the xemacs menu bar."
(eserve-xemacs-menu-create menu)
(setq eserve-menus (append eserve-menus (list menu))))
(defun eserve-xemacs-delete-menus (menus)
"Delete menus from the MENUS list from the menu bar."
(when menus
(mapcar #'eserve-xemacs-menu-delete menus)
(setq eserve-menus nil)))
(defun eserve-xemacs-menu-create (eserve-menu)
"Add ESERVE-MENU to the xemacs menu bar."
(when (eserve-menu-p eserve-menu)
(setf (eserve-menu-handle eserve-menu)
(list (eserve-menu-label eserve-menu)))
(add-submenu
'() (loop for button across (eserve-menu-items eserve-menu)
collect (eserve-xemacs-menuitem-create eserve-menu button)))))
(defun eserve-xemacs-menuitem-create (eserve-menu eserve-button)
"Return an xemacs menuitem from ESERVE-BUTTON."
;; First fix up eserve-button
(setf (eserve-button-sensesym eserve-button)
(eserve-button-create-sensesym
eserve-button (eserve-menu-label eserve-menu)))
(set (eserve-button-sensesym eserve-button)
(eserve-button-sense eserve-button))
(eserve-register-button eserve-button)
(vector
(eserve-button-label eserve-button)
(or (eserve-button-cmd eserve-button)
(eserve-button-create-cmd eserve-button
(eserve-menu-label eserve-menu)))
(eserve-button-sensesym eserve-button)))
(defun eserve-xemacs-menu-delete (eserve-menu)
"Delete a ESERVE-MENU from the xemacs menu bar."
(when (eserve-menu-p eserve-menu)
(delete-menu-item (eserve-menu-handle eserve-menu))))
(defun eserve-emacs-menuitem-create (eserve-menu button kmap)
"Add button BUTTON to ESERVE-MENU."
(let ((button-cmd
(if (eserve-button-verb button)
(eserve-button-cmd button)
(eserve-button-create-cmd button (eserve-menu-label eserve-menu)))))
(define-key kmap (vector (intern (eserve-button-label button)))
`( ,(eserve-button-label button)
,(eserve-button-help button) .
,button-cmd))
(setf (eserve-button-sensesym button)
(eserve-button-create-sensesym button
(eserve-menu-label eserve-menu)))
(set (eserve-button-sensesym button) (eserve-button-sense button))
(put button-cmd 'menu-enable (eserve-button-sensesym button))
(eserve-register-button button)))
(defun eserve-emacs-menu-create (eserve-menu)
"Add ESERVE-MENU to the menu bar."
(when (eserve-menu-p eserve-menu)
(let ((handle `[menu-bar ,(intern (eserve-menu-label eserve-menu)) ])
(kmap (make-sparse-keymap (eserve-menu-label eserve-menu)))
(index (eserve-menu-numitems eserve-menu))
(button nil))
(define-key global-map handle (cons (eserve-menu-label eserve-menu) kmap))
(setf (eserve-menu-handle eserve-menu) handle)
(while (> index 0)
(setq button (aref (eserve-menu-items eserve-menu) (- index 1)))
(eserve-emacs-menuitem-create eserve-menu button kmap)
(setq index (- index 1)))
(setq menu-bar-final-items
(cons (intern (eserve-menu-label eserve-menu))
menu-bar-final-items)))))
(defun eserve-emacs-menu-delete (eserve-menu)
"Delete ESERVE-MENU from the emacs menu bar."
(when (eserve-menu-p eserve-menu)
(global-unset-key (eserve-menu-handle eserve-menu))
(setq menu-bar-final-items
(delete (intern (eserve-menu-label eserve-menu))
menu-bar-final-items))))
;;
;; version control support
;;
(defun eserve-vc-setup ()
"Set up the VC menu."
(require 'vc-hooks))
;;
;; file/buffer utility functions
;;
(defun eserve-file-to-buffer (filename)
"Return the buffer containing the contents of FILENAME.
Return nil if no such buffer exists."
(get-file-buffer (expand-file-name (abbreviate-file-name filename))))
(defun eserve-file-to-buffer-create (filename)
"Return or create the buffer containing the contents of FILENAME."
(let ((full-file-name (abbreviate-file-name filename)))
(or (get-file-buffer full-file-name)
(find-file-noselect full-file-name))))
(defun eserve-line-to-pos (buffer line-no)
"Return the character position of LINE-NO in BUFFER."
(save-excursion
(set-buffer buffer)
(goto-line line-no)
(point)))
(defun eserve-cursor-line ()
(save-excursion
(beginning-of-line)
(count-lines 1 (point))))
(defun eserve-get-selection ()
"Return the text from the X primary clipboard."
(x-get-selection-internal 'PRIMARY 'STRING))
(defun eserve-current-selection ()
"Return the text of the current selection."
(and (x-selection-exists-p 'PRIMARY)
(x-selection-owner-p)
(eserve-get-selection)))
(defun eserve-show-buffer (buffer)
"Switch current window to BUFFER."
(switch-to-buffer buffer)
(unless (frame-visible-p (selected-frame))
(make-frame-visible))
(when (and (featurep 'toolbar) eserve-toolbar-orientation)
(eserve-install-frame-toolbar (selected-frame))))
(defun eserve-raise-buffer (buffer)
"Raise the X window containing BUFFER."
(raise-frame (window-frame (get-buffer-window buffer))))
(defun eserve-add-to-path (dir)
"Add DIR to the emacs load-path."
(when (and (stringp dir)
(not (member dir load-path)))
(setq load-path (cons (expand-file-name dir) load-path))))
(defun eserve-write-to-buffer (buffer string)
"Append STRING to buffer BUFFER."
(when (and (stringp string) buffer (buffer-name buffer))
(save-excursion
(set-buffer buffer)
(goto-char (point-max))
(insert string))))
(defun eserve-write-buffer (buffer filename)
"Write the contents of BUFFER to FILENAME."
(save-excursion
(set-buffer buffer)
(write-file filename)))
(defun eserve-replace-in-string (str oldstr newstr)
"Return a new string replacing occurrences of OLDSTR in STR with NEWSTR."
(let ((rtn-str "")
(start 0)
(match nil)
(prev-start 0))
(while (setq match (string-match oldstr str start))
(setq prev-start start)
(setq start (+ match (length oldstr)))
(setq rtn-str (concat rtn-str (substring str prev-start match) newstr)))
(concat rtn-str (substring str start))))
;;
;; hook functions for editor events
;;
(defun eserve-find-file-hook ()
"Notify client that new file has been visited in emacs."
(when (and buffer-file-name (eserve-file-to-buffer buffer-file-name))
(eserve-event-loaded-file buffer-file-name)))
(defun eserve-first-change-hook ()
"Notify client that a file has been modified by emacs."
(when buffer-file-name
(eserve-event-modified-file buffer-file-name)))
(defun eserve-after-save-hook ()
"Notify client that new file has been saved by emacs."
(when buffer-file-name
(eserve-event-saved-file buffer-file-name)))
(defun eserve-after-set-visited-file-name-hook ()
"Notify client that a buffer has been renamed (usually by write-file)."
(let* ((buffer (current-buffer))
(val (gethash buffer eserve-buffers-marks-hash))
(marks-list (car-safe val))
(original-file-name (cdr-safe val)))
(when marks-list
(mapcar #'eserve-mark-clear-renderer marks-list)
(when (fboundp 'remove-specifier)
(remove-specifier left-margin-width buffer 'eserve))
;; For all practical purposes, a renamed buffer is a deleted buffer.
(eserve-event-deleted-file original-file-name)
(eserve-delete-buffer-marks buffer))))
(defun eserve-kill-buffer-hook ()
"Delete buffer from eserve lists and informs eserve of event."
(if (null buffer-file-name)
(eserve-log-message "eserve-kill-buffer hook - no buffer name")
(eserve-log-message "eserve-kill-buffer hook - buffer name %s" buffer-file-name)
(let ((deleted-buffer (get-file-buffer buffer-file-name)))
(if (null deleted-buffer)
(eserve-log-message "eserve-kill-buffer hook - no deleted buffer")
(eserve-event-deleted-file buffer-file-name)
(when (eserve-get-buffer-marks deleted-buffer)
(eserve-delete-buffer-marks deleted-buffer))))))
;;
;; event functions - used to inform eserve of events occurring
;; in emacs
;;
(defun eserve-event-deleted-file (filename)
"Inform eserve that FILENAME has been deleted."
(eserve-connection-message "deletedFile %s\n" filename))
(defun eserve-event-loaded-file (filename)
"Inform eserve that FILENAME has been loaded."
(eserve-connection-message "loadedFile %s 0\n" filename))
(defun eserve-event-modified-file (filename)
"Inform eserve that FILENAME has been modified."
(eserve-connection-message "modifiedFile %s\n" filename))
(defun eserve-event-saved-file (filename)
"Inform eserve that FILENAME has been saved."
(eserve-connection-message "savedFile %s\n" filename))
(defun eserve-editor-version ()
"Return a string containing the major/minor version number."
(if (string-match " " emacs-version)
(substring emacs-version 0 (match-beginning 0))
emacs-version))
(defun eserve-event-connected ()
"Inform eserve that it is connected to emacs."
(eserve-connection-message
(if running-xemacs "connected xemacs %d.%d.%d %s\n" "connected emacs %d.%d.%d %s\n")
eserve-protocol-version
eserve-protocol-version-minor
eserve-protocol-version-micro
(eserve-editor-version)))
;;;
;;; Toolbar (aka buttonbar) functions
;;;
(defun eserve-toolbar-setup ()
"Perform any required one-time WorkShop toolbar initializations."
(when (featurep 'toolbar)
(define-specifier-tag 'eserve
(lambda (device) (eq 'x (device-type device))))))
(defun eserve-set-toolbar-specifiers ()
(let ((orientation
(cond
((eq eserve-toolbar-specifier top-toolbar) 'top)
((eq eserve-toolbar-specifier left-toolbar) 'left)
((eq eserve-toolbar-specifier right-toolbar) 'right)
((eq eserve-toolbar-specifier bottom-toolbar) 'bottom)
(t nil))))
(unless (eq eserve-toolbar-orientation orientation)
(let ((frames (when (specifierp eserve-toolbar-specifier)
(mapcar #'car (specifier-spec-list eserve-toolbar-specifier
'frame 'eserve)))))
(when frames
(eserve-remove-toolbar-specifiers 'frame))
(let ((data
(case eserve-toolbar-orientation
('right (list right-toolbar right-toolbar-width right-toolbar-visible-p))
('left (list left-toolbar left-toolbar-width left-toolbar-visible-p))
('bottom (list bottom-toolbar bottom-toolbar-height bottom-toolbar-visible-p))
('top (list top-toolbar top-toolbar-height top-toolbar-visible-p))
(t (list nil nil nil)))))
(setq eserve-toolbar-specifier (pop data))
(setq eserve-toolbar-size-specifier (pop data))
(setq eserve-toolbar-visible-p-specifier (pop data)))
(when eserve-toolbar-orientation
(mapcar #'eserve-install-frame-toolbar
(or frames (list (selected-frame)))))))))
(defun eserve-remove-toolbar-specifiers (locale)
(when (specifierp eserve-toolbar-specifier)
(remove-specifier eserve-toolbar-specifier locale 'eserve)
(remove-specifier eserve-toolbar-size-specifier locale 'eserve)
(remove-specifier eserve-toolbar-visible-p-specifier locale 'eserve)))
(defun eserve-toolbar-cleanup ()
"Restore emacs to the pre-eserve-toolbar state."
(when (featurep 'toolbar)
(eserve-remove-toolbar-specifiers 'frame)
(setq eserve-current-toolbar nil)
(setq eserve-toolbar-table nil)
(setq eserve-toolbar-specifier nil)
(setq eserve-toolbar-visible-p-specifier nil)
(setq eserve-toolbar-size-specifier nil)))
(defun eserve-refresh-toolbars ()
(eserve-set-toolbar-specifiers)
;; This ought to be implemented via
;; (set-specifier-dirty-flag eserve-toolbar-specifier)
;; but that appears to be broken, so we use the following workaround
(when (specifierp eserve-toolbar-specifier)
(let ((frame (caar (specifier-spec-list
eserve-toolbar-specifier 'frame 'eserve t))))
(when frame
(add-spec-to-specifier eserve-toolbar-specifier
eserve-current-toolbar frame 'eserve)))))
(defun eserve-toolbar-installed-p (frame)
"T if FRAME has an active WorkShop toolbar."
(specifier-spec-list eserve-toolbar-specifier frame 'eserve t))
(defun eserve-toggle-frame-toolbar (frame)
"Toggle the WorkShop toolbar for FRAME."
(if (eserve-toolbar-installed-p frame)
(eserve-deinstall-frame-toolbar frame)
(eserve-install-frame-toolbar frame)))
(defun eserve-install-frame-toolbar (frame)
"Make the WorkShop toolbar active on FRAME."
(when (and (specifierp eserve-toolbar-specifier) (not (eserve-toolbar-installed-p frame)))
(add-spec-to-specifier eserve-toolbar-specifier
eserve-current-toolbar frame 'eserve)
(add-spec-to-specifier eserve-toolbar-size-specifier
eserve-toolbar-icon-size frame 'eserve)
(add-spec-to-specifier eserve-toolbar-visible-p-specifier
eserve-toolbar-visible-p frame 'eserve)))
(defun eserve-deinstall-frame-toolbar (frame)
"Remove the WorkShop toolbar from FRAME, restoring previous toolbar, if any."
(when (frame-live-p frame)
(eserve-remove-toolbar-specifiers frame)))
(defun eserve-add-toolbar-button (toolbar-button)
"Add TOOLBAR-BUTTON to the current WorkShop toolbar."
(when (featurep 'toolbar)
(let ((xpm-color-symbols
(append
xpm-color-symbols
`(("BgColor"
,(or (frame-property (selected-frame) 'background-toolbar-color)
(face-background 'default)))
("FgColor" "black")))))
;; update eserve-toolbar-table
(setq eserve-toolbar-table
(vconcat eserve-toolbar-table (make-vector 1 toolbar-button)))
(eserve-init-toolbar-item toolbar-button))))
(defun eserve-set-toolbar-table (toolbar-table)
"Set eserve-toolbar-table to TOOLBAR-TABLE.
Perform all needed initializations and display the toolbar.
\[Return TBD if successful, or TBD if a non-fatal error is raised.
Signal the error TBD otherwise.]"
(when (featurep 'toolbar)
;; toolbar checks
(unless (vectorp toolbar-table)
(signal 'wrong-type-argument (list 'vectorp toolbar-table)))
(let ((xpm-color-symbols
(append
xpm-color-symbols
`(("BgColor"
,(or (frame-property (selected-frame) 'background-toolbar-color)
(face-background 'default)))
("FgColor" "black")))))
;; create and install toolbar
(setq eserve-toolbar-table toolbar-table) ; Save toolbar-table
(setq eserve-current-toolbar nil) ;delete any previous toolbars
(mapcar #'eserve-init-toolbar-item toolbar-table))))
(defun eserve-init-toolbar-item (toolbar-item)
(let ((button-cmd (eserve-button-create-cmd
toolbar-item "eserve-toolbar"))
(button-sense (eserve-button-sense toolbar-item))
(button-sensesym (eserve-button-create-sensesym
toolbar-item "eserve-toolbar"))
(button-space (eserve-button-offset toolbar-item))
(normal-iconfile (eserve-button-iconfile toolbar-item))
normal-glyph disabled-iconfile disabled-glyph)
(set button-sensesym button-sense)
(setf (eserve-button-sensesym toolbar-item) button-sensesym)
(eserve-register-button toolbar-item)
(when (and normal-iconfile (file-readable-p normal-iconfile))
(setq normal-glyph (make-glyph normal-iconfile))
(setq disabled-iconfile
(concat (file-name-sans-extension normal-iconfile) "-xx.xpm"))
(when (and disabled-iconfile (file-readable-p disabled-iconfile))
(setq disabled-glyph (make-glyph disabled-iconfile))))
(setq eserve-current-toolbar
(nconc
eserve-current-toolbar
(when (and (integerp button-space) (> button-space 0))
(list (vector ':size button-space ':style '2d))) ; spacer
(list (vector (list normal-glyph nil disabled-glyph)
button-cmd
button-sensesym
(eserve-button-help toolbar-item)))))))
(defun eserve-tool-flush (tool-name)
"Remove data related to tool TOOL-NAME."
)
;;;
;;; XEmacs-specific functions
;;;
(defun eserve-xemacs-create-extent (mark-type start end)
;; Create an extent in the current buffer with the properties of MARK-TYPE
;; and return it. The function `eserve-create-overlay-or-extent' is aliased
;; to this one when running XEmacs. Note, the arguments START and END are
;; not used and are present only because the corresponding function in GNU
;; Emacs `eserve-emacs-create-overlay' needs them.
(when (eserve-mark-type-face mark-type)
(let ((glyph (eserve-mark-type-glyph mark-type))
(face (eserve-mark-type-face mark-type))
extent)
(when face
(setq extent (make-extent start end (current-buffer)))
(setf (extent-face extent) face)
(setf (extent-priority extent) eserve-extent-priority)
(when glyph
(set-extent-begin-glyph extent glyph 'outside-margin)
(set-glyph-face glyph 'default)
(set-specifier left-margin-width 3 (current-buffer) 'eserve))
extent)))) ;return the newly created extent
;;; The following function used to be added to the hook after-change-functions.
;;; This is a bad idea.
;; The problem is that any solution we come up with to try to keep in
;; sync with the user's modifications to the source files comprising an
;; executable are going to be half-solutions. dbx can't keep track, and
;; neither can XEmacs (at least not without a LOT of work). And any such
;; solution has to be very intrusive, by analyzing EVERY buffer
;; modification, which is difficult to implement reliably and efficiently.
;; So we shouldn't even try.
;; (defun eserve-xemacs-change-function (start end old-length)
;; ;; Called by `after-change-function' to see if a newline was inserted and
;; ;; if so, to terminate the extent before that point. TBD: the
;; ;; corresponding operation of gluing two lines together to form a single
;; ;; highlighted line.
;; (save-excursion
;; (goto-char start)
;; (when (and (re-search-forward "\n" end t) ;return nil on failure
;; (<= (point) end))
;; ;; #### What if we're font-locking and there was already a smaller extent around point??
;; (let ((extent (extent-at (point)))) ;returns smallest extent
;; (when extent
;; (set-extent-endpoints
;; extent (extent-start-position extent) (point)))))))
(defun eserve-xemacs-delete-extent (extent)
(when extent
(delete-extent extent)))
;;;
;;; GNU Emacs-specific functions
;;;
(defun eserve-emacs-create-overlay (mark-type start end)
;; Create an overlay with the properties specified by MARK TYPE and return
;; it. The function `eserve-create-overlay-or-extent' is aliased to this one
;; when running GNU Emacs v19. N.B. There are no true glyphs in GNU Emacs v19.
;; TBD: replace use of gensym.
(let ((overlay (make-overlay start end))
(face (eserve-mark-type-face mark-type)))
(when face
(overlay-put overlay 'face (face-name face))
;; (overlay-put overlay 'modification-hooks
;; '(eserve-emacs-modification-function))
overlay)))
(defun eserve-emacs-delete-overlay (overlay)
(when overlay
(delete-overlay overlay)))
;;(defun eserve-emacs-modification-function (overlay &rest args)
;; Called by the modification hook in the overlay to see if a newline was
;; inserted and if so, to terminate the extent before that point. TBD:
;; the corresponding operation of gluing two lines together to form a
;; single highlighted line.
; (let (overlay after start end)
; (cond
; ((= (length args) 3)
; (setq overlay (nth 0 args))
; (setq start (nth 1 args))
; (setq end (nth 2 args)))
; ((= (length args) 4)
; (setq overlay (nth 0 args))
; (setq after (nth 1 args))
; (setq start (nth 2 args))
; (setq end (nth 3 args))))
;; (if (string-match "\n" (this-command-keys))
;; (move-overlay overlay (overlay-start overlay) (point))))
;;;
;;; Balloon Evaluation functions
;;;
;;; NOTE! This is not yet complete. For now it only displays
;;; the balloon results in the message area (which might be the
;;; right behavior for Emacs?) and only works for XEmacs
(defvar eserve-balloon-eval-buffer nil
"Buffer pointed to for the last balloon evaluation timeout.")
(defvar eserve-balloon-eval-cpos nil
"Buffer position pointed to for the last balloon evaluation timeout.")
(defvar eserve-balloon-eval-modeline-point nil
"Modeline point pointed to for the last balloon evaluation timeout.")
(defvar eserve-balloon-eval-timeout-id nil
"Timeout-id for the last current balloon evaluation timer.")
;; What type of evaluation we want: 0 to evaluate an expression; "1"
;; to dereference the expression and evaluate the resulting
;; expression, and "2" to evaluate the type of the expression
(defvar eserve-balloon-eval-type 0
"Balloon Expression Evaluation type: 0:evaluate 1:dereference 2:type.")
; Called whenever the mouse position changes
(defun eserve-balloon-eval-event-handler (event)
(when eserve-balloon-evaluation
(let* ((buffer (event-buffer event))
(modeline-point (and buffer (event-modeline-position event)))
(cpos (and buffer (event-point event))))
;; If the position has changed, delete the current timer and
;; set a new timeout
(if (not (and cpos eserve-balloon-eval-cpos
(= cpos eserve-balloon-eval-cpos)))
(progn
(when eserve-balloon-eval-timeout-id
(disable-timeout eserve-balloon-eval-timeout-id)
(setq eserve-balloon-eval-timeout-id nil))
(setq eserve-balloon-eval-cpos cpos)
(setq eserve-balloon-eval-buffer buffer)
(setq eserve-balloon-eval-modeline-point modeline-point)
(setq eserve-balloon-eval-timeout-id
(add-timeout (/ eserve-balloon-eval-delay 1000.0)
(function eserve-balloon-eval-display)
nil)))))))
; Called whenever the timer expires: send balloon request to the debugger
(defun eserve-balloon-eval-display (&rest ignored)
(let* ((selection "")
(index 0)
(bol 0)
(eol 0)
(cpos eserve-balloon-eval-cpos)
(modeline-point eserve-balloon-eval-modeline-point)
(filename (or eserve-balloon-eval-buffer "NULL")))
(if (and cpos (not modeline-point))
(save-excursion
(set-buffer eserve-balloon-eval-buffer)
(goto-char cpos)
(setq bol (progn (beginning-of-line) (point)))
(setq eol (progn (end-of-line) (point)))
; Adjust bol and eol so that it is at most 200 characters from point
; eol = min(eol, point+200)
(setq bol (max bol (- cpos 200)))
(setq eol (min eol (+ cpos 200)))
(setq index (- cpos bol))
(setq selection (buffer-substring bol eol))
(eserve-connection-message
"toolVerb debug.balloonEval %s 0,0 %d,0 %d,1000 %d %s\n"
filename
index ; the index should be 0-based
eserve-balloon-eval-type
(length selection) selection))
(message ""))))
; Reply from the debugger: post result
(defun eserve-balloon-result (msg clientData)
"Post an eserve balloon evaluation result."
(message "%s" (eserve-replace-in-string msg "\n" "\\n")))
(defun eserve-ballooneval-start ()
"Start Sun WorkShop's balloon evaluation feature in this buffer."
(interactive)
(add-hook 'mode-motion-hook 'eserve-balloon-eval-event-handler))
(defun eserve-ballooneval-quit ()
"Quit Sun WorkShop's balloon evaluation feature in this buffer."
(interactive)
(progn
(remove-hook 'mode-motion-hook 'eserve-balloon-eval-event-handler)
(when eserve-balloon-eval-timeout-id
(disable-timeout eserve-balloon-eval-timeout-id)
(setq eserve-balloon-eval-timeout-id nil))))
(defun eserve-ballooneval-expr ()
"For Balloon Expression Evaluation, evaluate the pointed to expression."
(interactive)
(setq eserve-balloon-eval-type 0))
(defun eserve-ballooneval-deref-expr ()
"For Balloon Expression Evaluation, dereference the pointed to expression."
(interactive)
(setq eserve-balloon-eval-type 1))
(defun eserve-ballooneval-type ()
"For Balloon Expression Evaluation, evaluate the pointed to expression's type."
(interactive)
(setq eserve-balloon-eval-type 2))
(defun eserve-add-ballooneval-buffer (filename)
"Add balloon evaluation to the given buffer"
(when running-xemacs
(let ((file-buffer (eserve-file-to-buffer filename)))
(save-excursion
(set-buffer file-buffer)
(eserve-log-message "Enabling balloon eval for: %s" filename)
(remove-hook 'mode-motion-hook 'eserve-balloon-eval-event-handler)
(add-hook 'mode-motion-hook 'eserve-balloon-eval-event-handler)))))
;; Tell eserve which files we have already loaded, which ones are read-only,
;; and which ones we have modified.
(defun eserve-initial-files ()
"Tell eserve wihch files are already loaded, and which ones are read-only or modified."
(let ((buffers (buffer-list)))
(save-excursion
(while buffers
(let* ((buffer (car buffers)))
(setq buffers (cdr buffers))
(set-buffer buffer)
(when buffer-file-name
;; Use buffer-file-truename instead??
(eserve-connection-message "loadedFile %s %d\n"
buffer-file-name
(if buffer-read-only 1 0))
(if (buffer-modified-p)
(eserve-connection-message "modifiedFile %s\n" buffer-file-name))
))))))
(provide 'eserve) ;Announce that we're providing the package 'eserve'.
;;; eserve.el ends here
[-- Attachment #3: workshop.el --]
[-- Type: application/octet-stream, Size: 30081 bytes --]
;; workshop.el --- Allows for integration of workshop with emacs.
;;
;; Instructions:
;;
;; If you plan to launch emacs from workshop, then you do not need to
;; do anything unless you would like to customize the commands
;; or bindings (see Customizing below).
;;
;; In order to invoke workshop from emacs, please add the following to
;; your .emacs file:
;;
;; (setq load-path (append load-path '("/opt/SUNWspro/lib")))
;; (load "workshop.el")
;;
;; Note that the path "/opt/SUNWspro/lib" is the path to the lib
;; directory of your workshop distribution.
;;
;; Once your emacs comes up and you would like to launch workshop, simply
;; issue "M-x workshop-start" in the minibuffer.
;;
;; Function keys:
;;
;; When this file is loaded, the function keys are bound to workshop
;; commands. If the user does not want workshop to bind the function
;; keys, then the variable eserve-bind-fkeys should be set to nil
;; before loading this file.
;;
;; If the user would like to change the bindings, then this file
;; should be copied and edited as described below.
;;
;; Customizing:
;;
;; In order to customize the behavior of the integration, the user
;; should copy the workshop.el file to the user's area and make the
;; desired edits to the copy of the file. The lines pertaining
;; to workshop integration would look something like:
;;
;; (setq load-path (append load-path '("/opt/SUNWspro/lib")))
;; (load "/home/user1/elisp/workshop.el")
;;
;; where the "/home/user1/elisp" can be any location. NOTE: the
;; setting of the load-path is still required in order for the
;; (require 'eserve) below to work.
;;
(require 'eserve)
(defvar workshop-process nil
"Process object for workshop process")
(defvar workshop-started nil
"Indicates whether workshop has been started/connected to")
(defvar workshop-path nil
"Indicates the path to the workshop binary, used to override use of PATH variable")
(defun workshop-check-connection ()
"Check for connection between workshop and emacs, error if no connection"
(unless workshop-started
(error "WorkShop is not connected to emacs, use M-x workshop-start to connect")))
;; Suppress compiler warnings
(eval-when-compile
(require 'eserve)
;; GNU Emacs-specific variables
(defvar menu-bar-final-items)
(defvar menu-bar-tools-menu))
;;
;; command to launch workshop and connect emacs to it.
;; NOTE: workshop must be in the user's PATH variable.
;;
(defun workshop-start ()
"Invoke workshop from emacs"
(interactive)
(when (or workshop-process workshop-started)
(error "WorkShop has already been started - use M-x workshop-quit to bring it down"))
(eserve-app-start
(if (not workshop-path)
"workshop"
(if (and (stringp workshop-path) (file-executable-p workshop-path))
workshop-path
(error "Cannot start WorkShop, bad value for workshop-path variable")))
'workshop-start-cb))
;;
;; command to quit workshop and disconnect from it.
;;
(defun workshop-quit ()
"Quit workshop process from emacs"
(interactive)
(unless (or workshop-process workshop-started)
(error "Cannot quit WorkShop; it has not been started yet. Use M-x workshop-start"))
(workshop-exit-cleanup)
(eserve-send-verb "workshop.quit" nil))
;;
;; function to setup workshop function keys
;; NOTE: If the user would rather the fkeys be left alone,
;; then the variable eserve-bind-fkeys should be set to nil
;; (before this file is loaded)
;;
(defun workshop-set-function-keys ()
"Set up function key bindings to use for workshop functions"
(when eserve-bind-fkeys
(global-set-key [f3] 'workshop-build)
(global-set-key [f4] 'workshop-next-error)
(global-set-key [f5] 'workshop-next-match)
(global-set-key [f6] 'workshop-go)
(global-set-key [f7] 'workshop-step-over)
(global-set-key [f8] 'workshop-step-into)
(global-set-key [f9] 'workshop-up-stack)
(cond
(running-xemacs
(global-set-key [(shift f4)] 'workshop-prev-error)
(global-set-key [(shift f5)] 'workshop-prev-match)
(global-set-key [(shift f6)] 'workshop-restart)
(global-set-key [(shift f8)] 'workshop-step-out)
(global-set-key [(shift f9)] 'workshop-down-stack))
(running-emacs
(global-set-key [S-f4] 'workshop-prev-error)
(global-set-key [S-f5] 'workshop-prev-match)
(global-set-key [S-f6] 'workshop-restart)
(global-set-key [S-f8] 'workshop-step-out)
(global-set-key [S-f9] 'workshop-down-stack)))))
;;
;; User interactive commands
;;
(defun workshop-open-file ()
"Tell WorkShop to open a file on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "workshop.fileopen" nil))
(defun workshop-project-add-file ()
"Tell WorkShop to add the current file to the project"
(interactive)
(workshop-check-connection)
(eserve-send-verb "workset.addfile" nil))
(defun workshop-project-remove-file ()
"Tell WorkShop to remove the current file from the project"
(interactive)
(workshop-check-connection)
(eserve-send-verb "workset.removefile" nil))
(defun workshop-build ()
"Tell WorkShop to build the current target on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "build.build" nil))
(defun workshop-build-file ()
"Tell WorkShop to build the current file on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "build.build-file" nil))
(defun workshop-next-error ()
"Tell WorkShop to go to the next error in the error browser on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "build.next-error" nil))
(defun workshop-prev-error ()
"Tell WorkShop to go to the previous error in the error browser on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "build.prev-error" nil))
(defun workshop-next-match ()
"Tell WorkShop to go to the next match in the browser on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "browse.next-match" nil))
(defun workshop-prev-match ()
"Tell WorkShop to go to the previous match in the browser on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "browse.prev-match" nil))
(defun workshop-step-into ()
"Tell WorkShop to step into a function on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.step-into" nil))
(defun workshop-step-out ()
"Tell WorkShop to step out of a function on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.step-out" nil))
(defun workshop-step-over ()
"Tell WorkShop to step over an expression on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.step-over" nil))
(defun workshop-go ()
"Tell WorkShop to run/continue running the current program on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.go" nil))
(defun workshop-interrupt ()
"Tell WorkShop to stop running the current program on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.interrupt" nil))
(defun workshop-restart ()
"Tell WorkShop to restart the current program on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.restart" nil))
(defun workshop-up-stack ()
"Tell WorkShop to go to up one stack frame on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.up" nil))
(defun workshop-down-stack ()
"Tell WorkShop to go to down one stack frame on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.down" nil))
(defun workshop-pop-stack ()
"Tell WorkShop to pop one stack frame on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.pop" nil))
(defun workshop-pop2cur-stack ()
"Tell WorkShop to pop up to the current stack frame on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.pop-to-current" nil))
(defun workshop-stop-at ()
"Tell eserve to set a breakpoint on the current line on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.stop-at" t))
(defun workshop-clear-at ()
"Tell eserve to clear the breakpoint on the current line on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.clear-at" t))
(defun workshop-stop-in ()
"Tell eserve to set a breakpoint in function indicated in the current selection"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.stop-in" t))
(defun workshop-disable-at ()
"Tell eserve to disable breakpoints on the current line on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.disable-at" t))
(defun workshop-enable-at ()
"Tell eserve to enable breakpoints on the current line on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.enable-at" t))
(defun workshop-eval ()
"Tell eserve to evaluate the expression indicated in the current selection"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.evaluate-expr" t))
(defun workshop-eval-star ()
"Tell eserve to evaluate the expression (dereferenced) indicated in the current selection"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.evaluate-expr-star" t))
(defun workshop-browse-refs ()
"Tell WorkShop to find the browser references for the selection on behalf of emacs"
(interactive)
(workshop-check-connection)
;; ### Should be checking for selection here and below. -- mrb
(eserve-send-verb "browse.showrefs" t))
(defun workshop-browse-def ()
"Tell WorkShop to find the browser definition for the selection on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "browse.showdef" t))
(defun workshop-fix ()
"Tell WorkShop to fix the current file on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.fix" t))
(defun workshop-fix-all ()
"Tell WorkShop to fix all files on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.fix-all" nil))
(defun workshop-reload ()
"Tell eserve's debugger to terminate and reload the current program on behalf of emacs"
(interactive)
(workshop-check-connection)
(eserve-send-verb "debug.reload" nil))
;;; Toolbar menu button support
(defun workshop-toolbar-invisible ()
"Make the WorkShop toolbar invisible."
(interactive)
(setq eserve-toolbar-orientation nil)
(eserve-set-toolbar-specifiers))
(defun workshop-toolbar-left ()
"Place the WorkShop toolbar on the left edge of the frame."
(interactive)
(setq eserve-toolbar-orientation 'left)
(eserve-set-toolbar-specifiers)
(eserve-install-frame-toolbar (selected-frame)))
(defun workshop-toolbar-right ()
"Place the WorkShop toolbar on the right edge of the frame."
(interactive)
(setq eserve-toolbar-orientation 'right)
(eserve-set-toolbar-specifiers)
(eserve-install-frame-toolbar (selected-frame)))
(defun workshop-toolbar-top ()
"Place the WorkShop toolbar on the top edge of the frame."
(interactive)
(setq eserve-toolbar-orientation 'top)
(eserve-set-toolbar-specifiers)
(eserve-install-frame-toolbar (selected-frame)))
(defun workshop-toolbar-bottom ()
"Place the WorkShop toolbar on the bottom edge of the frame."
(interactive)
(setq eserve-toolbar-orientation 'bottom)
(eserve-set-toolbar-specifiers)
(eserve-install-frame-toolbar (selected-frame)))
;;
;; Definitions for WorkShop menu
;;
;; See eserve.el for definition of the eserve-button vector type
;; The `sense' member in the following buttons is only the initial setting,
;; the setting is toggled from eserve `eserve-set-sensitivity'.
;; Note: there is duplicated code here. Properties of workshop buttons are
;; defined here, in eserve.el, and in IPEEditorControl.cc.
(defvar workshop-menu-handle nil)
(defvar workshop-menu [eserve-menu "WorkShop" 0 nil nil])
(defvar workshop-start-button
[eserve-button "Start WorkShop" "workshop.start"
nil "" nil t nil nil 2 workshop-start])
(defvar workshop-quit-button
[eserve-button "Quit WorkShop" "workshop.quit"
nil "" nil nil nil nil 2 workshop-quit])
(defvar workshop-project-add-button
[eserve-button "Add This File" "workset.addfile"
nil "" nil t nil nil 2 workshop-project-add-file])
(defvar workshop-project-remove-button
[eserve-button "Remove This File" "workset.removefile"
t "" nil t nil nil 2 workshop-project-remove-file])
(defvar workshop-build-button
[eserve-button "Current Target" "build.build"
nil "" nil t nil nil 2 workshop-build])
(defvar workshop-build-file-button
[eserve-button "Build This File" "build.build-file"
t "" nil t nil nil 2 workshop-build-file])
(defvar workshop-stop-at-button
[eserve-button "Stop At" "debug.stop-at"
t "" nil nil nil nil 2 workshop-stop-at])
(defvar workshop-stop-in-button
[eserve-button "Stop In Selected" "debug.stop-in"
t "" nil nil nil nil 2 workshop-stop-in])
(defvar workshop-clear-at-button
[eserve-button "Delete Breakpoint At" "debug.clear-at"
t "" nil nil nil nil 2 workshop-clear-at])
(defvar workshop-prog-go-button
[eserve-button "Continue" "debug.go"
nil "" nil nil nil nil 2 workshop-go])
(defvar workshop-prog-interrupt-button
[eserve-button "Interrupt" "debug.interrupt"
nil "" nil nil nil nil 2 workshop-interrupt])
(defvar workshop-prog-start-button
[eserve-button "Start" "debug.restart"
nil "" nil nil nil nil 2 workshop-restart])
(defvar workshop-step-into-button
[eserve-button "Into" "debug.step-into"
nil "" nil nil nil nil 2 workshop-step-into])
(defvar workshop-step-over-button
[eserve-button "Over" "debug.step-over"
nil "" nil nil nil nil 2 workshop-step-over])
(defvar workshop-step-out-button
[eserve-button "Out" "debug.step-out"
nil "" nil nil nil nil 2 workshop-step-out])
(defvar workshop-stack-up-button
[eserve-button "Up" "debug.up"
nil "" nil nil nil nil 2 workshop-up-stack])
(defvar workshop-stack-down-button
[eserve-button "Down" "debug.down"
nil "" nil nil nil nil 2 workshop-down-stack])
(defvar workshop-stack-pop-button
[eserve-button "Pop" "debug.pop"
nil "" nil nil nil nil 2 workshop-pop-stack])
(defvar workshop-stack-pop2-button
[eserve-button "Pop to Current Frame" "debug.pop-to-current"
nil "" nil nil nil nil 2 workshop-pop2cur-stack])
(defvar workshop-eval-button
[eserve-button "Selected" "debug.evaluate-expr"
t "" nil nil nil nil 2 workshop-eval])
(defvar workshop-eval-star-button
[eserve-button "As Pointer" "debug.evaluate-expr-star"
t "" nil nil nil nil 2 workshop-eval-star])
(defvar workshop-browse-refs-button
[eserve-button "References to Selected" "browse.showrefs"
t "" nil t nil nil 2 workshop-browse-refs])
(defvar workshop-browse-def-button
[eserve-button "Definition of Selected" "browse.showdef"
t "" nil nil nil nil 2 workshop-browse-def])
(defvar workshop-prog-fix-button
[eserve-button "File" "debug.fix"
t "" nil nil nil nil 2 workshop-fix])
(defvar workshop-prog-fix-all-button
[eserve-button "Program" "debug.fix-all"
nil "" nil nil nil nil 2 workshop-fix-all])
(defvar workshop-toolbar-invisible-button
[eserve-button "Invisible" "toolbar.invisible"
nil "" nil t nil nil 2 workshop-toolbar-invisible])
(defvar workshop-toolbar-left-button
[eserve-button "Left" "toolbar.left"
nil "" nil t nil nil 2 workshop-toolbar-left])
(defvar workshop-toolbar-top-button
[eserve-button "Top" "toolbar.top"
nil "" nil t nil nil 2 workshop-toolbar-top])
(defvar workshop-toolbar-right-button
[eserve-button "Right" "toolbar.right"
nil "" nil t nil nil 2 workshop-toolbar-right])
(defvar workshop-toolbar-bottom-button
[eserve-button "Bottom" "toolbar.bottom"
nil "" nil t nil nil 2 workshop-toolbar-bottom])
(defvar workshop-menu-kmap nil)
(defvar workshop-menu-project-kmap nil)
(defvar workshop-menu-build-kmap nil)
(defvar workshop-menu-fix-kmap nil)
(defvar workshop-menu-breakpts-kmap nil)
(defvar workshop-menu-program-kmap nil)
(defvar workshop-menu-step-kmap nil)
(defvar workshop-menu-stack-kmap nil)
(defvar workshop-menu-eval-kmap nil)
(defvar workshop-menu-browse-kmap nil)
;;
;; WorkShop menu creation functions
;;
(defun workshop-emacs-menu-create ()
"Add the workshop menu to the emacs menu bar"
(let ((handle `[menu-bar ,(intern (eserve-menu-label workshop-menu)) ]))
(setq workshop-menu-kmap (make-sparse-keymap
(eserve-menu-label workshop-menu)))
(define-key global-map handle
(cons (eserve-menu-label
workshop-menu) workshop-menu-kmap))
(setq workshop-menu-handle handle)
(eserve-emacs-menuitem-create workshop-menu
workshop-quit-button
workshop-menu-kmap)
(define-key workshop-menu-kmap [separator1]
'("----" . nil))
(setq workshop-menu-fix-kmap (make-sparse-keymap "WorkShop Fix"))
(fset 'workshop-menu-fix-kmap
(symbol-value 'workshop-menu-fix-kmap))
(define-key workshop-menu-kmap [fix]
'("Fix" . workshop-menu-fix-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-prog-fix-all-button
workshop-menu-fix-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-prog-fix-button
workshop-menu-fix-kmap)
(setq workshop-menu-browse-kmap (make-sparse-keymap "WorkShop Browse"))
(fset 'workshop-menu-browse-kmap
(symbol-value 'workshop-menu-browse-kmap))
(define-key workshop-menu-kmap [browse]
'("Browse" . workshop-menu-browse-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-browse-def-button
workshop-menu-browse-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-browse-refs-button
workshop-menu-browse-kmap)
(setq workshop-menu-eval-kmap (make-sparse-keymap "WorkShop Eval"))
(fset 'workshop-menu-eval-kmap
(symbol-value 'workshop-menu-eval-kmap))
(define-key workshop-menu-kmap [eval]
'("Eval" . workshop-menu-eval-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-eval-star-button
workshop-menu-eval-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-eval-button
workshop-menu-eval-kmap)
(setq workshop-menu-stack-kmap (make-sparse-keymap "WorkShop Stack"))
(fset 'workshop-menu-stack-kmap
(symbol-value 'workshop-menu-stack-kmap))
(define-key workshop-menu-kmap [stack]
'("Stack" . workshop-menu-stack-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-stack-down-button
workshop-menu-stack-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-stack-up-button
workshop-menu-stack-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-stack-pop-button
workshop-menu-stack-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-stack-pop2-button
workshop-menu-stack-kmap)
(setq workshop-menu-step-kmap (make-sparse-keymap "WorkShop Step"))
(fset 'workshop-menu-step-kmap
(symbol-value 'workshop-menu-step-kmap))
(define-key workshop-menu-kmap [step]
'("Step" . workshop-menu-step-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-step-out-button
workshop-menu-step-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-step-over-button
workshop-menu-step-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-step-into-button
workshop-menu-step-kmap)
(setq workshop-menu-program-kmap (make-sparse-keymap "WorkShop Program"))
(fset 'workshop-menu-program-kmap
(symbol-value 'workshop-menu-program-kmap))
(define-key workshop-menu-kmap [program]
'("Program" . workshop-menu-program-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-prog-interrupt-button
workshop-menu-program-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-prog-go-button
workshop-menu-program-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-prog-start-button
workshop-menu-program-kmap)
(setq workshop-menu-breakpts-kmap
(make-sparse-keymap "WorkShop Breakpoints"))
(fset 'workshop-menu-breakpts-kmap
(symbol-value 'workshop-menu-breakpts-kmap))
(define-key workshop-menu-kmap [breakpoints]
'("Breakpoints" . workshop-menu-breakpts-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-clear-at-button
workshop-menu-breakpts-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-stop-in-button
workshop-menu-breakpts-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-stop-at-button
workshop-menu-breakpts-kmap)
(setq workshop-menu-build-kmap (make-sparse-keymap "WorkShop Build"))
(fset 'workshop-menu-build-kmap
(symbol-value 'workshop-menu-build-kmap))
(define-key workshop-menu-kmap [build]
'("Build" . workshop-menu-build-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-build-file-button
workshop-menu-build-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-build-button
workshop-menu-build-kmap)
(setq workshop-menu-project-kmap (make-sparse-keymap "WorkShop Project"))
(fset 'workshop-menu-project-kmap
(symbol-value 'workshop-menu-project-kmap))
(define-key workshop-menu-kmap [project]
'("Project" . workshop-menu-project-kmap))
(eserve-emacs-menuitem-create workshop-menu
workshop-project-add-button
workshop-menu-project-kmap)
(eserve-emacs-menuitem-create workshop-menu
workshop-project-remove-button
workshop-menu-project-kmap)
;; create workshop start menu item by hand
(setq menu-bar-final-items
(append
(list (intern (eserve-menu-label workshop-menu)))
menu-bar-final-items))))
(defun workshop-emacs-menu-remove ()
"Remove the workshop menu from the emacs menu bar"
(when workshop-menu-kmap
(global-unset-key workshop-menu-handle)
(setq menu-bar-final-items
(delete (intern (eserve-menu-label workshop-menu))
menu-bar-final-items))))
(defun workshop-emacs-add-start-menuitem ()
"Add the start workshop menu item to the tools menu"
(when (boundp 'menu-bar-tools-menu)
(define-key menu-bar-tools-menu
(vector (intern (eserve-button-label workshop-start-button)))
`( ,(eserve-button-label workshop-start-button)
,(eserve-button-help workshop-start-button) .
,(eserve-button-cmd workshop-start-button)))
(setf (eserve-button-sensesym workshop-start-button)
(eserve-button-create-sensesym
workshop-start-button (eserve-menu-label workshop-menu)))
(set (eserve-button-sensesym workshop-start-button)
(eserve-button-sense workshop-start-button))
(put (eserve-button-cmd workshop-start-button)
'menu-enable (eserve-button-sensesym workshop-start-button))))
(defun workshop-xemacs-submenu (&rest buttons)
(mapcar #'(lambda (button)
(eserve-xemacs-menuitem-create workshop-menu button))
buttons))
(defun workshop-xemacs-menu-create ()
"Add the workshop menu to the emacs menu bar"
(let ((menulist
`(("Project"
,@(workshop-xemacs-submenu
workshop-project-add-button
workshop-project-remove-button))
("Build"
,@(workshop-xemacs-submenu
workshop-build-button
workshop-build-file-button))
("Breakpoints"
,@(workshop-xemacs-submenu
workshop-stop-at-button
workshop-stop-in-button
workshop-clear-at-button))
("Program"
,@(workshop-xemacs-submenu
workshop-prog-start-button
workshop-prog-go-button
workshop-prog-interrupt-button))
("Step"
,@(workshop-xemacs-submenu
workshop-step-into-button
workshop-step-over-button
workshop-step-out-button))
("Stack"
,@(workshop-xemacs-submenu
workshop-stack-up-button
workshop-stack-down-button
workshop-stack-pop-button
workshop-stack-pop2-button))
("Evaluate"
,@(workshop-xemacs-submenu
workshop-eval-button
workshop-eval-star-button))
("Browse"
,@(workshop-xemacs-submenu
workshop-browse-refs-button
workshop-browse-def-button))
("Fix"
,@(workshop-xemacs-submenu
workshop-prog-fix-button
workshop-prog-fix-all-button))
;;; To disable the `Toolbar' menu, comment out the following form:
,@(if (featurep 'toolbar)
`(("Toolbar"
,@(workshop-xemacs-submenu
workshop-toolbar-left-button
workshop-toolbar-top-button
workshop-toolbar-right-button
workshop-toolbar-bottom-button
workshop-toolbar-invisible-button))))
"----"
,(eserve-xemacs-menuitem-create workshop-menu
workshop-quit-button))))
(setq workshop-menu-handle (list (eserve-menu-label workshop-menu)))
(save-excursion
(dolist (buffer (buffer-list))
(set-buffer buffer)
(add-submenu
nil
(cons (eserve-menu-label workshop-menu) menulist))))))
(defun workshop-xemacs-menu-remove ()
"Remove the workshop menu from the xemacs menu bar"
(when (car (find-menu-item current-menubar
(list (eserve-menu-label workshop-menu))))
(save-excursion
(dolist (buffer (buffer-list))
(set-buffer buffer)
(delete-menu-item workshop-menu-handle)))))
(defun workshop-xemacs-add-start-menuitem ()
"Add the start workshop menu item to the tools menu"
(eserve-xemacs-menuitem-create workshop-menu workshop-start-button)
(add-menu-button
'("Tools")
(vector
"Start WorkShop" 'workshop-start
(eserve-button-sensesym workshop-start-button) nil)
"Grep..."))
;;
;; WorkShop process functions
;;
(defun workshop-process-sentinel (process status)
"Handle changes in STATUS to workshop PROCESS."
(when (memq (process-status process) '(signal exit closed))
(workshop-exit-cleanup)
(setq workshop-process nil)
(message "Connection to workshop terminated")))
(defun workshop-start-cb (proc)
"Callback for start of workshop process"
(workshop-startup-init)
(setq workshop-process proc)
(set-process-sentinel workshop-process 'workshop-process-sentinel))
(defun workshop-startup-init ()
"Setup emacs after workshop starts it"
(setq workshop-started t)
;; add workshop menu
(workshop-menu-create)
;; enable workshop-quit, disable workshop-start
(when (eserve-button-sensesym workshop-start-button)
(set (eserve-button-sensesym workshop-start-button) nil))
(when (eserve-button-sensesym workshop-quit-button)
(set (eserve-button-sensesym workshop-quit-button) t))
(when running-xemacs
(workshop-update-default-toolbar)))
(defun workshop-exit-cleanup ()
"Cleanup after workshop exit"
(setq workshop-started nil)
;; remove workshop menu
(workshop-menu-remove)
;; enable workshop-start, disable workshop-quit
(when (eserve-button-sensesym workshop-start-button)
(set (eserve-button-sensesym workshop-start-button) t))
(when (eserve-button-sensesym workshop-quit-button)
(set (eserve-button-sensesym workshop-quit-button) nil))
(when running-xemacs
(workshop-update-default-toolbar)))
(defvar toolbar-workshop-icon nil "A `workshop' icon set.")
(defun workshop-update-default-toolbar ()
"Update the default toolbar with changes to workshop buttons"
(set-specifier default-toolbar (specifier-instance default-toolbar)))
(defun workshop-frob-toolbar ()
"Replace Debug and Compile toolbar buttons with the `Start WorkShop' button."
(when (and (featurep 'xpm)
(featurep 'toolbar)
(consp (specifier-instance default-toolbar)))
(let ((prefix (expand-file-name "workshop" toolbar-icon-directory)))
(setq toolbar-workshop-icon
(toolbar-make-button-list
(concat prefix "-up.xpm")
nil
(concat prefix "-xx.xpm")
(concat prefix "-cap-up.xpm")
nil
(concat prefix "-cap-xx.xpm"))))
;; Remove the (non-WorkShop) debug and compile button from the toolbar
(let ((buttons (specifier-instance default-toolbar)))
(setq buttons
(delete-if
(lambda (button)
(memq (aref button 1) '(toolbar-debug toolbar-compile)))
buttons))
;; Add workshop button, if not already there
(unless (find-if (lambda (button) (eq (aref button 1) 'workshop-start))
buttons)
(setq buttons
(append buttons
`([toolbar-workshop-icon
workshop-start
,(eserve-button-sensesym workshop-start-button)
"Start Sun WorkShop"]))))
(set-specifier default-toolbar buttons))))
(cond
(running-emacs
(workshop-emacs-add-start-menuitem)
(defalias 'workshop-menu-create 'workshop-emacs-menu-create)
(defalias 'workshop-menu-remove 'workshop-emacs-menu-remove))
(running-xemacs
(workshop-xemacs-add-start-menuitem)
(workshop-frob-toolbar)
(defalias 'workshop-menu-create 'workshop-xemacs-menu-create)
(defalias 'workshop-menu-remove 'workshop-xemacs-menu-remove)))
(provide 'workshop) ;Announce that we're providing the package 'workshop'.
;;; workshop.el ends here
[-- Attachment #4: Type: text/plain, Size: 148 bytes --]
_______________________________________________
Bug-gnu-emacs mailing list
Bug-gnu-emacs@gnu.org
http://mail.gnu.org/mailman/listinfo/bug-gnu-emacs
^ permalink raw reply [flat|nested] 5+ messages in thread