Commit 93852cb0 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/progmodes/sql.el: Use cl-lib and lexical-binding; various cleanup.

(sql-signum): Remove.  Use `cl-signum' instead.
(sql-read-passwd): Remove; use read-passwd instread.
(sql-get-login-ext): Use read-string.
(sql-get-login): Use dolist and pcase.
(sql--completion-table): Rename from sql-try-completion.
Use complete-with-action.
(sql-mode): Don't change abbrev-all-caps globally.
(sql-connect): Don't rely on dynamic scoping for `new-name'.
(sql-postgres-completion-object): Initialize vars in their `let'.
(sql-comint-sybase, sql-comint-sqlite, sql-comint-mysql)
(sql-comint-solid, sql-comint-ms, sql-comint-postgres)
(sql-comint-interbase): Use a single append, without setq.
(sql-comint-linter): Same, and unwind-protect the LINTER_MBX var.
parent 853c1ffc
2012-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
 
* progmodes/sql.el: Use cl-lib and lexical-binding; various cleanup.
(sql-signum): Remove. Use `cl-signum' instead.
(sql-read-passwd): Remove; use read-passwd instread.
(sql-get-login-ext): Use read-string.
(sql-get-login): Use dolist and pcase.
(sql--completion-table): Rename from sql-try-completion.
Use complete-with-action.
(sql-mode): Don't change abbrev-all-caps globally.
(sql-connect): Don't rely on dynamic scoping for `new-name'.
(sql-postgres-completion-object): Initialize vars in their `let'.
(sql-comint-sybase, sql-comint-sqlite, sql-comint-mysql)
(sql-comint-solid, sql-comint-ms, sql-comint-postgres)
(sql-comint-interbase): Use a single append, without setq.
(sql-comint-linter): Same, and unwind-protect the LINTER_MBX var.
* hi-lock.el: Rework the default face and the serialize regexp code.
(hi-lock--auto-select-face-defaults): Remove.
(hi-lock-string-serialize-serial): Remove.
......
;;; sql.el --- specialized comint.el for SQL interpreters
;;; sql.el --- specialized comint.el for SQL interpreters -*- lexical-binding: t -*-
;; Copyright (C) 1998-2012 Free Software Foundation, Inc.
......@@ -80,14 +80,6 @@
;; Hint for newbies: take a look at `dabbrev-expand', `abbrev-mode', and
;; `imenu-add-menubar-index'.
;;; Requirements for Emacs 19.34:
;; If you are using Emacs 19.34, you will have to get and install
;; the file regexp-opt.el
;; <URL:ftp://ftp.ifi.uio.no/pub/emacs/emacs-20.3/lisp/emacs-lisp/regexp-opt.el>
;; and the custom package
;; <URL:http://www.dina.kvl.dk/~abraham/custom/>.
;;; Bugs:
;; sql-ms now uses osql instead of isql. Osql flushes its error
......@@ -169,15 +161,17 @@
;;
;; ;; Do something with `sql-user', `sql-password',
;; ;; `sql-database', and `sql-server'.
;; (let ((params options))
;; (if (not (string= "" sql-server))
;; (setq params (append (list "-S" sql-server) params)))
;; (if (not (string= "" sql-database))
;; (setq params (append (list "-D" sql-database) params)))
;; (if (not (string= "" sql-password))
;; (setq params (append (list "-P" sql-password) params)))
;; (let ((params
;; (append
;; (if (not (string= "" sql-user))
;; (setq params (append (list "-U" sql-user) params)))
;; (list "-U" sql-user))
;; (if (not (string= "" sql-password))
;; (list "-P" sql-password))
;; (if (not (string= "" sql-database))
;; (list "-D" sql-database))
;; (if (not (string= "" sql-server))
;; (list "-S" sql-server))
;; options)))
;; (sql-comint product params)))
;;
;; (sql-set-product-feature 'xyz
......@@ -229,22 +223,13 @@
;;; Code:
(require 'cl-lib)
(require 'comint)
;; Need the following to allow GNU Emacs 19 to compile the file.
(eval-when-compile
(require 'regexp-opt))
(require 'custom)
(require 'thingatpt)
(eval-when-compile ;; needed in Emacs 19, 20
(setq max-specpdl-size (max max-specpdl-size 2000)))
(defun sql-signum (n)
"Return 1, 0, or -1 to identify the sign of N."
(cond
((not (numberp n)) nil)
((< n 0) -1)
((> n 0) 1)
(t 0)))
(defvar font-lock-keyword-face)
(defvar font-lock-set-defaults)
......@@ -636,12 +621,14 @@ making new SQLi sessions."
(set
(group (const :tag "Product" sql-product)
(choice
,@(mapcar (lambda (prod-info)
`(const :tag
,(or (plist-get (cdr prod-info) :name)
(capitalize (symbol-name (car prod-info))))
(quote ,(car prod-info))))
sql-product-alist)))
,@(mapcar
(lambda (prod-info)
`(const :tag
,(or (plist-get (cdr prod-info) :name)
(capitalize
(symbol-name (car prod-info))))
(quote ,(car prod-info))))
sql-product-alist)))
(group (const :tag "Username" sql-user) string)
(group (const :tag "Password" sql-password) string)
(group (const :tag "Server" sql-server) string)
......@@ -655,8 +642,8 @@ making new SQLi sessions."
:group 'SQL)
(defcustom sql-product 'ansi
"Select the SQL database product used so that buffers can be
highlighted properly when you open them."
"Select the SQL database product used.
This allows highlighting buffers properly when you open them."
:type `(choice
,@(mapcar (lambda (prod-info)
`(const :tag
......@@ -818,12 +805,11 @@ for the first time."
;; Customization for ANSI
(defcustom sql-ansi-statement-starters (regexp-opt '(
"create" "alter" "drop"
"select" "insert" "update" "delete" "merge"
"grant" "revoke"
))
"Regexp of keywords that start SQL commands
(defcustom sql-ansi-statement-starters
(regexp-opt '("create" "alter" "drop"
"select" "insert" "update" "delete" "merge"
"grant" "revoke"))
"Regexp of keywords that start SQL commands.
All products share this list; products should define a regexp to
identify additional keywords in a variable defined by
......@@ -1167,10 +1153,10 @@ You can change `sql-prompt-length' on `sql-interactive-mode-hook'.")
Used by `sql-rename-buffer'.")
(defun sql-buffer-live-p (buffer &optional product connection)
"Returns non-nil if the process associated with buffer is live.
"Return non-nil if the process associated with buffer is live.
BUFFER can be a buffer object or a buffer name. The buffer must
be a live buffer, have an running process attached to it, be in
be a live buffer, have a running process attached to it, be in
`sql-interactive-mode', and, if PRODUCT or CONNECTION are
specified, it's `sql-product' or `sql-connection' must match."
......@@ -1178,7 +1164,6 @@ specified, it's `sql-product' or `sql-connection' must match."
(setq buffer (get-buffer buffer))
(and buffer
(buffer-live-p buffer)
(get-buffer-process buffer)
(comint-check-proc buffer)
(with-current-buffer buffer
(and (derived-mode-p 'sql-interactive-mode)
......@@ -1287,27 +1272,15 @@ Based on `comint-mode-map'.")
;; Abbreviations -- if you want more of them, define them in your init
;; file. Abbrevs have to be enabled in your init file, too.
(defvar sql-mode-abbrev-table nil
(define-abbrev-table 'sql-mode-abbrev-table
'(("ins" "insert" nil nil t)
("upd" "update" nil nil t)
("del" "delete" nil nil t)
("sel" "select" nil nil t)
("proc" "procedure" nil nil t)
("func" "function" nil nil t)
("cr" "create" nil nil t))
"Abbrev table used in `sql-mode' and `sql-interactive-mode'.")
(unless sql-mode-abbrev-table
(define-abbrev-table 'sql-mode-abbrev-table nil))
(mapc
;; In Emacs 22+, provide SYSTEM-FLAG to define-abbrev.
(lambda (abbrev)
(let ((name (car abbrev))
(expansion (cdr abbrev)))
(condition-case nil
(define-abbrev sql-mode-abbrev-table name expansion nil 0 t)
(error
(define-abbrev sql-mode-abbrev-table name expansion)))))
'(("ins" . "insert")
("upd" . "update")
("del" . "delete")
("sel" . "select")
("proc" . "procedure")
("func" . "function")
("cr" . "create")))
;; Syntax Table
......@@ -1530,9 +1503,8 @@ function `regexp-opt'. Therefore, take a look at the source before
you define your own `sql-mode-ansi-font-lock-keywords'. You may want
to add functions and PL/SQL keywords.")
(defun sql-oracle-show-reserved-words ()
(defun sql--oracle-show-reserved-words ()
;; This function is for use by the maintainer of SQL.EL only.
(interactive)
(if (or (and (not (derived-mode-p 'sql-mode))
(not (derived-mode-p 'sql-interactive-mode)))
(not sql-buffer)
......@@ -2611,14 +2583,12 @@ adds a fontification pattern to fontify identifiers ending in
(append keywords old-val))))))
(defun sql-for-each-login (login-params body)
"Iterates through login parameters and returns a list of results."
"Iterate through login parameters and return a list of results."
(delq nil
(mapcar
(lambda (param)
(let ((token (or (and (listp param) (car param)) param))
(plist (or (and (listp param) (cdr param)) nil)))
(let ((token (or (car-safe param) param))
(plist (cdr-safe param)))
(funcall body token plist)))
login-params)))
......@@ -2682,6 +2652,34 @@ matching the regular expression `comint-prompt-regexp', a buffer
local variable."
(save-excursion (comint-bol nil) (point))))
;;; SMIE support
;; Needs a lot more love than I can provide. --Stef
;; (require 'smie)
;; (defconst sql-smie-grammar
;; (smie-prec2->grammar
;; (smie-bnf->prec2
;; ;; Partly based on http://www.h2database.com/html/grammar.html
;; '((cmd ("SELECT" select-exp "FROM" select-table-exp)
;; )
;; (select-exp ("*") (exp) (exp "AS" column-alias))
;; (column-alias)
;; (select-table-exp (table-exp "WHERE" exp) (table-exp))
;; (table-exp)
;; (exp ("CASE" exp "WHEN" exp "THEN" exp "ELSE" exp "END")
;; ("CASE" exp "WHEN" exp "THEN" exp "END"))
;; ;; Random ad-hoc additions.
;; (foo (foo "," foo))
;; )
;; '((assoc ",")))))
;; (defun sql-smie-rules (kind token)
;; (pcase (cons kind token)
;; (`(:list-intro . ,_) t)
;; (`(:before . "(") (smie-rule-parent))))
;;; Motion Functions
(defun sql-statement-regexp (prod)
......@@ -2694,7 +2692,7 @@ local variable."
"\\>")))
(defun sql-beginning-of-statement (arg)
"Moves the cursor to the beginning of the current SQL statement."
"Move to the beginning of the current SQL statement."
(interactive "p")
(let ((here (point))
......@@ -2721,10 +2719,10 @@ local variable."
(beginning-of-line)
;; If we didn't move, try again
(when (= here (point))
(sql-beginning-of-statement (* 2 (sql-signum arg))))))
(sql-beginning-of-statement (* 2 (cl-signum arg))))))
(defun sql-end-of-statement (arg)
"Moves the cursor to the end of the current SQL statement."
"Move to the end of the current SQL statement."
(interactive "p")
(let ((term (sql-get-product-feature sql-product :terminator))
(re-search (if (> 0 arg) 're-search-backward 're-search-forward))
......@@ -2733,7 +2731,7 @@ local variable."
(when (consp term)
(setq term (car term)))
;; Iterate until we've moved the desired number of stmt ends
(while (not (= (sql-signum arg) 0))
(while (not (= (cl-signum arg) 0))
;; if we're looking at the terminator, jump by 2
(if (or (and (> 0 arg) (looking-back term))
(and (< 0 arg) (looking-at term)))
......@@ -2744,7 +2742,7 @@ local variable."
(setq arg 0)
;; count it if we're not in a comment
(unless (nth 7 (syntax-ppss))
(setq arg (- arg (sql-signum arg))))))
(setq arg (- arg (cl-signum arg))))))
(goto-char (if (match-data)
(match-end 0)
here))))
......@@ -2857,10 +2855,6 @@ appended to the SQLi buffer without disturbing your SQL buffer."
t t doc 0)))
doc)
(defun sql-read-passwd (prompt &optional default)
"Read a password using PROMPT. Optional DEFAULT is password to start with."
(read-passwd prompt nil default))
(defun sql-get-login-ext (symbol prompt history-var plist)
"Prompt user with extended login parameters.
......@@ -2912,8 +2906,7 @@ value. (The property value is used as the PREDICATE argument to
(read-number prompt (or default last-value 0)))
(t
(let ((r (read-from-minibuffer prompt-def last-value nil nil history-var nil)))
(if (string= "" r) (or default "") r)))))))
(read-string prompt-def last-value history-var default))))))
(defun sql-get-login (&rest what)
"Get username, password and database from the user.
......@@ -2943,32 +2936,29 @@ supported:
In order to ask the user for username, password and database, call the
function like this: (sql-get-login 'user 'password 'database)."
(interactive)
(mapcar
(lambda (w)
(let ((token (or (and (consp w) (car w)) w))
(plist (or (and (consp w) (cdr w)) nil)))
(cond
((eq token 'user) ; user
(sql-get-login-ext 'sql-user "User: " 'sql-user-history plist))
(dolist (w what)
(let ((plist (cdr-safe w)))
(pcase (or (car-safe w) w)
(`user
(sql-get-login-ext 'sql-user "User: " 'sql-user-history plist))
((eq token 'password) ; password
(setq-default sql-password
(sql-read-passwd "Password: " sql-password)))
(`password
(setq-default sql-password
(read-passwd "Password: " nil sql-password)))
((eq token 'server) ; server
(sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist))
(`server
(sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist))
((eq token 'database) ; database
(sql-get-login-ext 'sql-database "Database: " 'sql-database-history plist))
(`database
(sql-get-login-ext 'sql-database "Database: "
'sql-database-history plist))
((eq token 'port) ; port
(sql-get-login-ext 'sql-port "Port: " nil (append '(:number t) plist))))))
what))
(`port
(sql-get-login-ext 'sql-port "Port: "
nil (append '(:number t) plist)))))))
(defun sql-find-sqli-buffer (&optional product connection)
"Returns the name of the current default SQLi buffer or nil.
"Return the name of the current default SQLi buffer or nil.
In order to qualify, the SQLi buffer must be alive, be in
`sql-interactive-mode' and have a process."
(let ((buf sql-buffer)
......@@ -3072,29 +3062,29 @@ server/database name."
(sql-for-each-login
(sql-get-product-feature sql-product :sqli-login)
(lambda (token plist)
(cond
((eq token 'user)
(pcase token
(`user
(unless (string= "" sql-user)
(list "/" sql-user)))
((eq token 'port)
(`port
(unless (or (not (numberp sql-port))
(= 0 sql-port))
(list ":" (number-to-string sql-port))))
((eq token 'server)
(`server
(unless (string= "" sql-server)
(list "."
(if (plist-member plist :file)
(file-name-nondirectory sql-server)
sql-server))))
((eq token 'database)
(`database
(unless (string= "" sql-database)
(list "@"
(if (plist-member plist :file)
(file-name-nondirectory sql-database)
sql-database))))
((eq token 'password) nil)
(t nil))))))))
;; (`password nil)
(_ nil))))))))
;; If there's a connection, use it and the name thus far
(if sql-connection
......@@ -3527,7 +3517,7 @@ for each match."
(nreverse results)))
(defun sql-execute (sqlbuf outbuf command enhanced arg)
"Executes a command in a SQL interactive buffer and captures the output.
"Execute a command in a SQL interactive buffer and capture the output.
The commands are run in SQLBUF and the output saved in OUTBUF.
COMMAND must be a string, a function or a list of such elements.
......@@ -3535,7 +3525,7 @@ Functions are called with SQLBUF, OUTBUF and ARG as parameters;
strings are formatted with ARG and executed.
If the results are empty the OUTBUF is deleted, otherwise the
buffer is popped into a view window. "
buffer is popped into a view window."
(mapc
(lambda (c)
(cond
......@@ -3600,43 +3590,35 @@ The list is maintained in SQL interactive buffers.")
(defvar sql-completion-sqlbuf nil)
(defun sql-try-completion (string collection &optional predicate)
(defun sql--completion-table (string pred action)
(when sql-completion-sqlbuf
(with-current-buffer sql-completion-sqlbuf
(let ((schema (and (string-match "\\`\\(\\sw\\(:?\\sw\\|\\s_\\)*\\)[.]" string)
(downcase (match-string 1 string)))))
;; If we haven't loaded any object name yet, load local schema
(unless sql-completion-object
(sql-build-completions nil))
;; If they want another schema, load it if we haven't yet
(when schema
(let ((schema-dot (concat schema "."))
(schema-len (1+ (length schema)))
(names sql-completion-object)
has-schema)
(while (and (not has-schema) names)
(setq has-schema (and
(>= (length (car names)) schema-len)
(string= schema-dot
(downcase (substring (car names)
0 schema-len))))
names (cdr names)))
(unless has-schema
(sql-build-completions schema)))))
;; Try to find the completion
(cond
((not predicate)
(try-completion string sql-completion-object))
((eq predicate t)
(all-completions string sql-completion-object))
((eq predicate 'lambda)
(test-completion string sql-completion-object))
((eq (car predicate) 'boundaries)
(completion-boundaries string sql-completion-object nil (cdr predicate)))))))
(with-current-buffer sql-completion-sqlbuf
(let ((schema (and (string-match "\\`\\(\\sw\\(:?\\sw\\|\\s_\\)*\\)[.]" string)
(downcase (match-string 1 string)))))
;; If we haven't loaded any object name yet, load local schema
(unless sql-completion-object
(sql-build-completions nil))
;; If they want another schema, load it if we haven't yet
(when schema
(let ((schema-dot (concat schema "."))
(schema-len (1+ (length schema)))
(names sql-completion-object)
has-schema)
(while (and (not has-schema) names)
(setq has-schema (and
(>= (length (car names)) schema-len)
(string= schema-dot
(downcase (substring (car names)
0 schema-len))))
names (cdr names)))
(unless has-schema
(sql-build-completions schema)))))
;; Try to find the completion
(complete-with-action action sql-completion-object string pred))))
(defun sql-read-table-name (prompt)
"Read the name of a database table."
......@@ -3652,7 +3634,7 @@ The list is maintained in SQL interactive buffers.")
(completion-ignore-case t))
(if (sql-get-product-feature product :completion-object)
(completing-read prompt (function sql-try-completion)
(completing-read prompt #'sql--completion-table
nil nil tname)
(read-from-minibuffer prompt tname))))
......@@ -3720,6 +3702,7 @@ must tell Emacs. Here's how to do that in your init file:
(if sql-mode-menu
(easy-menu-add sql-mode-menu)); XEmacs
;; (smie-setup sql-smie-grammar #'sql-smie-rules)
(set (make-local-variable 'comment-start) "--")
;; Make each buffer in sql-mode remember the "current" SQLi buffer.
(make-local-variable 'sql-buffer)
......@@ -3733,7 +3716,7 @@ must tell Emacs. Here's how to do that in your init file:
(set (make-local-variable 'paragraph-separate) "[\f]*$")
(set (make-local-variable 'paragraph-start) "[\n\f]")
;; Abbrevs
(setq abbrev-all-caps 1)
(setq-local abbrev-all-caps 1)
;; Contains the name of database objects
(set (make-local-variable 'sql-contains-names) t)
;; Catch changes to sql-product and highlight accordingly
......@@ -3959,13 +3942,13 @@ is specified in the connection settings."
(setq set-params
(mapcar
(lambda (v)
(cond
((eq (car v) 'sql-user) 'user)
((eq (car v) 'sql-password) 'password)
((eq (car v) 'sql-server) 'server)
((eq (car v) 'sql-database) 'database)
((eq (car v) 'sql-port) 'port)
(t (car v))))
(pcase (car v)
(`sql-user 'user)
(`sql-password 'password)
(`sql-server 'server)
(`sql-database 'database)
(`sql-port 'port)
(s s)))
(cdr connect-set)))
;; the remaining params (w/o the connection params)
......@@ -3984,7 +3967,7 @@ is specified in the connection settings."
;; Start the SQLi session with revised list of login parameters
(eval `(let ((,param-var ',rem-params))
(sql-product-interactive sql-product new-name))))
(sql-product-interactive ',sql-product ',new-name))))
(message "SQL Connection <%s> does not exist" connection)
nil)))
......@@ -4028,16 +4011,16 @@ optionally is saved to the user's init file."
(if (assoc name alist)
(message "Connection <%s> already exists" name)
(setq connect
(append (list name)
(sql-for-each-login
`(product ,@login)
(lambda (token _plist)
(cond
((eq token 'product) `(sql-product ',product))
((eq token 'user) `(sql-user ,user))
((eq token 'database) `(sql-database ,database))
((eq token 'server) `(sql-server ,server))
((eq token 'port) `(sql-port ,port)))))))
(cons name
(sql-for-each-login
`(product ,@login)
(lambda (token _plist)
(pcase token
(`product `(sql-product ',product))
(`user `(sql-user ,user))
(`database `(sql-database ,database))
(`server `(sql-server ,server))
(`port `(sql-port ,port)))))))
(setq alist (append alist (list connect)))
......@@ -4047,7 +4030,7 @@ optionally is saved to the user's init file."
(customize-set-variable 'sql-connection-alist alist)))))))
(defun sql-connection-menu-filter (tail)
"Generates menu entries for using each connection."
"Generate menu entries for using each connection."
(append
(mapcar
(lambda (conn)
......@@ -4114,7 +4097,8 @@ the call to \\[sql-product-interactive] with
new-sqli-buffer)
;; Get credentials.
(apply 'sql-get-login (sql-get-product-feature product :sqli-login))
(apply #'sql-get-login
(sql-get-product-feature product :sqli-login))
;; Connect to database.
(message "Login...")
......@@ -4225,7 +4209,7 @@ The default comes from `process-coding-system-alist' and
(sql-comint product parameter)))
(defun sql-oracle-save-settings (sqlbuf)
"Saves most SQL*Plus settings so they may be reset by \\[sql-redirect]."
"Save most SQL*Plus settings so they may be reset by \\[sql-redirect]."
;; Note: does not capture the following settings:
;;
;; APPINFO
......@@ -4297,7 +4281,7 @@ The default comes from `process-coding-system-alist' and
;; Restore the changed settings
(sql-redirect sqlbuf saved-settings))
(defun sql-oracle-list-all (sqlbuf outbuf enhanced table-name)
(defun sql-oracle-list-all (sqlbuf outbuf enhanced _table-name)
;; Query from USER_OBJECTS or ALL_OBJECTS
(let ((settings (sql-oracle-save-settings sqlbuf))
(simple-sql
......@@ -4336,7 +4320,7 @@ The default comes from `process-coding-system-alist' and
(sql-oracle-restore-settings sqlbuf settings)))
(defun sql-oracle-list-table (sqlbuf outbuf enhanced table-name)
(defun sql-oracle-list-table (sqlbuf outbuf _enhanced table-name)
"Implements :list-table under Oracle."
(let ((settings (sql-oracle-save-settings sqlbuf)))
......@@ -4413,15 +4397,17 @@ The default comes from `process-coding-system-alist' and
"Create comint buffer and connect to Sybase."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
(let ((params options))
(if (not (string= "" sql-server))
(setq params (append (list "-S" sql-server) params)))
(if (not (string= "" sql-database))
(setq params (append (list "-D" sql-database) params)))
(if (not (string= "" sql-password))