code.delx.au - gnu-emacs-elpa/blob - packages/realgud/realgud/common/bp.el

   1 ;; Copyright (C) 2010, 2012-2015 Rocky Bernstein <rocky@gnu.org>
   2 ;; Code associated with breakpoints
   3
   4 (require 'image)
   5 (require 'load-relative)
   6 (require-relative-list '("loc" "bp-image-data") "realgud-")
   7
   8 (defvar realgud-bp-enabled-icon nil
   9   "Icon for an enabled breakpoint in display margin.")
  10
  11 (defvar realgud-bp-disabled-icon nil
  12   "Icon for a disabled breakpoint in display margin.")
  13
  14 (defun realgud-bp-remove-icons (&optional opt-begin-pos opt-end-pos)
  15   "Remove dbgr breakpoint icons (overlays) in the region
  16 OPT-BEGIN-POS to OPT-END-POS. The default value for OPT-BEGIN-POS
  17 is `point'.  The default value for OPT-END-POS is OPT-BEGIN-POS.
  18
  19 The way we determine if an overlay is ours is by inspecting the
  20 overlay for a before-string property containing one we normally set.
  21 "
  22   (interactive "r")
  23   (let* ((begin-pos (or opt-begin-pos (point)))
  24          (end-pos (or opt-end-pos begin-pos))
  25         )
  26     (dolist (overlay (overlays-in begin-pos end-pos))
  27       ;; We determine if this overlay is one we set by seeing if the
  28       ;; string in its 'before-string property has a 'realgud-bptno property
  29       (let ((before-string (overlay-get overlay 'before-string)))
  30         (when (and before-string (get-text-property 0 'realgud-bptno before-string))
  31           (delete-overlay overlay)
  32           )
  33         )
  34       )
  35     )
  36   )
  37
  38 (defun realgud-set-bp-icons()
  39   (if (display-images-p)
  40     ;; NOTE: if you don't see the icon, check the that the window margin
  41     ;; is not nil.
  42       (progn
  43         (setq realgud-bp-enabled-icon
  44               (find-image `((:type xpm :data
  45                                    ,realgud-bp-xpm-data
  46                                    :ascent 100 :pointer hand)
  47                             (:type svg :data
  48                                    ,realgud-bp-enabled-svg-data
  49                                    :ascent 100 :pointer hand)
  50                             (:type tiff :data
  51                                    ,realgud-bp-enabled-tiff-data
  52                                    :ascent 100 :pointer hand)
  53                             (:type pbm :data
  54                                    ,realgud-bp-enabled-pbm-data
  55                                    :ascent 100 :pointer hand)
  56                             )))
  57
  58         ;; For seeing what realgud-bp-enabled-icon looks like:
  59         ;; (insert-image realgud-bp-enabled-icon)
  60
  61         (setq realgud-bp-disabled-icon
  62               (find-image `((:type xpm :data
  63                                    ,realgud-bp-xpm-data
  64                                    :conversion disabled ;; different than 'enabled'
  65                                    :ascent 100 :pointer hand)
  66                             (:type svg :data
  67                                    ,realgud-bp-disabled-svg-data
  68                                    :ascent 100 :pointer hand)
  69                             (:type tiff :data
  70                                    ,realgud-bp-disabled-tiff-data
  71                                    :ascent 100 :pointer hand)
  72                             (:type pbm :data
  73                                    ,realgud-bp-disabled-pbm-data
  74                                    :ascent 100 :pointer hand)
  75                             (:type svg :data
  76                                    ,realgud-bp-disabled-svg-data
  77                                    :ascent 100 :pointer hand)
  78                             )))
  79         ;; For seeing what realgud-bp-enabled-icon looks like:
  80         ;; (insert-image realgud-bp-disabled-icon)
  81         )
  82     (message "Display doesn't support breakpoint images in fringe")
  83     )
  84   )
  85
  86
  87 (defun realgud-bp-put-icon (pos enabled bp-num &optional opt-buf)
  88   "Add a breakpoint icon in the left margin at POS via a `put-image' overlay.
  89 The alternate string name for the image is created from the value
  90 of ENABLED and BP-NUM.  In particular, if ENABLED is 't and
  91 BP-NUM is 5 the overlay string is be 'B5:' If ENABLED is false
  92 then the overlay string is 'b5:'. Breakpoint text properties are
  93 also attached to the icon via its display string."
  94   (let ((enabled-str)
  95         (buf (or opt-buf (current-buffer)))
  96         (bp-num-str
  97          (cond
  98           ((or (not bp-num) (not (numberp bp-num))) ":")
  99           ('t (format "%d:" bp-num))))
 100         (brkpt-icon)
 101         (bp-str)
 102         (help-string "mouse-1: enable/disable bkpt")
 103         )
 104     (with-current-buffer buf
 105       (unless realgud-bp-enabled-icon (realgud-set-bp-icons))
 106       (if enabled
 107           (progn
 108             (setq enabled-str "B")
 109             (setq brkpt-icon realgud-bp-enabled-icon)
 110             )
 111         (progn
 112           (setq enabled-str "b")
 113           (setq brkpt-icon realgud-bp-disabled-icon)
 114           ))
 115       ;; Create alternate display string and attach
 116       ;; properties it.
 117       (setq bp-str (concat enabled-str bp-num-str))
 118       (add-text-properties
 119        0 1 `(realgud-bptno ,bp-num enabled ,enabled) bp-str)
 120       (add-text-properties
 121        0 1 (list 'help-echo (format "%s %s" bp-str help-string))
 122        bp-str)
 123
 124       ;; Display breakpoint icon or display string.  If the window is
 125       ;; nil, the image doesn't get displayed, so make sure it is large
 126       ;; enough.
 127       (let ((window (get-buffer-window (current-buffer) 0)))
 128         (if window
 129             (set-window-margins window 2)
 130           ;; FIXME: This is all crap, but I don't know how to fix.
 131           (let ((buffer-save (window-buffer (selected-window))))
 132             (set-window-buffer (selected-window) (current-buffer))
 133             (set-window-margins (selected-window) 2)
 134             (set-window-buffer (selected-window) buffer-save))
 135           ))
 136       (realgud-bp-remove-icons pos)
 137       (if brkpt-icon
 138           (put-image brkpt-icon pos bp-str 'left-margin))
 139       )
 140     )
 141   )
 142
 143 (defun realgud-bp-del-icon (pos &optional opt-buf)
 144   "Delete breakpoint icon in the left margin at POS via a `put-image' overlay.
 145 The alternate string name for the image is created from the value
 146 of ENABLED and BP-NUM.  In particular, if ENABLED is 't and
 147 BP-NUM is 5 the overlay string is be 'B5:' If ENABLED is false
 148 then the overlay string is 'b5:'. Breakpoint text properties are
 149 also attached to the icon via its display string."
 150   (let ((buf (or opt-buf (current-buffer))))
 151     (with-current-buffer buf
 152       (realgud-bp-remove-icons pos)
 153     )
 154   )
 155 )
 156
 157 (defun realgud-bp-add-info (loc)
 158   "Record bp information for location LOC."
 159   (if (realgud-loc? loc)
 160       (let* ((marker (realgud-loc-marker loc))
 161              (bp-num (realgud-loc-num loc))
 162              )
 163         (realgud-bp-put-icon marker 't bp-num)
 164         )
 165     )
 166 )
 167
 168 (defun realgud-bp-del-info (loc)
 169   "Remove bp information for location LOC."
 170   (if (realgud-loc? loc)
 171       (let* ((marker (realgud-loc-marker loc))
 172              (bp-num (realgud-loc-num loc))
 173              )
 174         (realgud-bp-del-icon marker)
 175         )
 176     )
 177 )
 178
 179
 180 (provide-me "realgud-")