comparison lisp/emacs-lisp/re-builder.el @ 93198:eb3d659f5085

(reb-mode-common): Remove reference to bogus variable `reb-kill-buffer'; don't make hooks buffer-local, use the LOCAL arg of `add-hook'. (reb-blink-delay, reb-mode-hook, reb-re-syntax, reb-auto-match-limit): Remove spurious * from defcustom docstrings. (reb-next-match, reb-prev-match, reb-enter-subexp-mode): Fix typos in messages. (reb-mode-buffer-p): New function. (re-builder, reb-kill-buffer): Use `reb-mode-buffer-p'. Use `when'. (top, reb-show-subexp, reb-auto-update, reb-auto-update, reb-delete-overlays, reb-cook-regexp, reb-update-regexp, reb-update-overlays): Use `unless', `when'. (re-builder-unload-function): New function.

93197:212fa666680e

;;; Code:

;; On XEmacs, load the overlay compatibility library
(if (not (fboundp 'make-overlay))
    (require 'overlay))

;; User customizable variables
(defgroup re-builder nil
  "Options for the RE Builder."
  :group 'lisp
  :prefix "reb-")

(defcustom reb-blink-delay 0.5
  "*Seconds to blink cursor for next/previous match in RE Builder."
  :group 're-builder
  :type 'number)

(defcustom reb-mode-hook nil
  "*Hooks to run on entering RE Builder mode."
  :group 're-builder
  :type 'hook)

(defcustom reb-re-syntax 'read
  "*Syntax for the REs in the RE Builder.
Can either be `read', `string', `sregex', `lisp-re', `rx'."
  :group 're-builder
  :type '(choice (const :tag "Read syntax" read)
		 (const :tag "String syntax" string)
		 (const :tag "`sregex' syntax" sregex)
		 (const :tag "`lisp-re' syntax" lisp-re)
		 (const :tag "`rx' syntax" rx)))

(defcustom reb-auto-match-limit 200
  "*Positive integer limiting the matches for RE Builder auto updates.
Set it to nil if you don't want limits here."
  :group 're-builder
  :type '(restricted-sexp :match-alternatives
			  (integerp 'nil)))

  (setq	reb-mode-string  ""
	reb-valid-string ""
	mode-line-buffer-identification
	                 '(25 . ("%b" reb-mode-string reb-valid-string)))
  (reb-update-modestring)
  (make-local-variable 'after-change-functions)
  (add-hook 'after-change-functions
	    'reb-auto-update)
  ;; At least make the overlays go away if the buffer is killed
  (make-local-variable 'reb-kill-buffer)
  (add-hook 'kill-buffer-hook 'reb-kill-buffer)
  (reb-auto-update nil nil nil))

(defun reb-color-display-p ()
  "Return t if display is capable of displaying colors."
  (eq 'color

  (goto-char (+ 2 (point-min)))
  (cond ((reb-lisp-syntax-p)
         (reb-lisp-mode))
        (t (reb-mode))))

;;; This is to help people find this in Apropos.
;;;###autoload
(defalias 'regexp-builder 're-builder)

;;;###autoload
(defun re-builder ()
  "Construct a regexp interactively."
  (interactive)

  (if (and (string= (buffer-name) reb-buffer)
           (memq major-mode '(reb-mode reb-lisp-mode)))
      (message "Already in the RE Builder")
    (if reb-target-buffer
        (reb-delete-overlays))
    (setq reb-target-buffer (current-buffer)
          reb-target-window (selected-window)
          reb-window-config (current-window-configuration))
    (select-window (split-window (selected-window) (- (window-height) 4)))
    (switch-to-buffer (get-buffer-create reb-buffer))

  (interactive)

  (reb-assert-buffer-in-window)
  (with-selected-window reb-target-window
    (if (not (re-search-forward reb-regexp (point-max) t))
	(message "No more matches.")
      (reb-show-subexp
       (or (and reb-subexp-mode reb-subexp-displayed) 0)
       t))))

(defun reb-prev-match ()

      (if (re-search-backward reb-regexp (point-min) t)
          (reb-show-subexp
           (or (and reb-subexp-mode reb-subexp-displayed) 0)
           t)
        (goto-char p)
        (message "No more matches.")))))

(defun reb-toggle-case ()
  "Toggle case sensitivity of searches for RE Builder target buffer."
  (interactive)

  "Enter the subexpression mode in the RE Builder."
  (interactive)
  (setq reb-subexp-mode t)
  (reb-update-modestring)
  (use-local-map reb-subexp-mode-map)
  (message "`0'-`9' to display subexpressions  `q' to quit subexp mode."))

(defun reb-show-subexp (subexp &optional pause)
  "Visually show limit of subexpression SUBEXP of recent search.
On color displays this just puts point to the end of the expression as
the match should already be marked by an overlay.
On other displays jump to the beginning and the end of it.
If the optional PAUSE is non-nil then pause at the end in any case."
  (with-selected-window reb-target-window
    (if (not (reb-color-display-p))
	(progn (goto-char (match-beginning subexp))
	       (sit-for reb-blink-delay)))
    (goto-char (match-end subexp))
    (if (or (not (reb-color-display-p)) pause)
	(sit-for reb-blink-delay))))

(defun reb-quit-subexp-mode ()
  "Quit the subexpression mode in the RE Builder."
  (interactive)
  (setq reb-subexp-mode nil

optional fourth argument FORCE is non-nil."
  (let ((prev-valid reb-valid-string)
	(new-valid
	 (condition-case nil
	     (progn
	       (if (or (reb-update-regexp) force)
		   (progn
		     (reb-assert-buffer-in-window)
		     (reb-do-update)))
	       "")
	   (error " *invalid*"))))
    (setq reb-valid-string new-valid)
    (force-mode-line-update)

    ;; Through the caching of the re a change invalidating the syntax
    ;; for symbolic expressions will not delete the overlays so we
    ;; catch it here
    (if (and (reb-lisp-syntax-p)
	     (not (string= prev-valid new-valid))
	     (string= prev-valid ""))
	(reb-delete-overlays))))

(defun reb-delete-overlays ()
  "Delete all RE Builder overlays in the `reb-target-buffer' buffer."
  (if (buffer-live-p reb-target-buffer)
    (with-current-buffer reb-target-buffer
      (mapc 'delete-overlay reb-overlays)
      (setq reb-overlays nil))))

(defun reb-assert-buffer-in-window ()

  (reb-do-update reb-subexp-displayed))

(defun reb-kill-buffer ()
  "When the RE Builder buffer is killed make sure no overlays stay around."

  (if (member major-mode '(reb-mode reb-lisp-mode))
      (reb-delete-overlays)))


;; The next functions are the interface between the regexp and
;; its textual representation in the RE Builder buffer.
;; They are the only functions concerned with the actual syntax

		     (reb-empty-regexp)))))))

(defun reb-cook-regexp (re)
  "Return RE after processing it according to `reb-re-syntax'."
  (cond ((eq reb-re-syntax 'lisp-re)
	 (if (fboundp 'lre-compile-string)
	     (lre-compile-string (eval (car (read-from-string re))))))
	((eq reb-re-syntax 'sregex)
	 (apply 'sregex (eval (car (read-from-string re)))))
	((eq reb-re-syntax 'rx)
	 (rx-to-string (eval (car (read-from-string re)))))
	(t re)))

      (let ((oldre reb-regexp))
	(prog1
	    (not (string= oldre re))
	  (setq reb-regexp re)
	  ;; Only update the source re for the lisp formats
	  (if (reb-lisp-syntax-p)
	      (setq reb-regexp-src re-src)))))))


;; And now the real core of the whole thing
(defun reb-count-subexps (re)
  "Return number of sub-expressions in the regexp RE."

      (goto-char (point-min))
      (while (and (not (eobp))
		  (re-search-forward re (point-max) t)
		  (or (not reb-auto-match-limit)
		      (< matches reb-auto-match-limit)))
	(if (= 0 (length (match-string 0)))
	    (unless (eobp)
	      (forward-char 1)))
	(let ((i 0)
	      suffix max-suffix)
	  (setq matches (1+ matches))
	  (while (<= i subexps)
	    (if (and (or (not subexp) (= subexp i))
		     (match-beginning i))
		(let ((overlay (make-overlay (match-beginning i)
					     (match-end i)))
		      ;; When we have exceeded the number of provided faces,
		      ;; cycle thru them where `max-suffix' denotes the maximum
		      ;; suffix for `reb-match-*' that has been defined and
		      ;; `suffix' the suffix calculated for the current match.
		      (face
		       (cond
			(max-suffix
			 (if (= suffix max-suffix)
			     (setq suffix 1)
			   (setq suffix (1+ suffix)))
			 (intern-soft (format "reb-match-%d" suffix)))
			((intern-soft (format "reb-match-%d" i)))
			((setq max-suffix (1- i))
			 (setq suffix 1)
			 ;; `reb-match-1' must exist.
			 'reb-match-1))))
		  (unless firstmatch (setq firstmatch (match-data)))
		  (setq reb-overlays (cons overlay reb-overlays)
			submatches (1+ submatches))
		  (overlay-put overlay 'face face)
		  (overlay-put overlay 'priority i)))
	    (setq i (1+ i))))))
    (let ((count (if subexp submatches matches)))
      (message "%s %smatch%s%s"
	       (if (= 0 count) "No" (int-to-string count))
	       (if subexp "subexpression " "")
	       (if (= 1 count) "" "es")
	       (if (and reb-auto-match-limit
			(= reb-auto-match-limit count))
		   " (limit reached)" "")))
    (if firstmatch
	(progn (store-match-data firstmatch)
	       (reb-show-subexp (or subexp 0))))))

(provide 're-builder)

;;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7
;;; re-builder.el ends here

93198:eb3d659f5085

;;; Code:

;; On XEmacs, load the overlay compatibility library
(unless (fboundp 'make-overlay)
  (require 'overlay))

;; User customizable variables
(defgroup re-builder nil
  "Options for the RE Builder."
  :group 'lisp
  :prefix "reb-")

(defcustom reb-blink-delay 0.5
  "Seconds to blink cursor for next/previous match in RE Builder."
  :group 're-builder
  :type 'number)

(defcustom reb-mode-hook nil
  "Hooks to run on entering RE Builder mode."
  :group 're-builder
  :type 'hook)

(defcustom reb-re-syntax 'read
  "Syntax for the REs in the RE Builder.
Can either be `read', `string', `sregex', `lisp-re', `rx'."
  :group 're-builder
  :type '(choice (const :tag "Read syntax" read)
		 (const :tag "String syntax" string)
		 (const :tag "`sregex' syntax" sregex)
		 (const :tag "`lisp-re' syntax" lisp-re)
		 (const :tag "`rx' syntax" rx)))

(defcustom reb-auto-match-limit 200
  "Positive integer limiting the matches for RE Builder auto updates.
Set it to nil if you don't want limits here."
  :group 're-builder
  :type '(restricted-sexp :match-alternatives
			  (integerp 'nil)))

  (setq	reb-mode-string  ""
	reb-valid-string ""
	mode-line-buffer-identification
	                 '(25 . ("%b" reb-mode-string reb-valid-string)))
  (reb-update-modestring)
  (add-hook 'after-change-functions 'reb-auto-update nil t)
  ;; At least make the overlays go away if the buffer is killed
  (add-hook 'kill-buffer-hook 'reb-kill-buffer nil t)
  (reb-auto-update nil nil nil))

(defun reb-color-display-p ()
  "Return t if display is capable of displaying colors."
  (eq 'color

  (goto-char (+ 2 (point-min)))
  (cond ((reb-lisp-syntax-p)
         (reb-lisp-mode))
        (t (reb-mode))))

(defun reb-mode-buffer-p ()
  "Return non-nil if the current buffer is a RE Builder buffer."
  (memq major-mode '(reb-mode reb-lisp-mode)))

;;; This is to help people find this in Apropos.
;;;###autoload
(defalias 'regexp-builder 're-builder)

;;;###autoload
(defun re-builder ()
  "Construct a regexp interactively."
  (interactive)

  (if (and (string= (buffer-name) reb-buffer)
	   (reb-mode-buffer-p))
      (message "Already in the RE Builder")
    (when reb-target-buffer
      (reb-delete-overlays))
    (setq reb-target-buffer (current-buffer)
          reb-target-window (selected-window)
          reb-window-config (current-window-configuration))
    (select-window (split-window (selected-window) (- (window-height) 4)))
    (switch-to-buffer (get-buffer-create reb-buffer))

  (interactive)

  (reb-assert-buffer-in-window)
  (with-selected-window reb-target-window
    (if (not (re-search-forward reb-regexp (point-max) t))
	(message "No more matches")
      (reb-show-subexp
       (or (and reb-subexp-mode reb-subexp-displayed) 0)
       t))))

(defun reb-prev-match ()

      (if (re-search-backward reb-regexp (point-min) t)
          (reb-show-subexp
           (or (and reb-subexp-mode reb-subexp-displayed) 0)
           t)
        (goto-char p)
        (message "No more matches")))))

(defun reb-toggle-case ()
  "Toggle case sensitivity of searches for RE Builder target buffer."
  (interactive)

  "Enter the subexpression mode in the RE Builder."
  (interactive)
  (setq reb-subexp-mode t)
  (reb-update-modestring)
  (use-local-map reb-subexp-mode-map)
  (message "`0'-`9' to display subexpressions  `q' to quit subexp mode"))

(defun reb-show-subexp (subexp &optional pause)
  "Visually show limit of subexpression SUBEXP of recent search.
On color displays this just puts point to the end of the expression as
the match should already be marked by an overlay.
On other displays jump to the beginning and the end of it.
If the optional PAUSE is non-nil then pause at the end in any case."
  (with-selected-window reb-target-window
    (unless (reb-color-display-p)
      (goto-char (match-beginning subexp))
      (sit-for reb-blink-delay))
    (goto-char (match-end subexp))
    (when (or (not (reb-color-display-p)) pause)
      (sit-for reb-blink-delay))))

(defun reb-quit-subexp-mode ()
  "Quit the subexpression mode in the RE Builder."
  (interactive)
  (setq reb-subexp-mode nil

optional fourth argument FORCE is non-nil."
  (let ((prev-valid reb-valid-string)
	(new-valid
	 (condition-case nil
	     (progn
	       (when (or (reb-update-regexp) force)
		 (reb-assert-buffer-in-window)
		 (reb-do-update))
	       "")
	   (error " *invalid*"))))
    (setq reb-valid-string new-valid)
    (force-mode-line-update)

    ;; Through the caching of the re a change invalidating the syntax
    ;; for symbolic expressions will not delete the overlays so we
    ;; catch it here
    (when (and (reb-lisp-syntax-p)
	       (not (string= prev-valid new-valid))
	       (string= prev-valid ""))
      (reb-delete-overlays))))

(defun reb-delete-overlays ()
  "Delete all RE Builder overlays in the `reb-target-buffer' buffer."
  (when (buffer-live-p reb-target-buffer)
    (with-current-buffer reb-target-buffer
      (mapc 'delete-overlay reb-overlays)
      (setq reb-overlays nil))))

(defun reb-assert-buffer-in-window ()

  (reb-do-update reb-subexp-displayed))

(defun reb-kill-buffer ()
  "When the RE Builder buffer is killed make sure no overlays stay around."

  (when (reb-mode-buffer-p)
    (reb-delete-overlays)))


;; The next functions are the interface between the regexp and
;; its textual representation in the RE Builder buffer.
;; They are the only functions concerned with the actual syntax

		     (reb-empty-regexp)))))))

(defun reb-cook-regexp (re)
  "Return RE after processing it according to `reb-re-syntax'."
  (cond ((eq reb-re-syntax 'lisp-re)
	 (when (fboundp 'lre-compile-string)
	   (lre-compile-string (eval (car (read-from-string re))))))
	((eq reb-re-syntax 'sregex)
	 (apply 'sregex (eval (car (read-from-string re)))))
	((eq reb-re-syntax 'rx)
	 (rx-to-string (eval (car (read-from-string re)))))
	(t re)))

      (let ((oldre reb-regexp))
	(prog1
	    (not (string= oldre re))
	  (setq reb-regexp re)
	  ;; Only update the source re for the lisp formats
	  (when (reb-lisp-syntax-p)
	    (setq reb-regexp-src re-src)))))))


;; And now the real core of the whole thing
(defun reb-count-subexps (re)
  "Return number of sub-expressions in the regexp RE."

      (goto-char (point-min))
      (while (and (not (eobp))
		  (re-search-forward re (point-max) t)
		  (or (not reb-auto-match-limit)
		      (< matches reb-auto-match-limit)))
	(when (and (= 0 (length (match-string 0)))
		   (not (eobp)))
	  (forward-char 1))
	(let ((i 0)
	      suffix max-suffix)
	  (setq matches (1+ matches))
	  (while (<= i subexps)
	    (when (and (or (not subexp) (= subexp i))
		       (match-beginning i))
	      (let ((overlay (make-overlay (match-beginning i)
					   (match-end i)))
		    ;; When we have exceeded the number of provided faces,
		    ;; cycle thru them where `max-suffix' denotes the maximum
		    ;; suffix for `reb-match-*' that has been defined and
		    ;; `suffix' the suffix calculated for the current match.
		    (face
		     (cond
		       (max-suffix
			(if (= suffix max-suffix)
			    (setq suffix 1)
			  (setq suffix (1+ suffix)))
			(intern-soft (format "reb-match-%d" suffix)))
		       ((intern-soft (format "reb-match-%d" i)))
		       ((setq max-suffix (1- i))
			(setq suffix 1)
			;; `reb-match-1' must exist.
			'reb-match-1))))
		(unless firstmatch (setq firstmatch (match-data)))
		(setq reb-overlays (cons overlay reb-overlays)
		      submatches (1+ submatches))
		(overlay-put overlay 'face face)
		(overlay-put overlay 'priority i)))
	    (setq i (1+ i))))))
    (let ((count (if subexp submatches matches)))
      (message "%s %smatch%s%s"
	       (if (= 0 count) "No" (int-to-string count))
	       (if subexp "subexpression " "")
	       (if (= 1 count) "" "es")
	       (if (and reb-auto-match-limit
			(= reb-auto-match-limit count))
		   " (limit reached)" "")))
    (when firstmatch
      (store-match-data firstmatch)
      (reb-show-subexp (or subexp 0)))))

;; The End
(defun re-builder-unload-function ()
  "Unload the RE Builder library."
  (when (buffer-live-p (get-buffer reb-buffer))
    (with-current-buffer reb-buffer
      (remove-hook 'after-change-functions 'reb-auto-update t)
      (remove-hook 'kill-buffer-hook 'reb-kill-buffer t)
      (when (reb-mode-buffer-p)
	(reb-delete-overlays)
	(funcall default-major-mode))))
  ;; continue standard unloading
  nil)

(provide 're-builder)

;;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7
;;; re-builder.el ends here