Mercurial > emacs
comparison lisp/progmodes/sql.el @ 110326:ba7558616802
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.
author | Michael Mauger <mmaug@yahoo.com> |
---|---|
date | Mon, 13 Sep 2010 16:05:23 -0400 |
parents | 14a601b405fc |
children | 03a492f2d1ce |
comparison
equal
deleted
inserted
replaced
110325:ec11d41deaa6 | 110326:ba7558616802 |
---|---|
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, | 3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, |
4 ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. | 4 ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
5 | 5 |
6 ;; Author: Alex Schroeder <alex@gnu.org> | 6 ;; Author: Alex Schroeder <alex@gnu.org> |
7 ;; Maintainer: Michael Mauger <mmaug@yahoo.com> | 7 ;; Maintainer: Michael Mauger <mmaug@yahoo.com> |
8 ;; Version: 2.6 | 8 ;; Version: 2.7 |
9 ;; Keywords: comm languages processes | 9 ;; Keywords: comm languages processes |
10 ;; URL: http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/progmodes/sql.el | 10 ;; URL: http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/progmodes/sql.el |
11 ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode | 11 ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode |
12 | 12 |
13 ;; This file is part of GNU Emacs. | 13 ;; This file is part of GNU Emacs. |
1050 (defvar sql-alternate-buffer-name nil | 1050 (defvar sql-alternate-buffer-name nil |
1051 "Buffer-local string used to possibly rename the SQLi buffer. | 1051 "Buffer-local string used to possibly rename the SQLi buffer. |
1052 | 1052 |
1053 Used by `sql-rename-buffer'.") | 1053 Used by `sql-rename-buffer'.") |
1054 | 1054 |
1055 (defun sql-buffer-live-p (buffer) | 1055 (defun sql-buffer-live-p (buffer &optional product) |
1056 "Returns non-nil if the process associated with buffer is live." | 1056 "Returns non-nil if the process associated with buffer is live. |
1057 (and buffer | 1057 |
1058 (buffer-live-p (get-buffer buffer)) | 1058 BUFFER can be a buffer object or a buffer name. The buffer must |
1059 (get-buffer-process buffer))) | 1059 be a live buffer, have an running process attached to it, be in |
1060 `sql-interactive-mode', and, if PRODUCT is specified, it's | |
1061 `sql-product' must match." | |
1062 | |
1063 (when buffer | |
1064 (setq buffer (get-buffer buffer)) | |
1065 (and buffer | |
1066 (buffer-live-p buffer) | |
1067 (get-buffer-process buffer) | |
1068 (comint-check-proc buffer) | |
1069 (with-current-buffer buffer | |
1070 (and (derived-mode-p 'sql-product-interactive) | |
1071 (or (not product) | |
1072 (eq product sql-product))))))) | |
1060 | 1073 |
1061 ;; Keymap for sql-interactive-mode. | 1074 ;; Keymap for sql-interactive-mode. |
1062 | 1075 |
1063 (defvar sql-interactive-mode-map | 1076 (defvar sql-interactive-mode-map |
1064 (let ((map (make-sparse-keymap))) | 1077 (let ((map (make-sparse-keymap))) |
2575 | 2588 |
2576 (defun sql-find-sqli-buffer () | 2589 (defun sql-find-sqli-buffer () |
2577 "Returns the name of the current default SQLi buffer or nil. | 2590 "Returns the name of the current default SQLi buffer or nil. |
2578 In order to qualify, the SQLi buffer must be alive, be in | 2591 In order to qualify, the SQLi buffer must be alive, be in |
2579 `sql-interactive-mode' and have a process." | 2592 `sql-interactive-mode' and have a process." |
2580 (let ((default-buffer (default-value 'sql-buffer)) | 2593 (let ((buf sql-buffer) |
2581 (current-product sql-product)) | 2594 (prod sql-product)) |
2582 (if (sql-buffer-live-p default-buffer) | 2595 (or |
2583 default-buffer | 2596 ;; Current sql-buffer, if there is one. |
2584 (save-current-buffer | 2597 (and (sql-buffer-live-p buf prod) |
2585 (let ((buflist (buffer-list)) | 2598 buf) |
2586 (found)) | 2599 ;; Global sql-buffer |
2587 (while (not (or (null buflist) | 2600 (and (setq buf (default-value 'sql-buffer)) |
2588 found)) | 2601 (sql-buffer-live-p buf prod) |
2589 (let ((candidate (car buflist))) | 2602 buf) |
2590 (set-buffer candidate) | 2603 ;; Look thru each buffer |
2591 (if (and (sql-buffer-live-p candidate) | 2604 (car (apply 'append |
2592 (derived-mode-p 'sql-interactive-mode) | 2605 (mapcar (lambda (b) |
2593 (eq sql-product current-product)) | 2606 (and (sql-buffer-live-p b prod) |
2594 (setq found (buffer-name candidate))) | 2607 (list (buffer-name b)))) |
2595 (setq buflist (cdr buflist)))) | 2608 (buffer-list))))))) |
2596 found))))) | |
2597 | 2609 |
2598 (defun sql-set-sqli-buffer-generally () | 2610 (defun sql-set-sqli-buffer-generally () |
2599 "Set SQLi buffer for all SQL buffers that have none. | 2611 "Set SQLi buffer for all SQL buffers that have none. |
2600 This function checks all SQL buffers for their SQLi buffer. If their | 2612 This function checks all SQL buffers for their SQLi buffer. If their |
2601 SQLi buffer is nonexistent or has no process, it is set to the current | 2613 SQLi buffer is nonexistent or has no process, it is set to the current |
2609 (setq-default sql-buffer default-buffer) | 2621 (setq-default sql-buffer default-buffer) |
2610 (while (not (null buflist)) | 2622 (while (not (null buflist)) |
2611 (let ((candidate (car buflist))) | 2623 (let ((candidate (car buflist))) |
2612 (set-buffer candidate) | 2624 (set-buffer candidate) |
2613 (if (and (derived-mode-p 'sql-mode) | 2625 (if (and (derived-mode-p 'sql-mode) |
2614 (not (buffer-live-p sql-buffer))) | 2626 (not (sql-buffer-live-p sql-buffer))) |
2615 (progn | 2627 (progn |
2616 (setq sql-buffer default-buffer) | 2628 (setq sql-buffer default-buffer) |
2617 (run-hooks 'sql-set-sqli-hook)))) | 2629 (when default-buffer |
2630 (run-hooks 'sql-set-sqli-hook))))) | |
2618 (setq buflist (cdr buflist)))))) | 2631 (setq buflist (cdr buflist)))))) |
2619 | 2632 |
2620 (defun sql-set-sqli-buffer () | 2633 (defun sql-set-sqli-buffer () |
2621 "Set the SQLi buffer SQL strings are sent to. | 2634 "Set the SQLi buffer SQL strings are sent to. |
2622 | 2635 |
2630 If you call it from anywhere else, it sets the global copy of | 2643 If you call it from anywhere else, it sets the global copy of |
2631 `sql-buffer'." | 2644 `sql-buffer'." |
2632 (interactive) | 2645 (interactive) |
2633 (let ((default-buffer (sql-find-sqli-buffer))) | 2646 (let ((default-buffer (sql-find-sqli-buffer))) |
2634 (if (null default-buffer) | 2647 (if (null default-buffer) |
2635 (error "There is no suitable SQLi buffer")) | 2648 (error "There is no suitable SQLi buffer") |
2636 (let ((new-buffer | 2649 (let ((new-buffer (read-buffer "New SQLi buffer: " default-buffer t))) |
2637 (get-buffer | 2650 (if (null (sql-buffer-live-p new-buffer)) |
2638 (read-buffer "New SQLi buffer: " default-buffer t)))) | 2651 (error "Buffer %s is not a working SQLi buffer" new-buffer) |
2639 (if (null (get-buffer-process new-buffer)) | 2652 (when new-buffer |
2640 (error "Buffer %s has no process" (buffer-name new-buffer))) | 2653 (setq sql-buffer new-buffer) |
2641 (if (null (with-current-buffer new-buffer | 2654 (run-hooks 'sql-set-sqli-hook))))))) |
2642 (derived-mode-p 'sql-interactive-mode))) | |
2643 (error "Buffer %s is no SQLi buffer" (buffer-name new-buffer))) | |
2644 (if new-buffer | |
2645 (progn | |
2646 (setq sql-buffer (buffer-name new-buffer)) | |
2647 (run-hooks 'sql-set-sqli-hook)))))) | |
2648 | 2655 |
2649 (defun sql-show-sqli-buffer () | 2656 (defun sql-show-sqli-buffer () |
2650 "Show the name of current SQLi buffer. | 2657 "Show the name of current SQLi buffer. |
2651 | 2658 |
2652 This is the buffer SQL strings are sent to. It is stored in the | 2659 This is the buffer SQL strings are sent to. It is stored in the |
2740 (interactive "P") | 2747 (interactive "P") |
2741 | 2748 |
2742 (if (not (derived-mode-p 'sql-interactive-mode)) | 2749 (if (not (derived-mode-p 'sql-interactive-mode)) |
2743 (message "Current buffer is not a SQL interactive buffer") | 2750 (message "Current buffer is not a SQL interactive buffer") |
2744 | 2751 |
2745 (cond | 2752 (setq sql-alternate-buffer-name |
2746 ((stringp new-name) | 2753 (cond |
2747 (setq sql-alternate-buffer-name new-name)) | 2754 ((stringp new-name) new-name) |
2748 ((listp new-name) | 2755 ((consp new-name) |
2749 (setq sql-alternate-buffer-name | |
2750 (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " | 2756 (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " |
2751 sql-alternate-buffer-name)))) | 2757 sql-alternate-buffer-name)) |
2758 (t sql-alternate-buffer-name))) | |
2752 | 2759 |
2753 (rename-buffer (if (string= "" sql-alternate-buffer-name) | 2760 (rename-buffer (if (string= "" sql-alternate-buffer-name) |
2754 "*SQL*" | 2761 "*SQL*" |
2755 (format "*SQL: %s*" sql-alternate-buffer-name)) | 2762 (format "*SQL: %s*" sql-alternate-buffer-name)) |
2756 t))) | 2763 t))) |
2989 (interactive "P") | 2996 (interactive "P") |
2990 (if value | 2997 (if value |
2991 (setq sql-pop-to-buffer-after-send-region value) | 2998 (setq sql-pop-to-buffer-after-send-region value) |
2992 (setq sql-pop-to-buffer-after-send-region | 2999 (setq sql-pop-to-buffer-after-send-region |
2993 (null sql-pop-to-buffer-after-send-region)))) | 3000 (null sql-pop-to-buffer-after-send-region)))) |
3001 | |
3002 | |
3003 | |
3004 ;;; Redirect output functions | |
3005 | |
3006 (defun sql-redirect (command combuf &optional outbuf save-prior) | |
3007 "Execute the SQL command and send output to OUTBUF. | |
3008 | |
3009 COMBUF must be an active SQL interactive buffer. OUTBUF may be | |
3010 an existing buffer, or the name of a non-existing buffer. If | |
3011 omitted the output is sent to a temporary buffer which will be | |
3012 killed after the command completes. COMMAND should be a string | |
3013 of commands accepted by the SQLi program." | |
3014 | |
3015 (with-current-buffer combuf | |
3016 (let ((buf (get-buffer-create (or outbuf " *SQL-Redirect*"))) | |
3017 (proc (get-buffer-process (current-buffer))) | |
3018 (comint-prompt-regexp (sql-get-product-feature sql-product | |
3019 :prompt-regexp)) | |
3020 (start nil)) | |
3021 (with-current-buffer buf | |
3022 (unless save-prior | |
3023 (erase-buffer)) | |
3024 (goto-char (point-max)) | |
3025 (setq start (point))) | |
3026 | |
3027 ;; Run the command | |
3028 (comint-redirect-send-command-to-process command buf proc nil t) | |
3029 (while (null comint-redirect-completed) | |
3030 (accept-process-output nil 1)) | |
3031 | |
3032 ;; Remove echo if there was one | |
3033 (with-current-buffer buf | |
3034 (goto-char start) | |
3035 (when (looking-at (concat "^" (regexp-quote command) "[\\n]")) | |
3036 (delete-region (match-beginning 0) (match-end 0))) | |
3037 (goto-char start))))) | |
3038 | |
3039 (defun sql-redirect-value (command combuf regexp &optional regexp-groups) | |
3040 "Execute the SQL command and return part of result. | |
3041 | |
3042 COMBUF must be an active SQL interactive buffer. COMMAND should | |
3043 be a string of commands accepted by the SQLi program. From the | |
3044 output, the REGEXP is repeatedly matched and the list of | |
3045 REGEXP-GROUPS submatches is returned. This behaves much like | |
3046 \\[comint-redirect-results-list-from-process] but instead of | |
3047 returning a single submatch it returns a list of each submatch | |
3048 for each match." | |
3049 | |
3050 (let ((outbuf " *SQL-Redirect-values*") | |
3051 (results nil)) | |
3052 (sql-redirect command combuf outbuf nil) | |
3053 (with-current-buffer outbuf | |
3054 (while (re-search-forward regexp nil t) | |
3055 (push | |
3056 (cond | |
3057 ;; no groups-return all of them | |
3058 ((null regexp-groups) | |
3059 (let ((i 1) | |
3060 (r nil)) | |
3061 (while (match-beginning i) | |
3062 (push (match-string i) r)) | |
3063 (nreverse r))) | |
3064 ;; one group specified | |
3065 ((numberp regexp-groups) | |
3066 (match-string regexp-groups)) | |
3067 ;; (buffer-substring-no-properties | |
3068 ;; (match-beginning regexp-groups) | |
3069 ;; (match-end regexp-groups))) | |
3070 ;; list of numbers; return the specified matches only | |
3071 ((consp regexp-groups) | |
3072 (mapcar (lambda (c) | |
3073 (cond | |
3074 ((numberp c) (match-string c)) | |
3075 ((stringp c) (match-substitute-replacement c)) | |
3076 (t (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" c)))) | |
3077 regexp-groups)) | |
3078 ;; String is specified; return replacement string | |
3079 ((stringp regexp-groups) | |
3080 (match-substitute-replacement regexp-groups)) | |
3081 (t | |
3082 (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" | |
3083 regexp-groups))) | |
3084 results))) | |
3085 (nreverse results))) | |
2994 | 3086 |
2995 | 3087 |
2996 | 3088 |
2997 ;;; SQL mode -- uses SQL interactive mode | 3089 ;;; SQL mode -- uses SQL interactive mode |
2998 | 3090 |
3363 \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" | 3455 \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" |
3364 (interactive "P") | 3456 (interactive "P") |
3365 | 3457 |
3366 ;; Handle universal arguments if specified | 3458 ;; Handle universal arguments if specified |
3367 (when (not (or executing-kbd-macro noninteractive)) | 3459 (when (not (or executing-kbd-macro noninteractive)) |
3368 (when (and (listp product) | 3460 (when (and (consp product) |
3369 (not (cdr product)) | 3461 (not (cdr product)) |
3370 (numberp (car product))) | 3462 (numberp (car product))) |
3371 (when (>= (car product) 16) | 3463 (when (>= (car product) 16) |
3372 (when (not new-name) | 3464 (when (not new-name) |
3373 (setq new-name '(4))) | 3465 (setq new-name '(4))) |
3392 (if product | 3484 (if product |
3393 (when (sql-get-product-feature product :sqli-comint-func) | 3485 (when (sql-get-product-feature product :sqli-comint-func) |
3394 ;; If no new name specified, fall back on sql-buffer if its for | 3486 ;; If no new name specified, fall back on sql-buffer if its for |
3395 ;; the same product | 3487 ;; the same product |
3396 (if (and (not new-name) | 3488 (if (and (not new-name) |
3397 sql-buffer | 3489 (sql-buffer-live-p sql-buffer product)) |
3398 (sql-buffer-live-p sql-buffer) | |
3399 (comint-check-proc sql-buffer) | |
3400 (eq product (with-current-buffer sql-buffer sql-product))) | |
3401 (pop-to-buffer sql-buffer) | 3490 (pop-to-buffer sql-buffer) |
3402 | 3491 |
3403 ;; We have a new name or sql-buffer doesn't exist or match | 3492 ;; We have a new name or sql-buffer doesn't exist or match |
3404 ;; Start by remembering where we start | 3493 ;; Start by remembering where we start |
3405 (let* ((start-buffer (current-buffer)) | 3494 (let* ((start-buffer (current-buffer)) |
3421 | 3510 |
3422 ;; Set the new buffer name | 3511 ;; Set the new buffer name |
3423 (when new-name | 3512 (when new-name |
3424 (sql-rename-buffer new-name)) | 3513 (sql-rename-buffer new-name)) |
3425 | 3514 |
3426 ;; Set `sql-buffer' in the start buffer | 3515 ;; Set `sql-buffer' in the new buffer and the start buffer |
3427 (setq sql-buffer (buffer-name new-sqli-buffer)) | 3516 (setq sql-buffer (buffer-name new-sqli-buffer)) |
3428 (with-current-buffer start-buffer | 3517 (with-current-buffer start-buffer |
3429 (setq sql-buffer (buffer-name new-sqli-buffer))) | 3518 (setq sql-buffer (buffer-name new-sqli-buffer)) |
3519 (run-hooks 'sql-set-sqli-hook)) | |
3430 | 3520 |
3431 ;; All done. | 3521 ;; All done. |
3432 (message "Login...done") | 3522 (message "Login...done") |
3433 (pop-to-buffer sql-buffer)))) | 3523 (pop-to-buffer sql-buffer)))) |
3434 (message "No default SQL product defined. Set `sql-product'."))) | 3524 (message "No default SQL product defined. Set `sql-product'."))) |