# HG changeset patch # User Michael Mauger # Date 1284408323 14400 # Node ID ba7558616802a063516c8092a93e856f13e7a3f2 # Parent ec11d41deaa6332551aeaed313ed7f71809a2ac5 SQL Mode 2.7: Code cleanup and primatives for SQL redirection * progmodes/sql.el: Version 2.7. (sql-buffer-live-p): Improve detection. (sql-find-sqli-buffer, sql-set-sqli-buffer-generally) (sql-set-sqli-buffer): Use it. (sql-product-interactive): Run `sql-set-sqli-hook'. (sql-rename-buffer): Code cleanup. (sql-redirect, sql-redirect-value): New functions. More to come. diff -r ec11d41deaa6 -r ba7558616802 lisp/ChangeLog --- a/lisp/ChangeLog Mon Sep 13 21:50:30 2010 +0200 +++ b/lisp/ChangeLog Mon Sep 13 16:05:23 2010 -0400 @@ -1,3 +1,13 @@ +2010-09-13 Michael R. Mauger + + * progmodes/sql.el: Version 2.7. + (sql-buffer-live-p): Improve detection. + (sql-find-sqli-buffer, sql-set-sqli-buffer-generally) + (sql-set-sqli-buffer): Use it. + (sql-product-interactive): Run `sql-set-sqli-hook'. + (sql-rename-buffer): Code cleanup. + (sql-redirect, sql-redirect-value): New functions. More to come. + 2010-09-13 Juanma Barranquero Port tramp-related Makefile changes of revnos 101381, 101422 to Windows. diff -r ec11d41deaa6 -r ba7558616802 lisp/progmodes/sql.el --- a/lisp/progmodes/sql.el Mon Sep 13 21:50:30 2010 +0200 +++ b/lisp/progmodes/sql.el Mon Sep 13 16:05:23 2010 -0400 @@ -5,7 +5,7 @@ ;; Author: Alex Schroeder ;; Maintainer: Michael Mauger -;; Version: 2.6 +;; Version: 2.7 ;; Keywords: comm languages processes ;; URL: http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/progmodes/sql.el ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode @@ -1052,11 +1052,24 @@ Used by `sql-rename-buffer'.") -(defun sql-buffer-live-p (buffer) - "Returns non-nil if the process associated with buffer is live." - (and buffer - (buffer-live-p (get-buffer buffer)) - (get-buffer-process buffer))) +(defun sql-buffer-live-p (buffer &optional product) + "Returns 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 +`sql-interactive-mode', and, if PRODUCT is specified, it's +`sql-product' must match." + + (when buffer + (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-product-interactive) + (or (not product) + (eq product sql-product))))))) ;; Keymap for sql-interactive-mode. @@ -2577,23 +2590,22 @@ "Returns 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 ((default-buffer (default-value 'sql-buffer)) - (current-product sql-product)) - (if (sql-buffer-live-p default-buffer) - default-buffer - (save-current-buffer - (let ((buflist (buffer-list)) - (found)) - (while (not (or (null buflist) - found)) - (let ((candidate (car buflist))) - (set-buffer candidate) - (if (and (sql-buffer-live-p candidate) - (derived-mode-p 'sql-interactive-mode) - (eq sql-product current-product)) - (setq found (buffer-name candidate))) - (setq buflist (cdr buflist)))) - found))))) + (let ((buf sql-buffer) + (prod sql-product)) + (or + ;; Current sql-buffer, if there is one. + (and (sql-buffer-live-p buf prod) + buf) + ;; Global sql-buffer + (and (setq buf (default-value 'sql-buffer)) + (sql-buffer-live-p buf prod) + buf) + ;; Look thru each buffer + (car (apply 'append + (mapcar (lambda (b) + (and (sql-buffer-live-p b prod) + (list (buffer-name b)))) + (buffer-list))))))) (defun sql-set-sqli-buffer-generally () "Set SQLi buffer for all SQL buffers that have none. @@ -2611,10 +2623,11 @@ (let ((candidate (car buflist))) (set-buffer candidate) (if (and (derived-mode-p 'sql-mode) - (not (buffer-live-p sql-buffer))) + (not (sql-buffer-live-p sql-buffer))) (progn (setq sql-buffer default-buffer) - (run-hooks 'sql-set-sqli-hook)))) + (when default-buffer + (run-hooks 'sql-set-sqli-hook))))) (setq buflist (cdr buflist)))))) (defun sql-set-sqli-buffer () @@ -2632,19 +2645,13 @@ (interactive) (let ((default-buffer (sql-find-sqli-buffer))) (if (null default-buffer) - (error "There is no suitable SQLi buffer")) - (let ((new-buffer - (get-buffer - (read-buffer "New SQLi buffer: " default-buffer t)))) - (if (null (get-buffer-process new-buffer)) - (error "Buffer %s has no process" (buffer-name new-buffer))) - (if (null (with-current-buffer new-buffer - (derived-mode-p 'sql-interactive-mode))) - (error "Buffer %s is no SQLi buffer" (buffer-name new-buffer))) - (if new-buffer - (progn - (setq sql-buffer (buffer-name new-buffer)) - (run-hooks 'sql-set-sqli-hook)))))) + (error "There is no suitable SQLi buffer") + (let ((new-buffer (read-buffer "New SQLi buffer: " default-buffer t))) + (if (null (sql-buffer-live-p new-buffer)) + (error "Buffer %s is not a working SQLi buffer" new-buffer) + (when new-buffer + (setq sql-buffer new-buffer) + (run-hooks 'sql-set-sqli-hook))))))) (defun sql-show-sqli-buffer () "Show the name of current SQLi buffer. @@ -2742,13 +2749,13 @@ (if (not (derived-mode-p 'sql-interactive-mode)) (message "Current buffer is not a SQL interactive buffer") - (cond - ((stringp new-name) - (setq sql-alternate-buffer-name new-name)) - ((listp new-name) - (setq sql-alternate-buffer-name + (setq sql-alternate-buffer-name + (cond + ((stringp new-name) new-name) + ((consp new-name) (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " - sql-alternate-buffer-name)))) + sql-alternate-buffer-name)) + (t sql-alternate-buffer-name))) (rename-buffer (if (string= "" sql-alternate-buffer-name) "*SQL*" @@ -2994,6 +3001,91 @@ +;;; Redirect output functions + +(defun sql-redirect (command combuf &optional outbuf save-prior) + "Execute the SQL command and send output to OUTBUF. + +COMBUF must be an active SQL interactive buffer. OUTBUF may be +an existing buffer, or the name of a non-existing buffer. If +omitted the output is sent to a temporary buffer which will be +killed after the command completes. COMMAND should be a string +of commands accepted by the SQLi program." + + (with-current-buffer combuf + (let ((buf (get-buffer-create (or outbuf " *SQL-Redirect*"))) + (proc (get-buffer-process (current-buffer))) + (comint-prompt-regexp (sql-get-product-feature sql-product + :prompt-regexp)) + (start nil)) + (with-current-buffer buf + (unless save-prior + (erase-buffer)) + (goto-char (point-max)) + (setq start (point))) + + ;; Run the command + (comint-redirect-send-command-to-process command buf proc nil t) + (while (null comint-redirect-completed) + (accept-process-output nil 1)) + + ;; Remove echo if there was one + (with-current-buffer buf + (goto-char start) + (when (looking-at (concat "^" (regexp-quote command) "[\\n]")) + (delete-region (match-beginning 0) (match-end 0))) + (goto-char start))))) + +(defun sql-redirect-value (command combuf regexp &optional regexp-groups) + "Execute the SQL command and return part of result. + +COMBUF must be an active SQL interactive buffer. COMMAND should +be a string of commands accepted by the SQLi program. From the +output, the REGEXP is repeatedly matched and the list of +REGEXP-GROUPS submatches is returned. This behaves much like +\\[comint-redirect-results-list-from-process] but instead of +returning a single submatch it returns a list of each submatch +for each match." + + (let ((outbuf " *SQL-Redirect-values*") + (results nil)) + (sql-redirect command combuf outbuf nil) + (with-current-buffer outbuf + (while (re-search-forward regexp nil t) + (push + (cond + ;; no groups-return all of them + ((null regexp-groups) + (let ((i 1) + (r nil)) + (while (match-beginning i) + (push (match-string i) r)) + (nreverse r))) + ;; one group specified + ((numberp regexp-groups) + (match-string regexp-groups)) + ;; (buffer-substring-no-properties + ;; (match-beginning regexp-groups) + ;; (match-end regexp-groups))) + ;; list of numbers; return the specified matches only + ((consp regexp-groups) + (mapcar (lambda (c) + (cond + ((numberp c) (match-string c)) + ((stringp c) (match-substitute-replacement c)) + (t (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" c)))) + regexp-groups)) + ;; String is specified; return replacement string + ((stringp regexp-groups) + (match-substitute-replacement regexp-groups)) + (t + (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" + regexp-groups))) + results))) + (nreverse results))) + + + ;;; SQL mode -- uses SQL interactive mode ;;;###autoload @@ -3365,7 +3457,7 @@ ;; Handle universal arguments if specified (when (not (or executing-kbd-macro noninteractive)) - (when (and (listp product) + (when (and (consp product) (not (cdr product)) (numberp (car product))) (when (>= (car product) 16) @@ -3394,10 +3486,7 @@ ;; If no new name specified, fall back on sql-buffer if its for ;; the same product (if (and (not new-name) - sql-buffer - (sql-buffer-live-p sql-buffer) - (comint-check-proc sql-buffer) - (eq product (with-current-buffer sql-buffer sql-product))) + (sql-buffer-live-p sql-buffer product)) (pop-to-buffer sql-buffer) ;; We have a new name or sql-buffer doesn't exist or match @@ -3423,10 +3512,11 @@ (when new-name (sql-rename-buffer new-name)) - ;; Set `sql-buffer' in the start buffer + ;; Set `sql-buffer' in the new buffer and the start buffer (setq sql-buffer (buffer-name new-sqli-buffer)) (with-current-buffer start-buffer - (setq sql-buffer (buffer-name new-sqli-buffer))) + (setq sql-buffer (buffer-name new-sqli-buffer)) + (run-hooks 'sql-set-sqli-hook)) ;; All done. (message "Login...done")