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

   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            (>= emacs-major-version 21)
 154            (>= emacs-minor-version 4)
 155            (>= emacs-patch-level 10))
 156   (require 'efc-xemacs))
 157
 158 ;; Redefine toolbar-debug and toolbar-compile so that clicking the
 159 ;; icons on the toolbar will pop us into jde functions.
 160 (defun toolbar-debug ()
 161   (interactive)
 162   (call-interactively 'jde-debug))
 163
 164 (defun toolbar-compile ()
 165   (interactive)
 166   (call-interactively 'jde-compile))
 167
 168 (add-hook 'jde-bug-minor-mode-hook
 169           '(lambda (&optional on)
 170              (if on
 171                  (easy-menu-add jde-bug-menu-spec jde-bug-mode-map)
 172                (easy-menu-remove jde-bug-menu-spec))))
 173
 174 (defvar jde-xemacs-old-toolbar nil
 175   "Saved toolbar for buffer.")
 176
 177 (defvar jde-xemacs-old-hooks nil
 178   "Saved hooks for buffer.")
 179
 180 (defvar jde-xemacs-bug-mode-active nil
 181   "Indicates whether jde-xemacs-bug-minor-mode is active.")
 182
 183 (defvar jde-xemacs-bug-minor-mode nil
 184   "Indicates whether buffer is in jde-xemacs-bug-minor-mode or not")
 185 (make-variable-buffer-local 'jde-xemacs-bug-minor-mode)
 186
 187 ;; Make sure we only get the toolbar when we start debugging.
 188 (add-hook 'jde-dbs-debugger-hook 'jde-xemacs-bug-minor-mode)
 189
 190 (defvar jde-xemacs-bug-initial-readonly  'undefined
 191   "read-only status of buffer when not in jde-xemacs-bug-minor-mode")
 192
 193 (defvar jde-xemacs-bug-minor-mode-map
 194   (let ((map (make-sparse-keymap)))
 195     (suppress-keymap map)
 196     (set-keymap-name map 'jde-xemacs-bug-minor-mode-map)
 197 ;    (set-keymap-parent map jde-bug-mode-map)
 198     (define-key map "\C-x\C-q" 'jde-xemacs-bug-minor-mode) ; toggle read-only
 199     (define-key map "c" 'jde-bug-continue)
 200     (define-key map "n" 'jde-bug-step-over)
 201     (define-key map "i" 'jde-bug-step-into)
 202     (define-key map "b" 'jde-bug-toggle-breakpoint)
 203     (define-key map "r" 'jde-bug-step-out)
 204     (define-key map "g" 'jde-debug)
 205     (define-key map "u" 'jde-bug-up-stack)
 206     (define-key map "d" 'jde-bug-down-stack)
 207     (define-key map "p" 'jde-bug-evaluate-expression)
 208     (define-key map "q" 'jde-bug-exit)
 209     map)
 210   "Minor keymap for buffers in jde-xemacs-bug-minor-mode")
 211
 212 ;; Create a new minor mode jde-bug-minor-mode is no good because it is
 213 ;; unconditionally on.
 214 (semantic-add-minor-mode 'jde-xemacs-bug-minor-mode "[src]" jde-xemacs-bug-minor-mode-map)
 215
 216 (defvar jde-xemacs-toolbar
 217   '([debug::toolbar-stop-at-icon
 218      jde-bug-toggle-breakpoint
 219      t
 220      "Stop at selected position"]
 221     [debug::toolbar-stop-in-icon
 222      jde-bug-set-conditional-breakpoint
 223      nil
 224      "Stop in function whose name is selected"]
 225     [debug::toolbar-clear-at-icon
 226      jde-bug-toggle-breakpoint
 227      t
 228      "Clear at selected position"]
 229     [debug::toolbar-evaluate-icon
 230      jde-bug-evaluate-expression
 231      (and
 232       (jde-dbs-debugger-running-p)
 233       (jde-dbs-get-target-process))
 234      "Evaluate selected expression"]
 235     [debug::toolbar-run-icon
 236      jde-debug
 237      t
 238      "Run current program"]
 239     [debug::toolbar-cont-icon
 240      jde-bug-continue
 241      (jde-dbs-target-process-runnable-p)
 242      "Continue current program"]
 243     [debug::toolbar-step-into-icon
 244      jde-bug-step-into
 245      (jde-dbs-target-process-steppable-p)
 246      "Step into (aka step)"]
 247     [debug::toolbar-step-over-icon
 248      jde-bug-step-over
 249      (jde-dbs-target-process-steppable-p)
 250      "Step over (aka next)"]
 251     [debug::toolbar-up-icon
 252      jde-xemacs-toolbar-up
 253      (or
 254       (not (jde-dbs-target-process-steppable-p))
 255       (let* ((process (jde-dbs-get-target-process))
 256              (stack-max
 257               (if (slot-boundp process 'stack)
 258                   (1- (length (oref process stack)))
 259                 0))
 260              (stack-ptr (oref process stack-ptr)))
 261         (< stack-ptr stack-max)))
 262      "Go Up (towards \"cooler\" - less recently visited - frames, or superclass)"]
 263     [debug::toolbar-down-icon
 264      jde-xemacs-toolbar-down
 265      (or
 266       (not (jde-dbs-target-process-steppable-p))
 267       (let* ((process (jde-dbs-get-target-process))
 268              (stack-ptr (oref process stack-ptr)))
 269         (> stack-ptr 0)))
 270      "Go Down (towards \"warmer\" - more recently visited - frames, or class at point)"]
 271     [debug::toolbar-fix-icon
 272      nil
 273      nil
 274      "Fix (not available with jde-bug)"]
 275     [debug::toolbar-build-icon
 276      jde-compile
 277      t
 278      "Compile the current file"]
 279     ))
 280
 281 (defun jde-xemacs-bug-minor-mode (arg &optional quiet)
 282   "Minor mode for interacting with JDEbug from a Java source file.
 283 With arg, turn jde-xemacs-bug-minor-mode on iff arg is positive.  In
 284 jde-xemacs-bug-minor-mode, you may send an associated JDEbug buffer commands
 285 from the current buffer containing Java source code."
 286   (interactive "P")
 287   (setq jde-xemacs-bug-minor-mode
 288         (if (null arg)
 289             (not jde-xemacs-bug-minor-mode)
 290           (> (prefix-numeric-value arg) 0)))
 291
 292   (cond (jde-xemacs-bug-minor-mode
 293          ;; Turn on jde-xemacs-bug-minor-mode
 294          (when (not (local-variable-p 'jde-xemacs-bug-initial-readonly (current-buffer)))
 295            (set (make-local-variable 'jde-xemacs-bug-initial-readonly)
 296                 buffer-read-only))
 297          (jde-xemacs-insert-toolbar nil)
 298          (setq buffer-read-only t)
 299          ;; Save old hooks and make sure we get turned on for new
 300          ;; buffers.
 301          (unless jde-xemacs-bug-mode-active
 302            (setq jde-xemacs-old-hooks jde-entering-java-buffer-hook)
 303            (setq jde-entering-java-buffer-hook '(jde-xemacs-bug-minor-mode-hook))
 304            ;; Make sure turning off jde-bug mode turns us off also.
 305            (add-hook 'jde-bug-minor-mode-hook 'jde-xemacs-bug-minor-mode)
 306            (setq jde-xemacs-bug-mode-active t))
 307          ;; Killing the buffer kills the mode
 308          (make-local-hook 'kill-buffer-hook)
 309          (add-hook 'kill-buffer-hook 'jde-xemacs-bug-minor-mode-reset nil t)
 310          (or quiet (message "Entering jde-xemacs-bug-minor-mode...")))
 311         (t
 312          ;; Turn off jde-xemacs-bug-minor-mode
 313          (and (local-variable-p 'jde-xemacs-bug-initial-readonly (current-buffer))
 314               (progn
 315                 (setq buffer-read-only jde-xemacs-bug-initial-readonly)
 316                 (kill-local-variable 'jde-xemacs-bug-initial-readonly)
 317                 ))
 318          (jde-xemacs-insert-toolbar t)
 319          ;; First time through kill the hooks and reset all other
 320          ;; associated buffers.
 321          (when jde-xemacs-bug-mode-active
 322            (setq jde-entering-java-buffer-hook jde-xemacs-old-hooks)
 323            (setq jde-xemacs-old-hooks nil)
 324            (setq jde-xemacs-bug-mode-active nil)
 325            (remove-hook 'jde-bug-minor-mode-hook 'jde-xemacs-bug-minor-mode)
 326            (jde-xemacs-bug-minor-mode-reset))
 327          (or quiet (message "Exiting jde-xemacs-bug-minor-mode..."))))
 328   (redraw-modeline t))
 329
 330 (defun jde-xemacs-bug-minor-mode-hook ()
 331   "Hook function to run when entering a Java buffer while in bug-minor-mode."
 332   (jde-xemacs-bug-minor-mode t t))
 333
 334 (defun jde-xemacs-bug-minor-mode-reset ()
 335   ;; tidy house and turn off jde-xemacs-bug-minor-mode in all buffers
 336   (mapcar #'(lambda (buffer)
 337               (set-buffer buffer)
 338               (cond ((local-variable-p 'jde-xemacs-bug-initial-readonly (current-buffer))
 339                      (jde-xemacs-bug-minor-mode -1 t))))
 340           (buffer-list)))
 341
 342 ;;;###autoload
 343 (defun jde-xemacs-insert-toolbar (&optional remove)
 344   "Insert or remove JDE toolbar in the XEmacs toolbar."
 345   (interactive "P")
 346   (when (featurep 'toolbar)
 347     (if remove
 348         (progn
 349           (if (and jde-xemacs-old-toolbar (not (eq jde-xemacs-old-toolbar 'default)))
 350               (set-specifier default-toolbar
 351                              (cons (current-buffer)
 352                                    jde-xemacs-old-toolbar))
 353             (remove-specifier default-toolbar (current-buffer)))
 354           (kill-local-variable 'jde-xemacs-old-toolbar))
 355       (unless jde-xemacs-old-toolbar
 356         (set (make-local-variable 'jde-xemacs-old-toolbar)
 357              (or (specifier-specs default-toolbar (current-buffer)) 'default)))
 358       (set-specifier default-toolbar (cons (current-buffer)
 359                                            jde-xemacs-toolbar)))))
 360
 361 (defun jde-xemacs-toolbar-up ()
 362   (interactive)
 363   (if (jde-dbs-target-process-steppable-p)
 364       (jde-bug-up-stack)
 365     (jde-show-superclass-source)))
 366
 367 (defun jde-xemacs-toolbar-down ()
 368   (interactive)
 369   (if (jde-dbs-target-process-steppable-p)
 370       (jde-bug-down-stack)
 371     (jde-show-class-source)))
 372
 373 (provide 'jde-xemacs)