emacs: lisp/whitespace.el comparison

comparison lisp/whitespace.el @ 92372:0418e6ff8eb2

New version 9.3.

author	Vinicius Jose Latorre <viniciusjl@ig.com.br>
date	Sat, 01 Mar 2008 19:00:24 +0000
parents	13eacee3408e
children	7b3262e9986b

comparison

equal deleted inserted replaced

-:d442efe2d5a7
+:0418e6ff8eb2
 ;;   Free Software Foundation, Inc.
 ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
 ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
 ;; Keywords: data, wp
-;; Version: 9.2
+;; Version: 9.3
 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
 ;; This file is part of GNU Emacs.
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;;
 ;;         M-x global-whitespace-mode RET
 ;;
 ;; There are also the following useful commands:
 ;;
+;; `whitespace-report'
+;;    Report some blank problems in buffer.
+;;
+;; `whitespace-report-region'
+;;    Report some blank problems in a region.
+;;
 ;; `whitespace-cleanup'
 ;;    Cleanup some blank problems in all buffer or at region.
 ;;
 ;; `whitespace-cleanup-region'
 ;;    Cleanup some blank problems at region.
-;;
-;; `whitespace-buffer'
-;;    Turn on `whitespace-mode' forcing some settings.
 ;;
 ;; The problems, which are cleaned up, are:
 ;;
 ;; 1. empty lines at beginning of buffer.
 ;; 2. empty lines at end of buffer.
 ;;    If `whitespace-chars' includes the value `space-before-tab',
 ;;    replace SPACEs by TABs.
 ;;
 ;; 5. SPACEs or TABs at end of line.
 ;;    If `whitespace-chars' includes the value `trailing', remove all
-;;    SPACEs or TABs at end of line."
+;;    SPACEs or TABs at end of line.
 ;;
 ;; 6. 8 or more SPACEs after TAB.
 ;;    If `whitespace-chars' includes the value `space-after-tab',
 ;;    replace SPACEs by TABs.
 ;;
 ;;
 ;; `whitespace-global-modes'	Modes for which global
 ;;				`whitespace-mode' is automagically
 ;;				turned on.
 ;;
+;; `whitespace-action'		Specify which action is taken when a
+;;				buffer is visited, killed or written.
+;;
 ;;
 ;; Acknowledgements
 ;; ----------------
+;;
+;; Thanks to Eric Cooper <ecc@cmu.edu> for the suggestion to have hook actions
+;; when buffer is written or killed as the original whitespace package had.
 ;;
 ;; Thanks to nschum (EmacsWiki) for the idea about highlight "long"
 ;; lines tail.  See EightyColumnRule (EmacsWiki).
 ;;
 ;; Thanks to Juri Linkov <juri@jurta.org> for suggesting:
 :group 'whitespace)
 ;; Hacked from `visible-whitespace-mappings' in visws.el
 (defcustom whitespace-display-mappings
-;; Due to limitations of glyph representation, the char code can not
-;; be above ?\x1FFFF.  Probably, this will be fixed after Emacs
-;; unicode merging.
 '(
 (?\     [?\xB7]       [?.])		; space - centered dot
 (?\xA0  [?\xA4]       [?_])		; hard space - currency
 (?\x8A0 [?\x8A4]      [?_])		; hard space - currency
 (?\x920 [?\x924]      [?_])		; hard space - currency
 (?\xE20 [?\xE24]      [?_])		; hard space - currency
 (?\xF20 [?\xF24]      [?_])		; hard space - currency
 ;; NEWLINE is displayed using the face `whitespace-newline'
-(?\n    [?$ ?\n])			; end-of-line - dollar sign
+(?\n    [?\u21B5 ?\n] [?$ ?\n])		; end-of-line - downwards arrow
-;; (?\n    [?\u21B5 ?\n] [?$ ?\n])	; end-of-line - downwards arrow
+;; (?\n    [?$ ?\n])		; end-of-line - dollar sign
 ;; (?\n    [?\xB6 ?\n]   [?$ ?\n])	; end-of-line - pilcrow
 ;; (?\n    [?\x8AF ?\n]  [?$ ?\n])	; end-of-line - overscore
 ;; (?\n    [?\x8AC ?\n]  [?$ ?\n])	; end-of-line - negation
 ;; (?\n    [?\x8B0 ?\n]  [?$ ?\n])	; end-of-line - grade
 ;;
 (c-mode c++-mode)
 means that `whitespace-mode' is turned on for buffers in C and
 C++ modes only."
-:type '(choice (const :tag "None" nil)
+:type '(choice :tag "Global Modes"
+		 (const :tag "None" nil)
 		 (const :tag "All" t)
 		 (set :menu-tag "Mode Specific" :tag "Modes"
 		      :value (not)
 		      (const :tag "Except" not)
 		      (repeat :inline t
 			      (symbol :tag "Mode"))))
