cgit.sxemacs.org Git - packages/blob - xemacs-packages/jde/lisp/jde-xemacs.el

   1 ;;; jde-xemacs.el -- xemacs specific code for JDEE.
   2 ;; Keywords: java, tools, debugging
   3
   4 ;; Copyright (C) 2002, 2003, 2004 Andy Piper <andy@xemacs.org>
   5 ;; Copyright (C) 2002 Paul Kinnucan <paulk@mathworks.com>
   6 ;;
   7 ;; This file is part of XEmacs.
   8 ;;
   9 ;; XEmacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2 of the License, or
  12 ;; (at your option) any later version.
  13 ;;
  14 ;; XEmacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with XEmacs; if not, write to the Free Software
  21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 ;; Please send bug reports and enhancement suggestions
  24 ;; to Andy Piper at <andy@xemacs.org>
  25 ;;
  26 ;; If you don't use XEmacs, you should! XEmacs kicks some serious
  27 ;; butt!
  28
  29
  30 ;; XEmacs doesn't have replace-regexp-in-string so define our own
  31 ;; version
  32 (unless (fboundp 'replace-regexp-in-string)
  33 (defun replace-regexp-in-string (regexp rep string &optional
  34                                         fixedcase literal subexp start)
  35   "Replace all matches for REGEXP with REP in STRING.
  36
  37 Return a new string containing the replacements.
  38
  39 Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the
  40 arguments with the same names of function `replace-match'.  If START
  41 is non-nil, start replacements at that index in STRING.
  42
  43 REP is either a string used as the NEWTEXT arg of `replace-match' or a
  44 function.  If it is a function it is applied to each match to generate
  45 the replacement passed to `replace-match'; the match-data at this
  46 point are such that match 0 is the function's argument.
  47
  48 To replace only the first match (if any), make REGEXP match up to \\'
  49 and replace a sub-expression, e.g.
  50   (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1)
  51     => \" bar foo\"
  52 "
  53
  54   ;; To avoid excessive consing from multiple matches in long strings,
  55   ;; don't just call `replace-match' continually.  Walk down the
  56   ;; string looking for matches of REGEXP and building up a (reversed)
  57   ;; list MATCHES.  This comprises segments of STRING which weren't
  58   ;; matched interspersed with replacements for segments that were.
  59   ;; [For a `large' number of replacments it's more efficient to
  60   ;; operate in a temporary buffer; we can't tell from the function's
  61   ;; args whether to choose the buffer-based implementation, though it
  62   ;; might be reasonable to do so for long enough STRING.]
  63   (let ((l (length string))
  64         (start (or start 0))
  65         matches str mb me)
  66     (save-match-data
  67       (while (and (< start l) (string-match regexp string start))
  68         (setq mb (match-beginning 0)
  69               me (match-end 0))
  70         ;; If we matched the empty string, make sure we advance by one char
  71         (when (= me mb) (setq me (min l (1+ mb))))
  72         ;; Generate a replacement for the matched substring.
  73         ;; Operate only on the substring to minimize string consing.
  74         ;; Set up match data for the substring for replacement;
  75         ;; presumably this is likely to be faster than munging the
  76         ;; match data directly in Lisp.
  77         (string-match regexp (setq str (substring string mb me)))
  78         (setq matches
  79               (cons (replace-match (if (stringp rep)
  80                                        rep
  81                                      (funcall rep (match-string 0 str)))
  82                                    fixedcase literal str subexp)
  83                     (cons (substring string start mb) ; unmatched prefix
  84                           matches)))
  85         (setq start me))
  86       ;; Reconstruct a string from the pieces.
  87       (setq matches (cons (substring string start l) matches)) ; leftover
  88       (apply #'concat (nreverse matches)))))
  89 )
  90
  91 (unless (fboundp 'subst-char-in-string)
  92   (defun subst-char-in-string (fromchar tochar string &optional inplace)
  93     "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
  94 Unless optional argument INPLACE is non-nil, return a new string."
  95     (let ((i (length string))
  96           (newstr (if inplace string (copy-sequence string))))
  97       (while (> i 0)
  98         (setq i (1- i))
  99         (if (eq (aref newstr i) fromchar)
 100             (aset newstr i tochar)))
 101       newstr)))
 102
 103 ;; For non-MULE versions of xemacs
 104 (unless (fboundp 'coding-system-list)
 105   (defun coding-system-list (&optional base-only)
 106     '(raw-text)))
 107
 108 ;; XEmacs is missing `match-string-no-properties'.
 109 (unless (fboundp 'match-string-no-properties)
 110   (defun match-string-no-properties (num &optional string)
 111      "Return string of text matched by last search, without text properties.
 112 NUM specifies which parenthesized expression in the last regexp.
 113 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
 114 Zero means the entire text matched by the whole regexp or whole string.
 115 STRING should be given if the last search was by `string-match' on STRING."
 116     (let ((match (match-string num string)))
 117        (and match (set-text-properties 0 (length match) nil match))
 118       match)))
 119
 120 (unless (fboundp 'line-beginning-position)
 121   (defun line-beginning-position (&optional n)
 122     "Return the character position of the first character on the
 123 current line. With argument N not nil or 1, move forward N - 1 lines first.
 124 If scan reaches end of buffer, return that position."
 125     (save-excursion (beginning-of-line n) (point))))
 126
 127 (unless (fboundp 'line-end-position)
 128   (defun line-end-position (&optional n)
 129     "Return the character position of the last character on the
 130 current line. With argument N not nil or 1, move forward N - 1 lines first.
 131 If scan reaches end of buffer, return that position."
 132     (save-excursion (end-of-line n) (point))))
 133
 134 ;; XEmacs does not define run-with-timer and run-with-idle-timer
 135
 136 (unless (fboundp 'run-with-timer)
 137   (defun run-with-timer (secs repeat function &rest args)
 138     (start-itimer "timer" function secs repeat
 139                   nil (if args t nil) args))
 140   (defun run-with-idle-timer (secs repeat function &rest args)
 141     (start-itimer "idle timer"
 142                   function secs (if repeat secs nil)
 143                   t (if args t nil) args)))
 144
 145 (when (featurep 'toolbar)
 146   (require 'debug-toolbar))
 147
 148 (require 'jde-bug)
 149 (require 'jde-compile)
 150
 151 ;; Install gui options on XEmacs versions that can understand them
 152 (when (and (featurep 'widget)
 153            ;; XEmacs change: use `emacs-version>=' for the check
 154            (emacs-version>= 21 4 10))
 155   (require 'efc-xemacs))
 156
 157 ;; Redefine toolbar-debug and toolbar-compile so that clicking the
 158 ;; icons on the toolbar will pop us into jde functions.
 159 (defun toolbar-debug ()
 160   (interactive)
 161   (call-interactively 'jde-debug))
 162
 163 (defun toolbar-compile ()
 164   (interactive)
 165   (call-interactively 'jde-compile))
 166
 167 (add-hook 'jde-bug-minor-mode-hook
 168           '(lambda (&optional on)
 169              (if on
 170                  (easy-menu-add jde-bug-menu-spec jde-bug-mode-map)
 171                (easy-menu-remove jde-bug-menu-spec))))
 172
 173 (defvar jde-xemacs-old-toolbar nil
 174   "Saved toolbar for buffer.")
 175
 176 (defvar jde-xemacs-old-hooks nil
 177   "Saved hooks for buffer.")
 178
 179 (defvar jde-xemacs-bug-mode-active nil
 180   "Indicates whether jde-xemacs-bug-minor-mode is active.")
 181
 182 (defvar jde-xemacs-bug-minor-mode nil
 183   "Indicates whether buffer is in jde-xemacs-bug-minor-mode or not")
 184 (make-variable-buffer-local 'jde-xemacs-bug-minor-mode)
 185
 186 ;; Make sure we only get the toolbar when we start debugging.
 187 (add-hook 'jde-dbs-debugger-hook 'jde-xemacs-bug-minor-mode)
 188
 189 (defvar jde-xemacs-bug-initial-readonly  'undefined
 190   "read-only status of buffer when not in jde-xemacs-bug-minor-mode")
 191
 192 (defvar jde-xemacs-bug-minor-mode-map
 193   (let ((map (make-sparse-keymap)))
 194     (suppress-keymap map)
 195     (set-keymap-name map 'jde-xemacs-bug-minor-mode-map)
 196 ;    (set-keymap-parent map jde-bug-mode-map)
 197     (define-key map "\C-x\C-q" 'jde-xemacs-bug-minor-mode) ; toggle read-only
 198     (define-key map "c" 'jde-bug-continue)
 199     (define-key map "n" 'jde-bug-step-over)
 200     (define-key map "i" 'jde-bug-step-into)
 201     (define-key map "b" 'jde-bug-toggle-breakpoint)
 202     (define-key map "r" 'jde-bug-step-out)
 203     (define-key map "g" 'jde-debug)
 204     (define-key map "u" 'jde-bug-up-stack)
 205     (define-key map "d" 'jde-bug-down-stack)
 206     (define-key map "p" 'jde-bug-evaluate-expression)
 207     (define-key map "q" 'jde-bug-exit)
 208     map)
 209   "Minor keymap for buffers in jde-xemacs-bug-minor-mode")
 210
 211 ;; Create a new minor mode jde-bug-minor-mode is no good because it is
 212 ;; unconditionally on.
 213 (semantic-add-minor-mode 'jde-xemacs-bug-minor-mode "[src]" jde-xemacs-bug-minor-mode-map)
 214
 215 (defvar jde-xemacs-toolbar
 216   '([debug::toolbar-stop-at-icon
 217      jde-bug-toggle-breakpoint
 218      t
 219      "Stop at selected position"]
 220     [debug::toolbar-stop-in-icon
 221      jde-bug-set-conditional-breakpoint
 222      nil
 223      "Stop in function whose name is selected"]
 224     [debug::toolbar-clear-at-icon
 225      jde-bug-toggle-breakpoint
 226      t
 227      "Clear at selected position"]
 228     [debug::toolbar-evaluate-icon
 229      jde-bug-evaluate-expression
 230      (and
 231       (jde-dbs-debugger-running-p)
 232       (jde-dbs-get-target-process))
 233      "Evaluate selected expression"]
 234     [debug::toolbar-run-icon
 235      jde-debug
 236      t
 237      "Run current program"]
 238     [debug::toolbar-cont-icon
 239      jde-bug-continue
 240      (jde-dbs-target-process-runnable-p)
 241      "Continue current program"]
 242     [debug::toolbar-step-into-icon
 243      jde-bug-step-into
 244      (jde-dbs-target-process-steppable-p)
 245      "Step into (aka step)"]
 246     [debug::toolbar-step-over-icon
 247      jde-bug-step-over
 248      (jde-dbs-target-process-steppable-p)
 249      "Step over (aka next)"]
 250     [debug::toolbar-up-icon
 251      jde-xemacs-toolbar-up
 252      (or
 253       (not (jde-dbs-target-process-steppable-p))
 254       (let* ((process (jde-dbs-get-target-process))
 255              (stack-max
 256               (if (slot-boundp process 'stack)
 257                   (1- (length (oref process stack)))
 258                 0))
 259              (stack-ptr (oref process stack-ptr)))
 260         (< stack-ptr stack-max)))
 261      "Go Up (towards \"cooler\" - less recently visited - frames, or superclass)"]
 262     [debug::toolbar-down-icon
 263      jde-xemacs-toolbar-down
 264      (or
 265       (not (jde-dbs-target-process-steppable-p))
 266       (let* ((process (jde-dbs-get-target-process))
 267              (stack-ptr (oref process stack-ptr)))
 268         (> stack-ptr 0)))
 269      "Go Down (towards \"warmer\" - more recently visited - frames, or class at point)"]
 270     [debug::toolbar-fix-icon
 271      nil
 272      nil
 273      "Fix (not available with jde-bug)"]
 274     [debug::toolbar-build-icon
 275      jde-compile
 276      t
 277      "Compile the current file"]
 278     ))
 279
 280 (defun jde-xemacs-bug-minor-mode (arg &optional quiet)
 281   "Minor mode for interacting with JDEbug from a Java source file.
 282 With arg, turn jde-xemacs-bug-minor-mode on iff arg is positive.  In
 283 jde-xemacs-bug-minor-mode, you may send an associated JDEbug buffer commands
 284 from the current buffer containing Java source code."
 285   (interactive "P")
 286   (setq jde-xemacs-bug-minor-mode
 287         (if (null arg)
 288             (not jde-xemacs-bug-minor-mode)
 289           (> (prefix-numeric-value arg) 0)))
 290
 291   (cond (jde-xemacs-bug-minor-mode
 292          ;; Turn on jde-xemacs-bug-minor-mode
 293          (when (not (local-variable-p 'jde-xemacs-bug-initial-readonly (current-buffer)))
 294            (set (make-local-variable 'jde-xemacs-bug-initial-readonly)
 295                 buffer-read-only))
 296          (jde-xemacs-insert-toolbar nil)
 297          (setq buffer-read-only t)
 298          ;; Save old hooks and make sure we get turned on for new
 299          ;; buffers.
 300          (unless jde-xemacs-bug-mode-active
 301            (setq jde-xemacs-old-hooks jde-entering-java-buffer-hook)
 302            (setq jde-entering-java-buffer-hook '(jde-xemacs-bug-minor-mode-hook))
 303            ;; Make sure turning off jde-bug mode turns us off also.
 304            (add-hook 'jde-bug-minor-mode-hook 'jde-xemacs-bug-minor-mode)
 305            (setq jde-xemacs-bug-mode-active t))
 306          ;; Killing the buffer kills the mode
 307          (make-local-hook 'kill-buffer-hook)
 308          (add-hook 'kill-buffer-hook 'jde-xemacs-bug-minor-mode-reset nil t)
 309          (or quiet (message "Entering jde-xemacs-bug-minor-mode...")))
 310         (t
 311          ;; Turn off jde-xemacs-bug-minor-mode
 312          (and (local-variable-p 'jde-xemacs-bug-initial-readonly (current-buffer))
 313               (progn
 314                 (setq buffer-read-only jde-xemacs-bug-initial-readonly)
 315                 (kill-local-variable 'jde-xemacs-bug-initial-readonly)
 316                 ))
 317          (jde-xemacs-insert-toolbar t)
 318          ;; First time through kill the hooks and reset all other
 319          ;; associated buffers.
 320          (when jde-xemacs-bug-mode-active
 321            (setq jde-entering-java-buffer-hook jde-xemacs-old-hooks)
 322            (setq jde-xemacs-old-hooks nil)
 323            (setq jde-xemacs-bug-mode-active nil)
 324            (remove-hook 'jde-bug-minor-mode-hook 'jde-xemacs-bug-minor-mode)
 325            (jde-xemacs-bug-minor-mode-reset))
 326          (or quiet (message "Exiting jde-xemacs-bug-minor-mode..."))))
 327   (redraw-modeline t))
 328
 329 (defun jde-xemacs-bug-minor-mode-hook ()
 330   "Hook function to run when entering a Java buffer while in bug-minor-mode."
 331   (jde-xemacs-bug-minor-mode t t))
 332
 333 (defun jde-xemacs-bug-minor-mode-reset ()
 334   ;; tidy house and turn off jde-xemacs-bug-minor-mode in all buffers
 335   (mapcar #'(lambda (buffer)
 336               (set-buffer buffer)
 337               (cond ((local-variable-p 'jde-xemacs-bug-initial-readonly (current-buffer))
 338                      (jde-xemacs-bug-minor-mode -1 t))))
 339           (buffer-list)))
 340
 341 ;;;###autoload
 342 (defun jde-xemacs-insert-toolbar (&optional remove)
 343   "Insert or remove JDE toolbar in the XEmacs toolbar."
 344   (interactive "P")
 345   (when (featurep 'toolbar)
 346     (if remove
 347         (progn
 348           (if (and jde-xemacs-old-toolbar (not (eq jde-xemacs-old-toolbar 'default)))
 349               (set-specifier default-toolbar
 350                              (cons (current-buffer)
 351                                    jde-xemacs-old-toolbar))
 352             (remove-specifier default-toolbar (current-buffer)))
 353           (kill-local-variable 'jde-xemacs-old-toolbar))
 354       (unless jde-xemacs-old-toolbar
 355         (set (make-local-variable 'jde-xemacs-old-toolbar)
 356              (or (specifier-specs default-toolbar (current-buffer)) 'default)))
 357       (set-specifier default-toolbar (cons (current-buffer)
 358                                            jde-xemacs-toolbar)))))
 359
 360 (defun jde-xemacs-toolbar-up ()
 361   (interactive)
 362   (if (jde-dbs-target-process-steppable-p)
 363       (jde-bug-up-stack)
 364     (jde-show-superclass-source)))
 365
 366 (defun jde-xemacs-toolbar-down ()
 367   (interactive)
 368   (if (jde-dbs-target-process-steppable-p)
 369       (jde-bug-down-stack)
 370     (jde-show-class-source)))
 371
 372 (provide 'jde-xemacs)