;; Copyright (C) 2010, 2012-2015, 2017-2018 Free Software Foundation, Inc ;; Author: Rocky Bernstein ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;; Code associated with breakpoints (require 'image) (require 'load-relative) (require-relative-list '("loc" "bp-image-data") "realgud-") (defun realgud-bp-remove-icons (&optional begin-pos end-pos bpnum) "Remove breakpoint icons (overlays) in BEGIN-POS .. END-POS. The default value for BEGIN-POS is `point'. The default value for END-POS is BEGIN-POS. When BPNUM is non-nil, only remove overlays with that breakpoint number. The way we determine if an overlay is ours is by inspecting the overlay for a realgud property." (interactive "r") (setq begin-pos (or begin-pos (point)) end-pos (or end-pos begin-pos)) (dolist (overlay (overlays-in begin-pos end-pos)) (when (overlay-get overlay 'realgud) (when (or (null bpnum) (equal bpnum (overlay-get overlay 'realgud-bp-num))) (delete-overlay overlay))))) (defvar realgud-bp-enabled-icon nil "Icon for an enabled breakpoint in display margin.") (defvar realgud-bp-disabled-icon nil "Icon for a disabled breakpoint in display margin.") (defun realgud-set-bp-icons() "Load breakpoint icons, if needed." (when (display-images-p) (unless realgud-bp-enabled-icon (setq realgud-bp-enabled-icon (find-image `((:type xpm :data ,realgud-bp-xpm-data :ascent 100 :pointer hand) (:type svg :data ,realgud-bp-enabled-svg-data :ascent 100 :pointer hand) (:type tiff :data ,realgud-bp-enabled-tiff-data :ascent 100 :pointer hand) (:type pbm :data ,realgud-bp-enabled-pbm-data :ascent 100 :pointer hand))))) (unless realgud-bp-disabled-icon (setq realgud-bp-disabled-icon (find-image `((:type xpm :data ,realgud-bp-xpm-data :conversion disabled ; different than 'enabled' :ascent 100 :pointer hand) (:type svg :data ,realgud-bp-disabled-svg-data :ascent 100 :pointer hand) (:type tiff :data ,realgud-bp-disabled-tiff-data :ascent 100 :pointer hand) (:type pbm :data ,realgud-bp-disabled-pbm-data :ascent 100 :pointer hand) (:type svg :data ,realgud-bp-disabled-svg-data :ascent 100 :pointer hand))))))) (declare-function define-fringe-bitmap "fringe.c" (bitmap bits &optional height width align)) (when (display-images-p) ;; Taken from gdb-mi (define-fringe-bitmap 'realgud-bp-filled "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") (define-fringe-bitmap 'realgud-bp-hollow "\x3c\x42\x81\x81\x81\x81\x42\x3c")) (defgroup realgud-bp nil "RealGUD breakpoints UI" :group 'realgud :prefix 'realgud-bp-) (defface realgud-bp-enabled-face '((t :foreground "red" :weight bold)) "Face for enabled breakpoints (in the fringe or margin)." :group 'realgud-bp) (defface realgud-bp-disabled-face '((t :foreground "grey" :weight bold)) "Face for disabled breakpoints (in the fringe or margin). Only used in text terminals: fringe icons always use `realgud-bp-enabled-face'." :group 'realgud-bp) (defface realgud-bp-line-enabled-face '((t (:box (:color "red")))) "Face for lines with enabled breakpoints." :group 'realgud-bp) (defface realgud-bp-line-disabled-face '((t (:box (:color "grey")))) "Face for lines with disabled breakpoints." :group 'realgud-bp) (defcustom realgud-bp-fringe-indicator-style '(filled-rectangle . hollow-rectangle) "Which fringe icon to use for breakpoints." :type '(choice (const :tag "Disc" (realgud-bp-filled . realgud-bp-hollow)) (const :tag "Square" (filled-square . hollow-square)) (const :tag "Rectangle" (filled-rectangle . hollow-rectangle))) :group 'realgud-bp) (defcustom realgud-bp-use-fringe t "Whether to use the fringe to display breakpoints. If nil, use margins instead." :type '(boolean) :group 'realgud-bp) (defun realgud-bp--fringe-width () "Compute width of left fringe." (let ((window (get-buffer-window (current-buffer)))) (or left-fringe-width (and window (car (window-fringes window))) 0))) (defun realgud-bp-add-fringe-icon (overlay icon) "Add a fringe icon to OVERLAY. ICON is a symbol registered with `define-fringe-bitmap'." ;; Ensure that the fringe is wide enough (unless (>= (realgud-bp--fringe-width) 8) (set-fringe-mode `(8 . ,right-fringe-width))) ;; Add the fringe icon (let* ((fringe-spec `(left-fringe ,icon realgud-bp-enabled-face))) (overlay-put overlay 'before-string (propertize "x" 'display fringe-spec)))) (defun realgud-bp-add-margin-indicator (overlay text image face) "Add a margin breakpoint indicator to OVERLAY. TEXT is a string, IMAGE an IMAGE spec or nil; TEXT gets highlighted with FACE." ;; Ensure that the margin is large enough (Taken from gdb-mi) (when (< left-margin-width 2) (save-current-buffer (setq left-margin-width 2) (let ((window (get-buffer-window (current-buffer) 0))) (if window (set-window-margins window left-margin-width right-margin-width))))) ;; Add the margin string (let* ((indicator (or image (propertize text 'face face))) (spec `((margin left-margin) ,indicator))) (overlay-put overlay 'before-string (propertize text 'display spec)))) (defun realgud-bp-put-icon (pos enable? bp-num &optional buf) "Add a breakpoint icon at POS according to breakpoint-display-style. Use the fringe if available, and the margin otherwise. Record breakpoint status ENABLE? and breakpoint number BP-NUM in overlay. BUF is the buffer that POS refers to; it defaults to the current buffer." (let* ((bp-text) (bp-face) (line-face) (margin-icon) (fringe-icon)) (realgud-set-bp-icons) (if enable? (setq bp-text "B" bp-face 'realgud-bp-enabled-face line-face 'realgud-bp-line-enabled-face margin-icon realgud-bp-enabled-icon fringe-icon (car realgud-bp-fringe-indicator-style)) (setq bp-text "b" bp-face 'realgud-bp-disabled-face line-face 'realgud-bp-line-disabled-face margin-icon realgud-bp-disabled-icon fringe-icon (cdr realgud-bp-fringe-indicator-style))) (let ((help-echo (format "%s%s: mouse-1 to clear" bp-text bp-num))) (setq bp-text (propertize bp-text 'help-echo help-echo))) (with-current-buffer (or buf (current-buffer)) (realgud-bp-remove-icons pos (1+ pos) bp-num) (let* ((eol (save-excursion (goto-char pos) (point-at-eol))) (ov (make-overlay pos (1+ eol) (current-buffer) t nil))) (if (and realgud-bp-use-fringe (display-images-p)) (realgud-bp-add-fringe-icon ov fringe-icon) (realgud-bp-add-margin-indicator ov bp-text margin-icon bp-face)) (overlay-put ov 'face line-face) (overlay-put ov 'realgud t) (overlay-put ov 'realgud-bp-num bp-num) (overlay-put ov 'realgud-bp-enabled enable?))))) (defun realgud-bp-del-icon (pos &optional buf bpnum) "Delete breakpoint icon at POS. BUF is the buffer which pos refers to (default: current buffer). If BPNUM is non-nil, only remove overlays maching that breakpoint number." (with-current-buffer (or buf (current-buffer)) (realgud-bp-remove-icons pos (1+ pos) bpnum))) (defun realgud-bp-add-info (loc) "Record bp information for location LOC." (if (realgud-loc? loc) (let* ((marker (realgud-loc-marker loc)) (bp-num (realgud-loc-num loc))) (realgud-bp-put-icon marker t bp-num)))) (defun realgud-bp-del-info (loc) "Remove bp information for location LOC." (if (realgud-loc? loc) (let* ((marker (realgud-loc-marker loc)) (bp-num (realgud-loc-num loc))) (realgud-bp-del-icon marker (current-buffer) bp-num)))) (defun realgud-bp-enable-disable-info (bp-num enable? loc buf) "Enable or disable bp with BP-NUM at location LOC in BUF." (if (realgud-loc? loc) (let* ((marker (realgud-loc-marker loc)) (bp-num-check (realgud-loc-num loc))) (if (eq bp-num bp-num-check) (realgud-bp-put-icon marker enable? bp-num buf) (message "Internal error - bp number found %s doesn't match requested %s" bp-num-check bp-num) )))) (provide-me "realgud-")