nesv.ca
My personal emacs configuration
1;;; sql-upcase.el --- Upcase SQL keywords -*- lexical-binding: t -*-
2
3;; Author: Phil S.
4;; URL: https://www.emacswiki.org/emacs/SqlUpcase
5;; Keywords: abbrev, convenience, languages
6;; Created: 9 May 2016
7;; Package-Requires: ((emacs "24.3"))
8;; Version: 0.2
9
10;; This program is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; This program is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with this program. If not, see <http://www.gnu.org/licenses/>.
22
23
24;;; Commentary:
25;;
26;; `sql-upcase-mode' converts SQL keywords to upper-case as you type
27;; or otherwise insert text in the buffer -- for instance, killing and
28;; yanking an entire SQL query would upcase all keywords in that query.
29;;
30;; It utilises the product-specific regexps defined by sql.el, and thus
31;; will upcase only the keywords defined for the buffer's `sql-product'.
32;; (Note that `sql-mode' buffers default to the `ansi' product.)
33;;
34;; You can enable it via `sql-mode-hook' and/or `sql-interactive-mode-hook':
35;;
36;; (add-hook 'sql-mode-hook 'sql-upcase-mode)
37;; (add-hook 'sql-interactive-mode-hook 'sql-upcase-mode)
38;;
39;; Note that, by default, only lower-case keywords are processed.
40;; To handle mixed-case keywords as well, customize `sql-upcase-mixed-case'.
41
42
43;;; Change Log:
44;;
45;; 0.2 - Added `sql-upcase-region' and `sql-upcase-buffer' commands.
46;; - Rename from sql-upcase-mode.el to sql-upcase.el.
47;; - Match both boundaries of a keyword, to avoid false-positives.
48;; - Constrain 'in string' and 'in comment' tests to current query.
49;; - Fixed error with whitespace at beginning of buffer.
50;; 0.1 - Initial release to EmacsWiki.
51
52
53;;; Code:
54
55(require 'sql)
56
57(defcustom sql-upcase-mixed-case nil
58 "If nil, `sql-upcase-keywords' looks only for lower-case keywords,
59and mixed-case keywords are ignored.
60
61If non-nil, then mixed-case keywords will also be upcased."
62 :type '(choice (const :tag "Lower-case only" nil)
63 (const :tag "Both lower- and mixed-case" t))
64 :group 'SQL)
65
66(defvar sql-upcase-boundary "[\t\n\r ();]"
67 "Regexp matching a character which can precede or follow a keyword.
68
69In addition we match \"^\" at the start of a keyword; and `sql-upcase-region'
70and `sql-upcase-buffer' both match \"\\'\" at the end of a keyword.")
71
72(defvar sql-upcase-inhibited nil
73 "Set non-nil to prevent `sql-upcase-keywords' from acting.")
74
75(defvar-local sql-upcase-comint-output nil)
76
77(defvar sql-upcase-regions)
78
79;;;###autoload
80(define-minor-mode sql-upcase-mode
81 "Automatically upcase SQL keywords as text is inserted in the buffer.
82
83Intended to be enabled via `sql-mode-hook' and/or `sql-interactive-mode-hook'.
84
85Note that this can be a little aggressive in `sql-interactive-mode'. Although
86output from the inferior process is ignored, all other text changes to the
87buffer are processed (e.g. cycling through the command history)."
88 :lighter " sql^"
89 (if sql-upcase-mode
90 (progn
91 (add-hook 'after-change-functions 'sql-upcase-keywords nil :local)
92 (when (derived-mode-p 'sql-interactive-mode)
93 (add-hook 'comint-preoutput-filter-functions
94 'sql-upcase-comint-preoutput nil :local)))
95 ;; Disable.
96 (remove-hook 'after-change-functions 'sql-upcase-keywords :local)
97 (when (derived-mode-p 'sql-interactive-mode)
98 (remove-hook 'comint-preoutput-filter-functions
99 'sql-upcase-comint-preoutput :local))))
100
101;;;###autoload
102(defun sql-upcase-region (beginning end)
103 "Upcase SQL keywords within the marked region.
104
105Keywords overlapping BEGINNING will be upcased.
106Keywords overlapping END will not be upcased."
107 (interactive "*r")
108 (save-excursion
109 ;; Avoid upcasing a word preceding the region.
110 (goto-char beginning)
111 (and (not (eobp))
112 (looking-at sql-upcase-boundary)
113 (setq beginning (1+ beginning)))
114 ;; Allow upcasing the final word in the region.
115 (goto-char end)
116 (and (not (eobp))
117 (looking-at sql-upcase-boundary)
118 (setq end (1+ end))))
119 ;; Make an exception if the last character of the buffer is the last
120 ;; character of a keyword. Normally we require a trailing boundary
121 ;; character matching `sql-upcase-boundary', but for this command we
122 ;; will also treat the end of the buffer as a boundary.
123 (let ((sql-upcase-boundary
124 (concat "\\(?:\\'\\|" sql-upcase-boundary "\\)")))
125 ;; Call our `after-change-functions' handler.
126 (sql-upcase-keywords beginning end 0)))
127
128;;;###autoload
129(defun sql-upcase-buffer ()
130 "Upcase all SQL keywords in the buffer."
131 (interactive)
132 (sql-upcase-region (point-min) (point-max)))
133
134(defun sql-upcase-comint-preoutput (output)
135 "Inhibit `sql-upcase-keywords' for comint process output.
136
137Called via `comint-preoutput-filter-functions'."
138 (setq sql-upcase-comint-output t)
139 output)
140
141(defun sql-upcase-keywords (beginning end old-len)
142 "Automatically upcase SQL keywords and builtin function names.
143
144If `sql-upcase-mixed-case' is non-nil, then only lower-case keywords
145will be processed, and mixed-case keywords will be ignored.
146
147Triggered by `after-change-functions' (see which regarding the
148function arguments), and utilising the product-specific font-lock
149keywords specified in `sql-product-alist'."
150 (when (eq old-len 0) ; The text change was an insertion.
151 (if sql-upcase-comint-output
152 ;; The current input is output from comint, so ignore it and
153 ;; just reset this flag.
154 (setq sql-upcase-comint-output nil)
155 ;; User-generated input.
156 (unless (or undo-in-progress
157 sql-upcase-inhibited)
158 (let ((sql-upcase-regions nil)
159 (case-fold-search sql-upcase-mixed-case))
160 (save-excursion
161 ;; Any errors must be handled, otherwise we will be removed
162 ;; automatically from `after-change-functions'.
163 (with-demoted-errors "sql-upcase-keywords error: %S"
164 ;; Process all keywords affected by the inserted text.
165 ;;
166 ;; The "two steps forward one step back" approach of looking
167 ;; for the ENDs of keywords in the text and then testing the
168 ;; preceding words may seem odd, but one of the primary use-cases
169 ;; is as-you-type processing, in which case the text inserts we
170 ;; are looking at are typically single self-insert characters,
171 ;; and we are actually searching just that single character to
172 ;; see if it is a keyword-ending character, in order that we can
173 ;; upcase the previously-entered keyword before it.
174 (goto-char beginning)
175 (while (and (< (point) end)
176 (re-search-forward sql-upcase-boundary end :noerror))
177 (save-excursion
178 (goto-char (match-beginning 0))
179 (and (not (bobp))
180 ;; ...if the preceding character is of word syntax...
181 (eq (char-syntax (char-before)) ?w)
182 ;; ...and we're not inside a string or a comment...
183 (let* ((sep (if sql-prompt-regexp
184 (concat
185 "\\`\\|\\(?:" sql-prompt-regexp "\\)")
186 "\\`"))
187 ;; TODO: Use (sql-beginning-of-statement 1)?
188 ;; Might error out. Should call that only once
189 ;; (and only if needed), and cache the result.
190 (from (save-excursion
191 (re-search-backward sep nil :noerror)
192 (or (match-end 0) (point-min))))
193 (syn (parse-partial-sexp from (point))))
194 (not (or (nth 3 syn) ; string
195 (nth 4 syn)))) ; comment
196 ;; Try to match the preceding word as a SQL keyword.
197 (sql-upcase-match-keyword))))))
198 ;; Upcase the matched regions (if any)
199 (when sql-upcase-regions
200 (undo-boundary) ;; now that save-excursion has returned
201 (mapc (lambda (r) (upcase-region (car r) (cdr r)))
202 sql-upcase-regions)))))))
203
204(defun sql-upcase-match-keyword ()
205 "Matches a keyword for `sql-upcase-keywords'.
206
207Tests whether the preceding word:
208
2091) is itself preceded by (only) whitespace or (
2102a) matches the regexp for a keyword
2112b) matches the regexp for a builtin, followed by ("
212 (and (catch 'matched
213 (let ((inhibit-field-text-motion t)) ;; for comint
214 (forward-word -1)
215 (unless (bolp)
216 (forward-char -1)))
217 ;; Try to match a keyword using the regexps for this SQL product.
218 (let* ((before (concat "\\(?:^\\|" sql-upcase-boundary "\\)"))
219 (after sql-upcase-boundary)
220 ;; Build regexp for statement starters.
221 ;; FIXME: Generate once only, as a buffer-local var?
222 (statements ;; n.b. each of these is already a regexp
223 (delq nil
224 (list (sql-get-product-feature sql-product :statement)
225 (unless (eq sql-product 'ansi)
226 (sql-get-product-feature 'ansi :statement)))))
227 (statements-regexp
228 (concat "\\(?:" (mapconcat 'identity statements "\\|") "\\)")))
229 ;; Check statement starters first
230 (if (looking-at (concat before statements-regexp after))
231 (throw 'matched t)
232 ;; Otherwise process the product's font-lock keywords.
233 ;; TODO: I'm not sure that `font-lock-builtin-face' can be assumed
234 ;; to just be functions. (e.g. SET is not seen as a keyword.)
235 (dolist (keywords (sql-get-product-feature sql-product :font-lock))
236 (when (or (and (eq (cdr keywords) 'font-lock-keyword-face)
237 (looking-at (concat before (car keywords) after)))
238 (and (eq (cdr keywords) 'font-lock-builtin-face)
239 (looking-at (concat before (car keywords) "("))))
240 (throw 'matched t))))))
241 ;; If `sql-upcase-mixed-case' is non-nil then check for at least one
242 ;; lower-case character in the matched region, as otherwise the upcase
243 ;; will be a no-op (but stored as a change in the buffer undo list).
244 (or (not sql-upcase-mixed-case)
245 (save-match-data
246 (let ((case-fold-search nil))
247 (re-search-forward "[[:lower:]]" (match-end 0) :noerror))))
248 ;; Store the matched keyword region for subsequent upcasing.
249 (push (cons (match-beginning 0) (match-end 0))
250 sql-upcase-regions)))
251
252(provide 'sql-upcase)
253;;; sql-upcase.el ends here