+:group 'whitespace)
+(defcustom whitespace-action nil
+"*Specify which action is taken when a buffer is visited, killed or written.
+It's a list containing some or all of the following values:
+nil			no action is taken.
+cleanup		cleanup any bogus whitespace always when local
+			whitespace is turned on.
+			See `whitespace-cleanup' and
+			`whitespace-cleanup-region'.
+report-on-bogus	report if there is any bogus whitespace always
+			when local whitespace is turned on.
+auto-cleanup		cleanup any bogus whitespace when buffer is
+			written or killed.
+			See `whitespace-cleanup' and
+			`whitespace-cleanup-region'.
+abort-on-bogus	abort if there is any bogus whitespace and the
+			buffer is written or killed.
+Any other value is treated as nil."
+:type '(choice :tag "Actions"
+		 (const :tag "None" nil)
+		 (repeat :tag "Action List"
+		  (choice :tag "Action"
+			  (const :tag "Cleanup When On" cleanup)
+			  (const :tag "Report On Bogus" report-on-bogus)
+			  (const :tag "Auto Cleanup" auto-cleanup)
+			  (const :tag "Abort On Bogus" abort-on-bogus))))
 :group 'whitespace)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; User commands - Local mode
 :group      'whitespace
 (cond
 (noninteractive			; running a batch job
 (setq whitespace-mode nil))
 (whitespace-mode			; whitespace-mode on
-(whitespace-turn-on))
+(whitespace-turn-on)
+(whitespace-action-when-on))
 (t					; whitespace-mode off
 (whitespace-turn-off))))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (cond
 (noninteractive			; running a batch job
 (setq global-whitespace-mode nil))
 (global-whitespace-mode		; global-whitespace-mode on
 (save-excursion
-(add-hook 'find-file-hook 'whitespace-turn-on-if-enabled t)
+(add-hook 'find-file-hook 'whitespace-turn-on-if-enabled)
 (dolist (buffer (buffer-list))	; adjust all local mode
 	(set-buffer buffer)
 	(unless whitespace-mode
 	  (whitespace-turn-on-if-enabled)))))
 (t					; global-whitespace-mode off
 	(when (memq 'indentation whitespace-chars)
 	  (goto-char rstart)
 	  (while (re-search-forward
 		  whitespace-indentation-regexp rend t)
 	    (setq tmp (current-indentation))
+	    (goto-char (match-beginning 0))
 	    (delete-horizontal-space)
 	    (unless (eolp)
 	      (indent-to tmp))))
 	;; problem 3: SPACEs or TABs at eol
 	;; action: remove all SPACEs or TABs at eol
 	(when (memq 'trailing whitespace-chars)
-	  (let ((regexp (concat "\\(\\(" whitespace-trailing-regexp
+	  (let ((regexp (whitespace-trailing-regexp)))
-				"\\)+\\)$")))
 	    (goto-char rstart)
 	    (while (re-search-forward regexp rend t)
 	      (delete-region (match-beginning 1) (match-end 1)))))
 	;; problem 4: 8 or more SPACEs after TAB
 	;; action: replace 8 or more SPACEs by TABs
 			 (- scol (% scol 8))) ; prev start col
 		      8)))))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; User command - old whitespace compatibility
+;;;; User command - report
+(defun whitespace-trailing-regexp ()
+"Make the `whitespace-trailing-regexp' regexp."
+(concat "\\(\\(" whitespace-trailing-regexp "\\)+\\)$"))
+(defconst whitespace-report-list
+(list
+(cons 'empty            whitespace-empty-at-bob-regexp)
+(cons 'empty            whitespace-empty-at-eob-regexp)
+(cons 'indentation      whitespace-indentation-regexp)
+(cons 'space-before-tab whitespace-space-before-tab-regexp)
+(cons 'trailing         (whitespace-trailing-regexp))
+(cons 'space-after-tab  whitespace-space-after-tab-regexp)
+)
+"List of whitespace bogus symbol and corresponding regexp.")
+(defconst whitespace-report-text
+"\
+Whitespace Report
+Current Setting                Whitespace Problem
+empty             []     []  empty lines at beginning of buffer.
+empty             []     []  empty lines at end of buffer.
+indentation       []     []  8 or more SPACEs at beginning of line.
+space-before-tab  []     []  SPACEs before TAB.
+trailing          []     []  SPACEs or TABs at end of line.
+space-after-tab   []     []  8 or more SPACEs after TAB.\n\n"
+"Text for whitespace bogus report.")
+(defconst whitespace-report-buffer-name "*Whitespace Report*"
+"The buffer name for whitespace bogus report.")
 ;;;###autoload
-(defun whitespace-buffer ()
+(defun whitespace-report (&optional force report-if-bogus)
-"Turn on `whitespace-mode' forcing some settings.
+"Report some whitespace problems in buffer.
-It forces `whitespace-style' to have `color'.
+Return nil if there is no whitespace problem; otherwise, return
+non-nil.
-It also forces `whitespace-chars' to have:
+If FORCE is non-nil or \\[universal-argument] was pressed just before calling
-trailing
+`whitespace-report' interactively, it forces `whitespace-chars' to
+have:
+empty
 indentation
 space-before-tab
-empty
+trailing
 space-after-tab
-So, it is possible to visualize the following problems:
+If REPORT-IF-BOGUS is non-nil, it reports only when there are any
+whitespace problems in buffer.
+Report if some of the following whitespace problems exist:
 empty		1. empty lines at beginning of buffer.
 empty		2. empty lines at end of buffer.
 indentation		3. 8 or more SPACEs at beginning of line.
 space-before-tab	4. SPACEs before TAB.
 space-after-tab	6. 8 or more SPACEs after TAB.
 See `whitespace-chars' and `whitespace-style' for documentation.
 See also `whitespace-cleanup' and `whitespace-cleanup-region' for
 cleaning up these problems."
-(interactive)
+(interactive (list current-prefix-arg))
-(whitespace-mode 0)			; assure is off
+(whitespace-report-region (point-min) (point-max)
-;; keep original values
+			    force report-if-bogus))
-(let ((whitespace-style (copy-sequence whitespace-style))
-	(whitespace-chars (copy-sequence whitespace-chars)))
-;; adjust options for whitespace bogus blanks
+;;;###autoload
-(add-to-list 'whitespace-style 'color)
+(defun whitespace-report-region (start end &optional force report-if-bogus)
-(mapc #'(lambda (option)
+"Report some whitespace problems in a region.
-	      (add-to-list 'whitespace-chars option))
-	  '(trailing
+Return nil if there is no whitespace problem; otherwise, return
-	    indentation
+non-nil.
-	    space-before-tab
-	    empty
+If FORCE is non-nil or \\[universal-argument] was pressed just before calling
-	    space-after-tab))
+`whitespace-report-region' interactively, it forces `whitespace-chars'
-(whitespace-mode 1)))		; turn on
+to have:
+empty
+indentation
+space-before-tab
+trailing
+space-after-tab
+If REPORT-IF-BOGUS is non-nil, it reports only when there are any
+whitespace problems in buffer.
+Report if some of the following whitespace problems exist:
+empty		1. empty lines at beginning of buffer.
+empty		2. empty lines at end of buffer.
+indentation		3. 8 or more SPACEs at beginning of line.
+space-before-tab	4. SPACEs before TAB.
+trailing		5. SPACEs or TABs at end of line.
+space-after-tab	6. 8 or more SPACEs after TAB.
+See `whitespace-chars' and `whitespace-style' for documentation.
+See also `whitespace-cleanup' and `whitespace-cleanup-region' for
+cleaning up these problems."
+(interactive "r")
+(setq force (or current-prefix-arg force))
+(save-excursion
+(save-match-data
+(let* (has-bogus
+	     (rstart (min start end))
+	     (rend   (max start end))
+	     (bogus-list (mapcar
+			  #'(lambda (option)
+			      (when force
+				(add-to-list 'whitespace-chars (car option)))
+			      (goto-char rstart)
+			      (and (re-search-forward (cdr option) rend t)
+				   (setq has-bogus t)))
+			  whitespace-report-list)))
+	(when (if report-if-bogus has-bogus t)
+	  (with-current-buffer (get-buffer-create
+				whitespace-report-buffer-name)
+	    (erase-buffer)
+	    (insert whitespace-report-text)
+	    (goto-char (point-min))
+	    (forward-line 3)
+	    (dolist (option whitespace-report-list)
+	      (forward-line 1)
+	      (whitespace-mark-x 22 (memq (car option) whitespace-chars))
+	      (whitespace-mark-x 7 (car bogus-list))
+	      (setq bogus-list (cdr bogus-list)))
+	    (when has-bogus
+	      (goto-char (point-max))
+	      (insert "   Type `M-x whitespace-cleanup'"
+		      " to cleanup the buffer.\n\n")
+	      (insert "   Type `M-x whitespace-cleanup-region'"
+		      " to cleanup a region.\n\n"))
+	    (whitespace-display-window (current-buffer))))
+	has-bogus))))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; Internal functions
 (defconst whitespace-help-buffer-name "*Whitespace Toggle Options*"
 "The buffer name for whitespace toggle options.")
+(defun whitespace-mark-x (nchars condition)
+"Insert the mark ('X' or ' ') after NCHARS depending on CONDITION."
+(forward-char nchars)
+(insert (if condition "X" " ")))
 (defun whitespace-insert-option-mark (the-list the-value)
 "Insert the option mark ('X' or ' ') in toggle options buffer."
 (forward-line 1)
 (dolist (sym  the-list)
 (forward-line 1)
-(forward-char 2)
+(whitespace-mark-x 2 (memq sym the-value))))
-(insert (if (memq sym the-value) "X" " "))))
 (defun whitespace-help-on (chars style)
 "Display the whitespace toggle options."
 (unless (get-buffer whitespace-help-buffer-name)
 	(goto-char (point-min))
 	(whitespace-insert-option-mark
 	 whitespace-chars-value-list chars)
 	(whitespace-insert-option-mark
 	 whitespace-style-value-list style)
-	(goto-char (point-min))
+	(whitespace-display-window buffer)))))
-	(set-buffer-modified-p nil)
-	(let ((size (- (window-height)
-		       (max window-min-height
+(defun whitespace-display-window (buffer)
-			    (1+ (count-lines (point-min)
+"Display BUFFER in a new window."
-					     (point-max)))))))
+(goto-char (point-min))
-	  (when (<= size 0)
+(set-buffer-modified-p nil)
-	    (kill-buffer buffer)
+(let ((size (- (window-height)
-	    (error "Frame height is too small; \
+		 (max window-min-height
+		      (1+ (count-lines (point-min)
+				       (point-max)))))))
+(when (<= size 0)
+(kill-buffer buffer)
+(error "Frame height is too small; \
 can't split window to display whitespace toggle options"))
-	  (set-window-buffer (split-window nil size) buffer))))))
+(set-window-buffer (split-window nil size) buffer)))
 (defun whitespace-help-off ()
 "Remove the buffer and window of the whitespace toggle options."
 (let ((buffer (get-buffer whitespace-help-buffer-name)))
 the-list)
 (defun whitespace-turn-on ()
 "Turn on whitespace visualization."
+(whitespace-add-local-hook)
 (setq whitespace-active-style (if (listp whitespace-style)
 				    whitespace-style
 				  (list whitespace-style)))
 (setq whitespace-active-chars (if (listp whitespace-chars)
 				    whitespace-chars
 (whitespace-display-char-on)))
 (defun whitespace-turn-off ()
 "Turn off whitespace visualization."
+(whitespace-remove-local-hook)
 (when (memq 'color whitespace-active-style)
 (whitespace-color-off))
 (when (memq 'mark  whitespace-active-style)
 (whitespace-display-char-off)))
 (when (memq 'trailing whitespace-active-chars)
 (font-lock-add-keywords
 nil
 (list
 	;; Show trailing blanks
-	(list (concat "\\(\\(" whitespace-trailing-regexp "\\)+\\)$")
+	(list (whitespace-trailing-regexp) 1 whitespace-trailing t))
-	      1 whitespace-trailing t))
 t))
 (when (or (memq 'lines      whitespace-active-chars)
 	      (memq 'lines-tail whitespace-active-chars))
 (font-lock-add-keywords
 nil
 	    ;; Only insert face bits on NEWLINE char mapping to avoid
 	    ;; obstruction of other faces like TABs and (HARD) SPACEs
 	    ;; faces, font-lock faces, etc.
 	    (when (memq 'color whitespace-active-style)
 	      (dotimes (i (length vec))
-		;; Due to limitations of glyph representation, the char
-		;; code can not be above ?\x1FFFF.  Probably, this will
-		;; be fixed after Emacs unicode merging.
 		(or (eq (aref vec i) ?\n)
-		    (> (aref vec i) #x1FFFF)
 		    (aset vec i
 			  (make-glyph-code (aref vec i)
 					   whitespace-newline)))))
 	    ;; Display mapping
 	    (aset buffer-display-table (car entry) vec))
 (setq whitespace-display-table-was-local nil
 	     buffer-display-table whitespace-display-table)))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Hook
+(defun whitespace-action-when-on ()
+"Action to be taken always when local whitespace is turned on."
+(cond ((memq 'cleanup whitespace-action)
+	 (whitespace-cleanup))
+	((memq 'report-on-bogus whitespace-action)
+	 (whitespace-report nil t))))
+(defun whitespace-add-local-hook ()
+"Add some whitespace hooks locally."
+(add-hook 'write-file-functions 'whitespace-write-file-hook nil t)
+(add-hook 'kill-buffer-hook 'whitespace-kill-buffer-hook nil t))
+(defun whitespace-remove-local-hook ()
+"Remove some whitespace hooks locally."
+(remove-hook 'write-file-functions 'whitespace-write-file-hook t)
+(remove-hook 'kill-buffer-hook 'whitespace-kill-buffer-hook t))
+(defun whitespace-write-file-hook ()
+"Action to be taken when buffer is written.
+It should be added buffer-locally to `write-file-functions'."
+(when (whitespace-action)
+(error "Abort write due to whitespace problems in %s"
+	   (buffer-name)))
+nil)					; continue hook processing
+(defun whitespace-kill-buffer-hook ()
+"Action to be taken when buffer is killed.
+It should be added buffer-locally to `kill-buffer-hook'."
+(whitespace-action)
+nil)					; continue  hook processing
+(defun whitespace-action ()
+"Action to be taken when buffer is killed or written.
+Return t when the action should be aborted."
+(cond ((memq 'auto-cleanup whitespace-action)
+	 (whitespace-cleanup)
+	 nil)
+	((memq 'abort-on-bogus whitespace-action)
+	 (whitespace-report nil t))
+	(t
+	 nil)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun whitespace-unload-function ()
-"Unload the Whitespace library."
+"Unload the whitespace library."
-(let (whitespace-mode) ;; so g-w-m thinks it is nil in all buffers
+(global-whitespace-mode -1)
-(global-whitespace-mode -1))
+;; be sure all local whitespace mode is turned off
-;; continue standard unloading
+(save-current-buffer
-nil)
+(dolist (buf (buffer-list))
+(set-buffer buf)
+(whitespace-mode -1)))
+nil)					; continue standard unloading
 (provide 'whitespace)
 (run-hooks 'whitespace-load-hook)

Mercurial > emacs

comparison lisp/whitespace.el @ 92372:0418e6ff8eb2