Now on revision 105012. ------------------------------------------------------------ revno: 105012 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Thu 2011-07-07 13:59:05 +0200 message: Mention the `send-mail-function' default change. diff: === modified file 'etc/ChangeLog' --- etc/ChangeLog 2011-07-07 11:18:17 +0000 +++ etc/ChangeLog 2011-07-07 11:59:05 +0000 @@ -1,6 +1,7 @@ 2011-07-07 Lars Magne Ingebrigtsen * NEWS: Clarify `smtpmail-auth-credentials' non-existence. + Mention the `send-mail-function' default change. 2011-07-07 Chong Yidong === modified file 'etc/NEWS' --- etc/NEWS 2011-07-07 11:18:17 +0000 +++ etc/NEWS 2011-07-07 11:59:05 +0000 @@ -117,14 +117,22 @@ ** auto-mode-case-fold is now enabled by default. +** Mail changes + +The default of `send-mail-function' has changed from +`sendmail-send-it' (on GNU/Linux and other Unix-like systems) or +`mailclient-send-it' (on Windows) to `sendmail-query-once'. This new +default will ask the user (once) whether to use the internal smtpmail +package to send email, or to use the old, external defaults. + ** smtpmail changes -** smtpmail has been largely rewritten to upgrade to STARTTLS if +*** smtpmail has been largely rewritten to upgrade to STARTTLS if possible, and uses the auth-source framework for getting credentials. The rewrite should be largely compatible with previous versions of smtpmail, but there are two major incompatibilities: -** `smtpmail-auth-credentials' no longer exists. That variable used +*** `smtpmail-auth-credentials' no longer exists. That variable used to be be either ~/.authinfo (in which case you won't see any difference), but if it were a direct list of user names and passwords, it will be ignored, and you will be prompted for the user name and the @@ -143,7 +151,7 @@ machine mail.example.org port 25 login jim password s!cret -** Similarly, `smtpmail-starttls-credentials' no longer exists. If +*** Similarly, `smtpmail-starttls-credentials' no longer exists. If you had that set, then then you need to put machine smtp.whatever.foo port 25 key "~/.my_smtp_tls.key" cert ------------------------------------------------------------ revno: 105011 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Thu 2011-07-07 13:18:17 +0200 message: * NEWS: Clarify `smtpmail-auth-credentials' non-existence. diff: === modified file 'etc/ChangeLog' --- etc/ChangeLog 2011-07-07 01:48:14 +0000 +++ etc/ChangeLog 2011-07-07 11:18:17 +0000 @@ -1,3 +1,7 @@ +2011-07-07 Lars Magne Ingebrigtsen + + * NEWS: Clarify `smtpmail-auth-credentials' non-existence. + 2011-07-07 Chong Yidong * themes/dichromacy-theme.el: === modified file 'etc/NEWS' --- etc/NEWS 2011-07-06 16:50:34 +0000 +++ etc/NEWS 2011-07-07 11:18:17 +0000 @@ -124,16 +124,30 @@ The rewrite should be largely compatible with previous versions of smtpmail, but there are two major incompatibilities: -** `smtpmail-auth-credentials' no longer exists. That variable could -be either ~/.authinfo (in which case you're fine -- you won't see any +** `smtpmail-auth-credentials' no longer exists. That variable used +to be be either ~/.authinfo (in which case you won't see any difference), but if it were a direct list of user names and passwords, -you will be prompted for the user name and the password instead, and -they will then be saved to ~/.authinfo. +it will be ignored, and you will be prompted for the user name and the +password instead. They will then be saved to ~/.authinfo. + +If you wish to copy over all the credentials from +`smtpmail-auth-credentials' to your ~/.authinfo file manually, instead +of letting smtpmail prompt you for these values, that's also possible. + +If you had, for instance, + +(setq smtpmail-auth-credentials + '(("mail.example.org" 25 "jim" "s!cret"))) + +then the equivalent line in ~/.authinfo would be + +machine mail.example.org port 25 login jim password s!cret ** Similarly, `smtpmail-starttls-credentials' no longer exists. If -you had thet set, then then you need to put +you had that set, then then you need to put -machine smtp.whatever.foo port 25 key "~/.my_smtp_tls.key" cert "~/.my_smtp_tls.cert" +machine smtp.whatever.foo port 25 key "~/.my_smtp_tls.key" cert +"~/.my_smtp_tls.cert" in your ~/.authinfo file instead. ------------------------------------------------------------ revno: 105010 committer: Richard Stallman branch nick: trunk timestamp: Thu 2011-07-07 06:35:43 -0400 message: Fix bugs finding grep hits in Rmail buffers. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-07 04:20:12 +0000 +++ lisp/ChangeLog 2011-07-07 10:35:43 +0000 @@ -1,3 +1,11 @@ +2011-07-07 Richard Stallman + + * mail/rmail.el (rmail-next-error-move): Use `compilation-message' + property, and handle its changed format. + Look for the correct line number. + Use file's line contents (but not past first =) to find + correct line in message. + 2011-07-07 Kenichi Handa * international/characters.el (build-unicode-category-table): === modified file 'lisp/mail/rmail.el' --- lisp/mail/rmail.el 2011-07-07 04:20:12 +0000 +++ lisp/mail/rmail.el 2011-07-07 10:35:43 +0000 @@ -3025,9 +3025,13 @@ MSG-POS is a marker pointing at the error message in the grep buffer. BAD-MARKER is a marker that ought to point at where to move to, but probably is garbage." - (let* ((message (car (get-text-property msg-pos 'message (marker-buffer msg-pos)))) - (column (car message)) - (linenum (cadr message)) + + (let* ((message-loc (compilation--message->loc + (get-text-property msg-pos 'compilation-message + (marker-buffer msg-pos)))) + (column (car message-loc)) + (linenum (cadr message-loc)) + line-text pos msgnum msgbeg msgend header-field @@ -3041,10 +3045,18 @@ (save-excursion ;; Find the line that the error message points at. (goto-char (point-min)) - (forward-line linenum) + (forward-line (1- linenum)) (setq pos (point)) - ;; Find which message that's in, + ;; Find the text at the start of the line, + ;; before the first = sign. + ;; This text has a good chance of being also in the + ;; decoded message. + (save-excursion + (skip-chars-forward "^=\n") + (setq line-text (buffer-substring pos (point)))) + + ;; Find which message this position is in, ;; and the limits of that message. (setq msgnum (rmail-what-message pos)) (setq msgbeg (rmail-msgbeg msgnum)) @@ -3071,11 +3083,23 @@ (rmail-show-message msgnum) ;; Move to the right position within the displayed message. + ;; Or at least try. The decoded message's lines may not + ;; correspond to the lines in the inbox file. + (goto-char (point-min)) (if header-field - (re-search-forward (concat "^" (regexp-quote header-field)) nil t) - (search-forward "\n\n" nil t)) - (forward-line line-number-within) - (forward-char column))) + (progn + (re-search-forward (concat "^" (regexp-quote header-field)) nil t) + (forward-line line-number-within)) + (search-forward "\n\n" nil t) + (if (re-search-forward (concat "^" (regexp-quote line-text)) nil t) + (goto-char (match-beginning 0)))) + (if (eobp) + ;; If the decoded message doesn't have enough lines, + ;; go to the beginning rather than the end. + (goto-char (point-min)) + ;; Otherwise, go to the right column. + (if column + (forward-char column))))) (defun rmail-what-message (&optional pos) "Return message number POS (or point) is in." ------------------------------------------------------------ revno: 105009 committer: Glenn Morris branch nick: trunk timestamp: Thu 2011-07-07 06:19:23 -0400 message: Auto-commit of generated files. diff: === modified file 'autogen/config.in' --- autogen/config.in 2011-07-01 10:19:04 +0000 +++ autogen/config.in 2011-07-07 10:19:23 +0000 @@ -1038,9 +1038,9 @@ /* If using the C implementation of alloca, define if you know the direction of stack growth for your system; otherwise it will be automatically deduced at runtime. - STACK_DIRECTION > 0 => grows toward higher addresses - STACK_DIRECTION < 0 => grows toward lower addresses - STACK_DIRECTION = 0 => direction of growth unknown */ + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown */ #undef STACK_DIRECTION /* Define to 1 if the `S_IS*' macros in do not work properly. */ === modified file 'autogen/configure' --- autogen/configure 2011-07-05 10:19:43 +0000 +++ autogen/configure 2011-07-07 10:19:23 +0000 @@ -4478,7 +4478,7 @@ ## Silicon Graphics machines ## Iris 4D mips-sgi-irix6.5 ) - machine=iris4d opsys=irix6-5 + opsys=irix6-5 # Without defining _LANGUAGE_C, things get masked out in the headers # so that, for instance, grepping for `free' in stdlib.h fails and # AC_HEADER_STD_C fails. (MIPSPro 7.2.1.2m compilers, Irix 6.5.3m). ------------------------------------------------------------ revno: 105008 committer: Daiki Ueno branch nick: trunk timestamp: Thu 2011-07-07 18:20:37 +0900 message: Add a major mode to edit plstore files. * plstore.el: Add documentation. (plstore-mode): New mode to edit plstore file. (plstore-mode-toggle-display, plstore-mode-original) (plstore-mode-decoded): New command. (plstore--encode, plstore--decode, plstore--write-contents-functions) (plstore--insert-buffer, plstore--make): New function. (plstore-open, plstore-save): Simplify by using them. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-07-06 22:39:47 +0000 +++ lisp/gnus/ChangeLog 2011-07-07 09:20:37 +0000 @@ -1,3 +1,13 @@ +2011-07-07 Daiki Ueno + + * plstore.el: Add documentation. + (plstore-mode): New mode to edit plstore file. + (plstore-mode-toggle-display, plstore-mode-original) + (plstore-mode-decoded): New command. + (plstore--encode, plstore--decode, plstore--write-contents-functions) + (plstore--insert-buffer, plstore--make): New function. + (plstore-open, plstore-save): Simplify by using them. + 2011-07-06 Glenn Morris * gnus-group.el (gnus-read-ephemeral-emacs-bug-group): Silence compiler. === modified file 'lisp/gnus/plstore.el' --- lisp/gnus/plstore.el 2011-07-01 07:35:39 +0000 +++ lisp/gnus/plstore.el 2011-07-07 09:20:37 +0000 @@ -1,4 +1,4 @@ -;;; plstore.el --- searchable, partially encrypted, persistent plist store -*- lexical-binding: t -*- +;;; plstore.el --- secure plist store -*- lexical-binding: t -*- ;; Copyright (C) 2011 Free Software Foundation, Inc. ;; Author: Daiki Ueno @@ -21,24 +21,61 @@ ;;; Commentary +;; Plist based data store providing search and partial encryption. +;; ;; Creating: ;; +;; ;; Open a new store associated with ~/.emacs.d/auth.plist. ;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist"))) +;; ;; Both `:host' and `:port' are public property. ;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil) +;; ;; No encryption will be needed. ;; (plstore-save store) -;; ;; :user property is secret +;; +;; ;; `:user' is marked as secret. ;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test")) -;; (plstore-put store "baz" '(:host "baz.example.org") '(:user "test")) -;; (plstore-save store) ;<= will ask passphrase via GPG +;; ;; `:password' is marked as secret. +;; (plstore-put store "baz" '(:host "baz.example.org") '(:password "test")) +;; ;; Those secret properties are encrypted together. +;; (plstore-save store) +;; +;; ;; Kill the buffer visiting ~/.emacs.d/auth.plist. ;; (plstore-close store) ;; ;; Searching: ;; ;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist"))) +;; +;; ;; As the entry "foo" associated with "foo.example.org" has no +;; ;; secret properties, no need to decryption. ;; (plstore-find store '(:host ("foo.example.org"))) -;; (plstore-find store '(:host ("bar.example.org"))) ;<= will ask passphrase via GPG +;; +;; ;; As the entry "bar" associated with "bar.example.org" has a +;; ;; secret property `:user', Emacs tries to decrypt the secret (and +;; ;; thus you will need to input passphrase). +;; (plstore-find store '(:host ("bar.example.org"))) +;; +;; ;; While the entry "baz" associated with "baz.example.org" has also +;; ;; a secret property `:password', it is encrypted together with +;; ;; `:user' of "bar", so no need to decrypt the secret. +;; (plstore-find store '(:host ("bar.example.org"))) +;; ;; (plstore-close store) ;; +;; Editing: +;; +;; This file also provides `plstore-mode', a major mode for editing +;; the PLSTORE format file. Visit a non-existing file and put the +;; following line: +;; +;; (("foo" :host "foo.example.org" :secret-user "user")) +;; +;; where the prefixing `:secret-' means the property (without +;; `:secret-' prefix) is marked as secret. Thus, when you save the +;; buffer, the `:secret-user' property is encrypted as `:user'. +;; +;; You can toggle the view between encrypted form and the decrypted +;; form with C-c C-c. ;;; Code: @@ -78,6 +115,10 @@ (put 'plstore-encrypt-to 'permanent-local t) +(defvar plstore-encoded nil) + +(put 'plstore-encoded 'permanent-local t) + (defvar plstore-cache-passphrase-for-symmetric-encryption nil) (defvar plstore-passphrase-alist nil) @@ -123,8 +164,8 @@ (defun plstore--get-merged-alist (this) (aref this 4)) -(defun plstore--set-file (this file) - (aset this 0 file)) +(defun plstore--set-buffer (this buffer) + (aset this 0 buffer)) (defun plstore--set-alist (this plist) (aset this 1 plist)) @@ -141,6 +182,10 @@ (defun plstore-get-file (this) (buffer-file-name (plstore--get-buffer this))) +(defun plstore--make (&optional buffer alist encrypted-data secret-alist + merged-alist) + (vector buffer alist encrypted-data secret-alist merged-alist)) + (defun plstore--init-from-buffer (plstore) (goto-char (point-min)) (when (looking-at ";;; public entries") @@ -156,16 +201,17 @@ ;;;###autoload (defun plstore-open (file) "Create a plstore instance associated with FILE." - (with-current-buffer (find-file-noselect file) - ;; make the buffer invisible from user - (rename-buffer (format " plstore %s" (buffer-file-name))) - (let ((store (vector - (current-buffer) - nil ;plist (plist) - nil ;encrypted data (string) - nil ;secret plist (plist) - nil ;merged plist (plist) - ))) + (let* ((filename (file-truename file)) + (buffer (or (find-buffer-visiting filename) + (generate-new-buffer (format " plstore %s" filename)))) + (store (plstore--make buffer))) + (with-current-buffer buffer + (erase-buffer) + (condition-case nil + (insert-file-contents-literally file) + (error)) + (setq buffer-file-name (file-truename file)) + (set-buffer-modified-p nil) (plstore--init-from-buffer store) store))) @@ -356,44 +402,160 @@ (delq entry (plstore--get-merged-alist plstore)))))) (defvar pp-escape-newlines) +(defun plstore--insert-buffer (plstore) + (insert ";;; public entries -*- mode: plstore -*- \n" + (pp-to-string (plstore--get-alist plstore))) + (if (plstore--get-secret-alist plstore) + (let ((context (epg-make-context 'OpenPGP)) + (pp-escape-newlines nil) + (recipients + (cond + ((listp plstore-encrypt-to) plstore-encrypt-to) + ((stringp plstore-encrypt-to) (list plstore-encrypt-to)))) + cipher) + (epg-context-set-armor context t) + (epg-context-set-passphrase-callback + context + (cons #'plstore-passphrase-callback-function + plstore)) + (setq cipher (epg-encrypt-string + context + (pp-to-string + (plstore--get-secret-alist plstore)) + (if (or (eq plstore-select-keys t) + (and (null plstore-select-keys) + (not (local-variable-p 'plstore-encrypt-to + (current-buffer))))) + (epa-select-keys + context + "Select recipents for encryption. +If no one is selected, symmetric encryption will be performed. " + recipients) + (if plstore-encrypt-to + (epg-list-keys context recipients))))) + (goto-char (point-max)) + (insert ";;; secret entries\n" (pp-to-string cipher))))) + (defun plstore-save (plstore) "Save the contents of PLSTORE associated with a FILE." (with-current-buffer (plstore--get-buffer plstore) (erase-buffer) - (insert ";;; public entries -*- mode: emacs-lisp -*- \n" - (pp-to-string (plstore--get-alist plstore))) - (if (plstore--get-secret-alist plstore) - (let ((context (epg-make-context 'OpenPGP)) - (pp-escape-newlines nil) - (recipients - (cond - ((listp plstore-encrypt-to) plstore-encrypt-to) - ((stringp plstore-encrypt-to) (list plstore-encrypt-to)))) - cipher) - (epg-context-set-armor context t) - (epg-context-set-passphrase-callback - context - (cons #'plstore-passphrase-callback-function - plstore)) - (setq cipher (epg-encrypt-string - context - (pp-to-string - (plstore--get-secret-alist plstore)) - (if (or (eq plstore-select-keys t) - (and (null plstore-select-keys) - (not (local-variable-p 'plstore-encrypt-to - (current-buffer))))) - (epa-select-keys - context - "Select recipents for encryption. -If no one is selected, symmetric encryption will be performed. " - recipients) - (if plstore-encrypt-to - (epg-list-keys context recipients))))) - (goto-char (point-max)) - (insert ";;; secret entries\n" (pp-to-string cipher)))) + (plstore--insert-buffer plstore) (save-buffer))) +(defun plstore--encode (plstore) + (plstore--decrypt plstore) + (let ((merged-alist (plstore--get-merged-alist plstore))) + (concat "(" + (mapconcat + (lambda (entry) + (setq entry (copy-sequence entry)) + (let ((merged-plist (cdr (assoc (car entry) merged-alist))) + (plist (cdr entry))) + (while plist + (if (string-match "\\`:secret-" (symbol-name (car plist))) + (setcar (cdr plist) + (plist-get + merged-plist + (intern (concat ":" + (substring (symbol-name + (car plist)) + (match-end 0))))))) + (setq plist (nthcdr 2 plist))) + (prin1-to-string entry))) + (plstore--get-alist plstore) + "\n") + ")"))) + +(defun plstore--decode (string) + (let* ((alist (car (read-from-string string))) + (pointer alist) + secret-alist + plist + entry) + (while pointer + (unless (stringp (car (car pointer))) + (error "Invalid PLSTORE format %s" string)) + (setq plist (cdr (car pointer))) + (while plist + (when (string-match "\\`:secret-" (symbol-name (car plist))) + (setq entry (assoc (car (car pointer)) secret-alist)) + (unless entry + (setq entry (list (car (car pointer))) + secret-alist (cons entry secret-alist))) + (setcdr entry (plist-put (cdr entry) + (intern (concat ":" + (substring (symbol-name + (car plist)) + (match-end 0)))) + (car (cdr plist)))) + (setcar (cdr plist) t)) + (setq plist (nthcdr 2 plist))) + (setq pointer (cdr pointer))) + (plstore--make nil alist nil secret-alist))) + +(defun plstore--write-contents-functions () + (when plstore-encoded + (let ((store (plstore--decode (buffer-string))) + (file (buffer-file-name))) + (unwind-protect + (progn + (set-visited-file-name nil) + (with-temp-buffer + (plstore--insert-buffer store) + (write-region (buffer-string) nil file))) + (set-visited-file-name file) + (set-buffer-modified-p nil)) + t))) + +(defun plstore-mode-original () + "Show the original form of the this buffer." + (interactive) + (when plstore-encoded + (if (and (buffer-modified-p) + (y-or-n-p "Save buffer before reading the original form? ")) + (save-buffer)) + (erase-buffer) + (insert-file-contents-literally (buffer-file-name)) + (set-buffer-modified-p nil) + (setq plstore-encoded nil))) + +(defun plstore-mode-decoded () + "Show the decoded form of the this buffer." + (interactive) + (unless plstore-encoded + (if (and (buffer-modified-p) + (y-or-n-p "Save buffer before decoding? ")) + (save-buffer)) + (let ((store (plstore--make (current-buffer)))) + (plstore--init-from-buffer store) + (erase-buffer) + (insert + (substitute-command-keys "\ +;;; You are looking at the decoded form of the PLSTORE file.\n\ +;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n")) + (insert (plstore--encode store)) + (set-buffer-modified-p nil) + (setq plstore-encoded t)))) + +(defun plstore-mode-toggle-display () + "Toggle the display mode of PLSTORE between the original and decoded forms." + (interactive) + (if plstore-encoded + (plstore-mode-original) + (plstore-mode-decoded))) + +;;;###autoload +(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE" + "Major mode for editing PLSTORE files." + (make-local-variable 'plstore-encoded) + (add-hook 'write-contents-functions #'plstore--write-contents-functions) + (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display) + ;; to create a new file with plstore-mode, mark it as already decoded + (if (called-interactively-p 'any) + (setq plstore-encoded t) + (plstore-mode-decoded))) + (provide 'plstore) ;;; plstore.el ends here ------------------------------------------------------------ revno: 105007 [merge] committer: Kenichi Handa branch nick: trunk timestamp: Thu 2011-07-07 13:21:49 +0900 message: Add C interface for Unicode character property table. diff: === modified file 'admin/ChangeLog' --- admin/ChangeLog 2011-05-21 21:19:30 +0000 +++ admin/ChangeLog 2011-07-06 22:43:48 +0000 @@ -1,3 +1,38 @@ +2011-07-06 Kenichi Handa + + * unidata/unidata-gen.el (unidata-dir): New variable. + (unidata-setup-list): Expand unidata-text-file in unidata-dir. + (unidata-prop-alist): INDEX element may be a function. New + optional element VAL-LIST (for general-category and bidi-class). + New entry `mirroring'. + (unidata-prop-default, unidata-prop-val-list): New subst. + (unidata-get-character, unidata-put-character): Delete them. + (unidata-gen-table-character): New arg IGNORE. Adjusted for the + above changes. + (unidata-get-symbol, unidata-get-integer, unidata-get-numeric) + (unidata-put-symbol, unidata-put-integer, unidata-put-numeric): + Delete them. + (unidata-encode-val): Assume that the first element of VAL-LIST is + a cons (nil . 0). + (unidata-gen-table): Change argument DEFAULT-VALUE to VAL-LIST. + Always store the encoded value. + (unidata-gen-table-symbol): New args DEFAULT-VALUE and VAL-LIST. + Set the 1st and the 2nd extra slots to index numbers for C + functions. + (unidata-gen-table-integer): Likewise. + (unidata-gen-table-numeric): Likewise. + (unidata-gen-table-name): New arg IGNORE. + (unidata-gen-table-decomposition): Likewise. + (unidata-describe-general-category): Add the case nil to the + description alist. + (unidata-gen-mirroring-list): New funciton. + (unidata-gen-files): New arg DATA-DIR. Adjusted for the change of + unidata-prop-alist. Handle the case of storing multiple + char-tables in a file. + + * unidata/Makefile.in (${DSTDIR}/charprop.el): New arg to + unidata-gen-files. + 2011-05-21 Glenn Morris * bzrmerge.el (bzrmerge-resolve): Suppress prompts about file-locals. === modified file 'admin/unidata/Makefile.in' --- admin/unidata/Makefile.in 2011-01-14 17:18:41 +0000 +++ admin/unidata/Makefile.in 2011-07-06 22:43:48 +0000 @@ -33,9 +33,10 @@ ${DSTDIR}/charprop.el: unidata-gen.elc unidata.txt ELC=`/bin/pwd`/unidata-gen.elc; \ - DATA=`/bin/pwd`/unidata.txt; \ + DATADIR=`/bin/pwd`; \ + DATA=unidata.txt; \ cd ${DSTDIR}; \ - ${RUNEMACS} -batch --load $${ELC} -f unidata-gen-files $${DATA} + ${RUNEMACS} -batch --load $${ELC} -f unidata-gen-files $${DATADIR} $${DATA} ../../src/biditype.h: UnicodeData.txt gawk -F";" -f biditype.awk $< > $@ === modified file 'admin/unidata/unidata-gen.el' --- admin/unidata/unidata-gen.el 2011-01-14 17:18:41 +0000 +++ admin/unidata/unidata-gen.el 2011-07-06 22:43:48 +0000 @@ -33,24 +33,25 @@ ;; ;; charprop.el ;; It contains a series of forms of this format: -;; (char-code-property-register PROP FILE) +;; (define-char-code-property PROP FILE) ;; where PROP is a symbol representing a character property -;; (name, generic-category, etc), and FILE is a name of one of +;; (name, general-category, etc), and FILE is a name of one of ;; the following files. ;; ;; uni-name.el, uni-category.el, uni-combining.el, uni-bidi.el, ;; uni-decomposition.el, uni-decimal.el, uni-digit.el, uni-numeric.el, ;; uni-mirrored.el, uni-old-name.el, uni-comment.el, uni-uppercase.el, ;; uni-lowercase.el, uni-titlecase.el -;; They each contain a single form of this format: -;; (char-code-property-register PROP CHAR-TABLE) +;; They contain one or more forms of this format: +;; (define-char-code-property PROP CHAR-TABLE) ;; where PROP is the same as above, and CHAR-TABLE is a ;; char-table containing property values in a compressed format. ;; ;; When they are installed in .../lisp/international/, the file ;; "charprop.el" is preloaded in loadup.el. The other files are -;; automatically loaded when the functions `get-char-code-property' -;; and `put-char-code-property' are called. +;; automatically loaded when the Lisp functions +;; `get-char-code-property' and `put-char-code-property', and C +;; function uniprop_table are called. ;; ;; FORMAT OF A CHAR TABLE ;; @@ -62,17 +63,22 @@ ;; data in a char-table as below. ;; ;; If succeeding 128*N characters have the same property value, we -;; store that value for them. Otherwise, compress values for -;; succeeding 128 characters into a single string and store it as a -;; value for those characters. The way of compression depends on a -;; property. See the section "SIMPLE TABLE", "RUN-LENGTH TABLE", -;; and "WORD-LIST TABLE". +;; store that value (or the encoded one) for them. Otherwise, +;; compress values (or the encoded ones) for succeeding 128 +;; characters into a single string and store it for those +;; characters. The way of compression depends on a property. See +;; the section "SIMPLE TABLE", "RUN-LENGTH TABLE", and "WORD-LIST +;; TABLE". -;; The char table has four extra slots: +;; The char table has five extra slots: ;; 1st: property symbol -;; 2nd: function to call to get a property value -;; 3nd: function to call to put a property value -;; 4th: function to call to get a description of a property value +;; 2nd: function to call to get a property value, +;; or an index number of C function to decode the value, +;; or nil if the value can be directly got from the table. +;; 3nd: function to call to put a property value, +;; or an index number of C function to encode the value, +;; or nil if the value can be directly stored in the table. +;; 4th: function to call to get a description of a property value, or nil ;; 5th: data referred by the above functions ;; List of elements of this form: @@ -82,6 +88,11 @@ (defvar unidata-list nil) +;; Name of the directory containing files of Unicode Character +;; Database. + +(defvar unidata-dir nil) + (defun unidata-setup-list (unidata-text-file) (let* ((table (list nil)) (tail table) @@ -90,6 +101,7 @@ ("^<.*Surrogate" . nil) ("^<.*Private Use" . PRIVATE\ USE))) val char name) + (setq unidata-text-file (expand-file-name unidata-text-file unidata-dir)) (or (file-readable-p unidata-text-file) (error "File not readable: %s" unidata-text-file)) (with-temp-buffer @@ -134,12 +146,17 @@ (setq unidata-list (cdr table)))) ;; Alist of this form: -;; (PROP INDEX GENERATOR FILENAME) +;; (PROP INDEX GENERATOR FILENAME DOCSTRING DESCRIBER VAL-LIST) ;; PROP: character property -;; INDEX: index to each element of unidata-list for PROP +;; INDEX: index to each element of unidata-list for PROP. +;; It may be a function that generates an alist of character codes +;; vs. the corresponding property values. ;; GENERATOR: function to generate a char-table ;; FILENAME: filename to store the char-table +;; DOCSTRING: docstring for the property ;; DESCRIBER: function to call to get a description string of property value +;; DEFAULT: the default value of the property +;; VAL-LIST: list of specially ordered property values (defconst unidata-prop-alist '((name @@ -152,7 +169,12 @@ Property value is one of the following symbols: Lu, Ll, Lt, Lm, Lo, Mn, Mc, Me, Nd, Nl, No, Pc, Pd, Ps, Pe, Pi, Pf, Po, Sm, Sc, Sk, So, Zs, Zl, Zp, Cc, Cf, Cs, Co, Cn" - unidata-describe-general-category) + unidata-describe-general-category + nil + ;; The order of elements must be in sync with unicode_category_t + ;; in src/character.h. + (Lu Ll Lt Lm Lo Mn Mc Me Nd Nl No Pc Pd Ps Pe Pi Pf Po + Sm Sc Sk So Zs Zl Zp Cc Cf Cs Co Cn)) (canonical-combining-class 3 unidata-gen-table-integer "uni-combining.el" "Unicode canonical combining class. @@ -164,7 +186,11 @@ Property value is one of the following symbols: L, LRE, LRO, R, AL, RLE, RLO, PDF, EN, ES, ET, AN, CS, NSM, BN, B, S, WS, ON" - unidata-describe-bidi-class) + unidata-describe-bidi-class + L + ;; The order of elements must be in sync with bidi_type_t in + ;; src/dispextern.h. + (L R EN AN BN B AL LRE LRO RLE RLO PDF ES ET CS NSM S WS ON)) (decomposition 5 unidata-gen-table-decomposition "uni-decomposition.el" "Unicode decomposition mapping. @@ -188,7 +214,7 @@ (mirrored 9 unidata-gen-table-symbol "uni-mirrored.el" "Unicode bidi mirrored flag. -Property value is a symbol `Y' or `N'.") +Property value is a symbol `Y' or `N'. See also the property `mirroring'.") (old-name 10 unidata-gen-table-name "uni-old-name.el" "Unicode old names as published in Unicode 1.0. @@ -211,7 +237,12 @@ 14 unidata-gen-table-character "uni-titlecase.el" "Unicode simple titlecase mapping. Property value is a character." - string))) + string) + (mirroring + unidata-gen-mirroring-list unidata-gen-table-character "uni-mirrored.el" + "Unicode bidi-mirroring characters. +Property value is a character that has the corresponding mirroring image, +or nil for non-mirrored character."))) ;; Functions to access the above data. (defsubst unidata-prop-index (prop) (nth 1 (assq prop unidata-prop-alist))) @@ -219,6 +250,8 @@ (defsubst unidata-prop-file (prop) (nth 3 (assq prop unidata-prop-alist))) (defsubst unidata-prop-docstring (prop) (nth 4 (assq prop unidata-prop-alist))) (defsubst unidata-prop-describer (prop) (nth 5 (assq prop unidata-prop-alist))) +(defsubst unidata-prop-default (prop) (nth 6 (assq prop unidata-prop-alist))) +(defsubst unidata-prop-val-list (prop) (nth 7 (assq prop unidata-prop-alist))) ;; SIMPLE TABLE @@ -227,52 +260,34 @@ ;; values of succeeding character codes are usually different, we use ;; a char-table described here to store such values. ;; -;; If succeeding 128 characters has no property, a char-table has the -;; symbol t for them. Otherwise a char-table has a string of the -;; following format for them. -;; -;; The first character of the string is FIRST-INDEX. -;; The Nth (N > 0) character of the string is a property value of the -;; character (BLOCK-HEAD + FIRST-INDEX + N - 1), where BLOCK-HEAD is -;; the first of the characters in the block. -;; -;; The 4th extra slot of a char-table is nil. - -(defun unidata-get-character (char val table) - (cond - ((characterp val) - val) - - ((stringp val) - (let* ((len (length val)) - (block-head (lsh (lsh char -7) 7)) - (vec (make-vector 128 nil)) - (first-index (aref val 0))) - (dotimes (i (1- len)) - (let ((elt (aref val (1+ i)))) - (if (> elt 0) - (aset vec (+ first-index i) elt)))) - (dotimes (i 128) - (aset table (+ block-head i) (aref vec i))) - (aref vec (- char block-head)))))) - -(defun unidata-put-character (char val table) - (or (characterp val) - (not val) - (error "Not a character nor nil: %S" val)) - (let ((current-val (aref table char))) - (unless (eq current-val val) - (if (stringp current-val) - (funcall (char-table-extra-slot table 1) char current-val table)) - (aset table char val)))) - -(defun unidata-gen-table-character (prop) +;; A char-table divides character code space (#x0..#x3FFFFF) into +;; #x8000 blocks (each block contains 128 characters). + +;; If all characters of a block have no property, a char-table has the +;; symbol nil for that block. Otherwise a char-table has a string of +;; the following format for it. +;; +;; The first character of the string is ?\001. +;; The second character of the string is FIRST-INDEX. +;; The Nth (N > 1) character of the string is a property value of the +;; character (BLOCK-HEAD + FIRST-INDEX + N - 2), where BLOCK-HEAD is +;; the first character of the block. +;; +;; This kind of char-table has these extra slots: +;; 1st: the property symbol +;; 2nd: nil +;; 3rd: 0 (corresponding to uniprop_encode_character in chartab.c) +;; 4th to 5th: nil + +(defun unidata-gen-table-character (prop &rest ignore) (let ((table (make-char-table 'char-code-property-table)) (prop-idx (unidata-prop-index prop)) (vec (make-vector 128 0)) (tail unidata-list) elt range val idx slot) - (set-char-table-range table (cons 0 (max-char)) t) + (if (functionp prop-idx) + (setq tail (funcall prop-idx) + prop-idx 1)) (while tail (setq elt (car tail) tail (cdr tail)) (setq range (car elt) @@ -301,7 +316,7 @@ (setq first-index last-index))) (setq tail (cdr tail))) (when first-index - (let ((str (string first-index)) + (let ((str (string 1 first-index)) c) (while (<= first-index last-index) (setq str (format "%s%c" str (or (aref vec first-index) 0)) @@ -309,184 +324,78 @@ (set-char-table-range table (cons start limit) str)))))) (set-char-table-extra-slot table 0 prop) - (byte-compile 'unidata-get-character) - (byte-compile 'unidata-put-character) - (set-char-table-extra-slot table 1 (symbol-function 'unidata-get-character)) - (set-char-table-extra-slot table 2 (symbol-function 'unidata-put-character)) - + (set-char-table-extra-slot table 2 0) table)) ;; RUN-LENGTH TABLE ;; -;; If the type of character property value is symbol, integer, -;; boolean, or character, we use a char-table described here to store -;; the values. -;; -;; The 4th extra slot is a vector of property values (VAL-TABLE), and -;; values for succeeding 128 characters are encoded into this -;; character sequence: +;; If many characters of successive character codes have the same +;; property value, we use a char-table described here to store the +;; values. +;; +;; At first, instead of a value itself, we store an index number to +;; the VAL-TABLE (5th extra slot) in the table. We call that index +;; number as VAL-CODE here after. +;; +;; A char-table divides character code space (#x0..#x3FFFFF) into +;; #x8000 blocks (each block contains 128 characters). +;; +;; If all characters of a block have the same value, a char-table has +;; VAL-CODE for that block. Otherwise a char-table has a string of +;; the following format for that block. +;; +;; The first character of the string is ?\002. +;; The following characters has this form: ;; ( VAL-CODE RUN-LENGTH ? ) + ;; where: -;; VAL-CODE (0..127): -;; (VAL-CODE - 1) is an index into VAL-TABLE. -;; The value 0 means no-value. +;; VAL-CODE (0..127): index into VAL-TABLE. ;; RUN-LENGTH (130..255): ;; (RUN-LENGTH - 128) specifies how many characters have the same ;; value. If omitted, it means 1. - - -;; Return a symbol-type character property value of CHAR. VAL is the -;; current value of (aref TABLE CHAR). - -(defun unidata-get-symbol (char val table) - (let ((val-table (char-table-extra-slot table 4))) - (cond ((symbolp val) - val) - ((stringp val) - (let ((first-char (lsh (lsh char -7) 7)) - (str val) - (len (length val)) - (idx 0) - this-val count) - (set-char-table-range table (cons first-char (+ first-char 127)) - nil) - (while (< idx len) - (setq val (aref str idx) idx (1+ idx) - count (if (< idx len) (aref str idx) 1)) - (setq val (and (> val 0) (aref val-table (1- val))) - count (if (< count 128) - 1 - (prog1 (- count 128) (setq idx (1+ idx))))) - (dotimes (i count) - (if val - (aset table first-char val)) - (if (= first-char char) - (setq this-val val)) - (setq first-char (1+ first-char)))) - this-val)) - ((> val 0) - (aref val-table (1- val)))))) - -;; Return a integer-type character property value of CHAR. VAL is the -;; current value of (aref TABLE CHAR). - -(defun unidata-get-integer (char val table) - (let ((val-table (char-table-extra-slot table 4))) - (cond ((integerp val) - val) - ((stringp val) - (let ((first-char (lsh (lsh char -7) 7)) - (str val) - (len (length val)) - (idx 0) - this-val count) - (while (< idx len) - (setq val (aref str idx) idx (1+ idx) - count (if (< idx len) (aref str idx) 1)) - (setq val (and (> val 0) (aref val-table (1- val))) - count (if (< count 128) - 1 - (prog1 (- count 128) (setq idx (1+ idx))))) - (dotimes (i count) - (aset table first-char val) - (if (= first-char char) - (setq this-val val)) - (setq first-char (1+ first-char)))) - this-val))))) - -;; Return a numeric-type (integer or float) character property value -;; of CHAR. VAL is the current value of (aref TABLE CHAR). - -(defun unidata-get-numeric (char val table) - (cond - ((numberp val) - val) - ((stringp val) - (let ((val-table (char-table-extra-slot table 4)) - (first-char (lsh (lsh char -7) 7)) - (str val) - (len (length val)) - (idx 0) - this-val count) - (while (< idx len) - (setq val (aref str idx) idx (1+ idx) - count (if (< idx len) (aref str idx) 1)) - (setq val (and (> val 0) (aref val-table (1- val))) - count (if (< count 128) - 1 - (prog1 (- count 128) (setq idx (1+ idx))))) - (dotimes (i count) - (aset table first-char val) - (if (= first-char char) - (setq this-val val)) - (setq first-char (1+ first-char)))) - this-val)))) - -;; Store VAL (symbol) as a character property value of CHAR in TABLE. - -(defun unidata-put-symbol (char val table) - (or (symbolp val) - (error "Not a symbol: %S" val)) - (let ((current-val (aref table char))) - (unless (eq current-val val) - (if (stringp current-val) - (funcall (char-table-extra-slot table 1) char current-val table)) - (aset table char val)))) - -;; Store VAL (integer) as a character property value of CHAR in TABLE. - -(defun unidata-put-integer (char val table) - (or (integerp val) - (not val) - (error "Not an integer nor nil: %S" val)) - (let ((current-val (aref table char))) - (unless (eq current-val val) - (if (stringp current-val) - (funcall (char-table-extra-slot table 1) char current-val table)) - (aset table char val)))) - -;; Store VAL (integer or float) as a character property value of CHAR -;; in TABLE. - -(defun unidata-put-numeric (char val table) - (or (numberp val) - (not val) - (error "Not a number nor nil: %S" val)) - (let ((current-val (aref table char))) - (unless (equal current-val val) - (if (stringp current-val) - (funcall (char-table-extra-slot table 1) char current-val table)) - (aset table char val)))) +;; +;; This kind of char-table has these extra slots: +;; 1st: the property symbol +;; 2nd: 0 (corresponding to uniprop_decode_value in chartab.c) +;; 3rd: 1..3 (corresponding to uniprop_encode_xxx in chartab.c) +;; 4th: function or nil +;; 5th: VAL-TABLE ;; Encode the character property value VAL into an integer value by ;; VAL-LIST. By side effect, VAL-LIST is modified. ;; VAL-LIST has this form: -;; (t (VAL1 . VAL-CODE1) (VAL2 . VAL-CODE2) ...) -;; If VAL is one of VALn, just return VAL-CODEn. Otherwise, -;; VAL-LIST is modified to this: -;; (t (VAL . (1+ VAL-CODE1)) (VAL1 . VAL-CODE1) (VAL2 . VAL-CODE2) ...) +;; ((nil . 0) (VAL1 . 1) (VAL2 . 2) ...) +;; If VAL is one of VALn, just return n. +;; Otherwise, VAL-LIST is modified to this: +;; ((nil . 0) (VAL1 . 1) (VAL2 . 2) ... (VAL . n+1)) (defun unidata-encode-val (val-list val) (let ((slot (assoc val val-list)) val-code) (if slot (cdr slot) - (setq val-code (if (cdr val-list) (1+ (cdr (nth 1 val-list))) 1)) - (setcdr val-list (cons (cons val val-code) (cdr val-list))) + (setq val-code (length val-list)) + (nconc val-list (list (cons val val-code))) val-code))) ;; Generate a char-table for the character property PROP. -(defun unidata-gen-table (prop val-func default-value) +(defun unidata-gen-table (prop val-func default-value val-list) (let ((table (make-char-table 'char-code-property-table)) (prop-idx (unidata-prop-index prop)) - (val-list (list t)) (vec (make-vector 128 0)) tail elt range val val-code idx slot prev-range-data) - (set-char-table-range table (cons 0 (max-char)) default-value) + (setq val-list (cons nil (copy-sequence val-list))) + (setq tail val-list val-code 0) + ;; Convert (nil A B ...) to ((nil . 0) (A . 1) (B . 2) ...) + (while tail + (setcar tail (cons (car tail) val-code)) + (setq tail (cdr tail) val-code (1+ val-code))) + (setq default-value (unidata-encode-val val-list default-value)) + (set-char-table-range table t default-value) + (set-char-table-range table nil default-value) (setq tail unidata-list) (while tail (setq elt (car tail) tail (cdr tail)) @@ -495,7 +404,7 @@ (setq val-code (if val (unidata-encode-val val-list val))) (if (consp range) (when val-code - (set-char-table-range table range val) + (set-char-table-range table range val-code) (let ((from (car range)) (to (cdr range))) ;; If RANGE doesn't end at the char-table boundary (each ;; 128 characters), we may have to carry over the data @@ -534,7 +443,7 @@ (if val-code (aset vec (- range start) val-code)) (setq tail (cdr tail))) - (setq str "" val-code -1 count 0) + (setq str "\002" val-code -1 count 0) (mapc #'(lambda (x) (if (= val-code x) (setq count (1+ count)) @@ -549,7 +458,7 @@ vec) (if (= count 128) (if val - (set-char-table-range table (cons start limit) val)) + (set-char-table-range table (cons start limit) val-code)) (if (= val-code 0) (set-char-table-range table (cons start limit) str) (if (> count 2) @@ -559,34 +468,29 @@ (setq str (concat str (string val-code))))) (set-char-table-range table (cons start limit) str)))))) - (setq val-list (nreverse (cdr val-list))) (set-char-table-extra-slot table 0 prop) (set-char-table-extra-slot table 4 (vconcat (mapcar 'car val-list))) table)) -(defun unidata-gen-table-symbol (prop) +(defun unidata-gen-table-symbol (prop default-value val-list) (let ((table (unidata-gen-table prop #'(lambda (x) (and (> (length x) 0) (intern x))) - 0))) - (byte-compile 'unidata-get-symbol) - (byte-compile 'unidata-put-symbol) - (set-char-table-extra-slot table 1 (symbol-function 'unidata-get-symbol)) - (set-char-table-extra-slot table 2 (symbol-function 'unidata-put-symbol)) + default-value val-list))) + (set-char-table-extra-slot table 1 0) + (set-char-table-extra-slot table 2 1) table)) -(defun unidata-gen-table-integer (prop) +(defun unidata-gen-table-integer (prop default-value val-list) (let ((table (unidata-gen-table prop #'(lambda (x) (and (> (length x) 0) (string-to-number x))) - t))) - (byte-compile 'unidata-get-integer) - (byte-compile 'unidata-put-integer) - (set-char-table-extra-slot table 1 (symbol-function 'unidata-get-integer)) - (set-char-table-extra-slot table 2 (symbol-function 'unidata-put-integer)) + default-value val-list))) + (set-char-table-extra-slot table 1 0) + (set-char-table-extra-slot table 2 1) table)) -(defun unidata-gen-table-numeric (prop) +(defun unidata-gen-table-numeric (prop default-value val-list) (let ((table (unidata-gen-table prop #'(lambda (x) (if (string-match "/" x) @@ -595,11 +499,9 @@ (substring x (match-end 0)))) (if (> (length x) 0) (string-to-number x)))) - t))) - (byte-compile 'unidata-get-numeric) - (byte-compile 'unidata-put-numeric) - (set-char-table-extra-slot table 1 (symbol-function 'unidata-get-numeric)) - (set-char-table-extra-slot table 2 (symbol-function 'unidata-put-numeric)) + default-value val-list))) + (set-char-table-extra-slot table 1 0) + (set-char-table-extra-slot table 2 2) table)) @@ -892,7 +794,6 @@ word-table block-list block-word-table block-end tail elt range val idx slot) - (set-char-table-range table (cons 0 (max-char)) 0) (setq tail unidata-list) (setq block-end -1) (while tail @@ -1025,7 +926,7 @@ idx (1+ i))))) (nreverse (cons (intern (substring str idx)) l)))))) -(defun unidata-gen-table-name (prop) +(defun unidata-gen-table-name (prop &rest ignore) (let* ((table (unidata-gen-table-word-list prop 'unidata-split-name)) (word-tables (char-table-extra-slot table 4))) (byte-compile 'unidata-get-name) @@ -1064,7 +965,7 @@ (nreverse l))))) -(defun unidata-gen-table-decomposition (prop) +(defun unidata-gen-table-decomposition (prop &rest ignore) (let* ((table (unidata-gen-table-word-list prop 'unidata-split-decomposition)) (word-tables (char-table-extra-slot table 4))) (byte-compile 'unidata-get-decomposition) @@ -1080,7 +981,8 @@ (defun unidata-describe-general-category (val) (cdr (assq val - '((Lu . "Letter, Uppercase") + '((nil . "Uknown") + (Lu . "Letter, Uppercase") (Ll . "Letter, Lowercase") (Lt . "Letter, Titlecase") (Lm . "Letter, Modifier") @@ -1171,6 +1073,19 @@ (string ?')))) val " ")) +(defun unidata-gen-mirroring-list () + (let ((head (list nil)) + tail) + (with-temp-buffer + (insert-file-contents (expand-file-name "BidiMirroring.txt" unidata-dir)) + (goto-char (point-min)) + (setq tail head) + (while (re-search-forward "^\\([0-9A-F]+\\);\\s +\\([0-9A-F]+\\)" nil t) + (let ((char (string-to-number (match-string 1) 16)) + (mirror (match-string 2))) + (setq tail (setcdr tail (list (list char mirror))))))) + (cdr head))) + ;; Verify if we can retrieve correct values from the generated ;; char-tables. @@ -1212,13 +1127,21 @@ ;; The entry function. It generates files described in the header ;; comment of this file. -(defun unidata-gen-files (&optional unidata-text-file) - (or unidata-text-file - (setq unidata-text-file (car command-line-args-left) +(defun unidata-gen-files (&optional data-dir unidata-text-file) + (or data-dir + (setq data-dir (car command-line-args-left) + command-line-args-left (cdr command-line-args-left) + unidata-text-file (car command-line-args-left) command-line-args-left (cdr command-line-args-left))) - (unidata-setup-list unidata-text-file) (let ((coding-system-for-write 'utf-8-unix) - (charprop-file "charprop.el")) + (charprop-file "charprop.el") + (unidata-dir data-dir)) + (dolist (elt unidata-prop-alist) + (let* ((prop (car elt)) + (file (unidata-prop-file prop))) + (if (file-exists-p file) + (delete-file file)))) + (unidata-setup-list unidata-text-file) (with-temp-file charprop-file (insert ";; Automatically generated by unidata-gen.el.\n") (dolist (elt unidata-prop-alist) @@ -1227,31 +1150,41 @@ (file (unidata-prop-file prop)) (docstring (unidata-prop-docstring prop)) (describer (unidata-prop-describer prop)) + (default-value (unidata-prop-default prop)) + (val-list (unidata-prop-val-list prop)) table) ;; Filename in this comment line is extracted by sed in ;; Makefile. (insert (format ";; FILE: %s\n" file)) (insert (format "(define-char-code-property '%S %S\n %S)\n" prop file docstring)) - (with-temp-file file + (with-temp-buffer (message "Generating %s..." file) - (setq table (funcall generator prop)) + (when (file-exists-p file) + (insert-file-contents file) + (goto-char (point-max)) + (search-backward ";; Local Variables:")) + (setq table (funcall generator prop default-value val-list)) (when describer (unless (subrp (symbol-function describer)) (byte-compile describer) (setq describer (symbol-function describer))) (set-char-table-extra-slot table 3 describer)) - (insert ";; Copyright (C) 1991-2009 Unicode, Inc. -;; This file was generated from the Unicode data file at -;; http://www.unicode.org/Public/UNIDATA/UnicodeData.txt. -;; See lisp/international/README for the copyright and permission notice.\n" - (format "(define-char-code-property '%S %S %S)\n" - prop table docstring) - ";; Local Variables:\n" - ";; coding: utf-8\n" - ";; no-byte-compile: t\n" - ";; End:\n\n" - (format ";; %s ends here\n" file))))) + (if (bobp) + (insert ";; Copyright (C) 1991-2009 Unicode, Inc. +;; This file was generated from the Unicode data files at +;; http://www.unicode.org/Public/UNIDATA/. +;; See lisp/international/README for the copyright and permission notice.\n")) + (insert (format "(define-char-code-property '%S %S %S)\n" + prop table docstring)) + (if (eobp) + (insert ";; Local Variables:\n" + ";; coding: utf-8\n" + ";; no-byte-compile: t\n" + ";; End:\n\n" + (format ";; %s ends here\n" file))) + (write-file file) + (message "Generating %s...done" file)))) (message "Writing %s..." charprop-file) (insert ";; Local Variables:\n" ";; coding: utf-8\n" === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-07 01:46:59 +0000 +++ lisp/ChangeLog 2011-07-07 04:20:12 +0000 @@ -1,3 +1,39 @@ +2011-07-07 Kenichi Handa + + * international/characters.el (build-unicode-category-table): + Delete it. + (unicode-category-table): Set it by + unicode-prroperty-table-internal. + + * international/mule-cmds.el (char-code-property-alist): Moved to + to src/chartab.c. + (get-char-code-property): Call unicode-property-table-internal to + load a file. Call get-unicode-property-internal where necessary. + (put-char-code-property): Call unicode-property-table-internal to + load a file. Call put-unicode-property-internal where necessary. + put-unicode-property-internal where necessary. + (char-code-property-description): Call + unicode-property-table-internal to load a file. + + * international/charprop.el: + * international/uni-bidi.el: + * international/uni-category.el: + * international/uni-combining.el: + * international/uni-comment.el: + * international/uni-decimal.el: + * international/uni-decomposition.el: + * international/uni-digit.el: + * international/uni-lowercase.el: + * international/uni-mirrored.el: + * international/uni-name.el: + * international/uni-numeric.el: + * international/uni-old-name.el: + * international/uni-titlecase.el: + * international/uni-uppercase.el: Regenerate. + + * loadup.el: Load international/charprop.el before + international/characters. + 2011-07-07 Chong Yidong * window.el (next-buffer, previous-buffer): Signal an error if === modified file 'lisp/dired.el' --- lisp/dired.el 2011-07-06 17:10:36 +0000 +++ lisp/dired.el 2011-07-07 04:16:52 +0000 @@ -3643,7 +3643,7 @@ ;;;;;; dired-run-shell-command dired-do-shell-command dired-do-async-shell-command ;;;;;; dired-clean-directory dired-do-print dired-do-touch dired-do-chown ;;;;;; dired-do-chgrp dired-do-chmod dired-compare-directories dired-backup-diff -;;;;;; dired-diff) "dired-aux" "dired-aux.el" "d7b197829c8d456cc5bc6c5fdab7c4b0") +;;;;;; dired-diff) "dired-aux" "dired-aux.el" "198ca311b49f0b6354f915502bba4ab6") ;;; Generated autoloads from dired-aux.el (autoload 'dired-diff "dired-aux" "\ @@ -4104,7 +4104,7 @@ ;;;*** ;;;### (autoloads (dired-do-relsymlink dired-jump-other-window dired-jump) -;;;;;; "dired-x" "dired-x.el" "cdeb2935dc1d33819b12981ba5272073") +;;;;;; "dired-x" "dired-x.el" "90459fb5998296fc67986945701b2bfc") ;;; Generated autoloads from dired-x.el (autoload 'dired-jump "dired-x" "\ === modified file 'lisp/international/characters.el' --- lisp/international/characters.el 2011-01-26 08:36:39 +0000 +++ lisp/international/characters.el 2011-07-06 22:43:48 +0000 @@ -1206,22 +1206,8 @@ ;;; Setting unicode-category-table. -;; This macro is to build unicode-category-table at compile time so -;; that C code can access the table efficiently. -(defmacro build-unicode-category-table () - (let ((table (make-char-table 'unicode-category-table nil))) - (dotimes (i #x110000) - (if (or (< i #xD800) - (and (>= i #xF900) (< i #x30000)) - (and (>= i #xE0000) (< i #xE0200))) - (aset table i (get-char-code-property i 'general-category)))) - (set-char-table-range table '(#xE000 . #xF8FF) 'Co) - (set-char-table-range table '(#xF0000 . #xFFFFD) 'Co) - (set-char-table-range table '(#x100000 . #x10FFFD) 'Co) - (optimize-char-table table 'eq) - table)) - -(setq unicode-category-table (build-unicode-category-table)) +(setq unicode-category-table + (unicode-property-table-internal 'general-category)) (map-char-table #'(lambda (key val) (if (and val (or (and (/= (aref (symbol-name val) 0) ?M) === modified file 'lisp/international/charprop.el' --- lisp/international/charprop.el 2010-06-09 15:46:41 +0000 +++ lisp/international/charprop.el 2011-07-06 22:43:48 +0000 @@ -1,8 +1,4 @@ -;; Copyright (C) 1991-2010 Unicode, Inc. -;; This file was generated from the Unicode data file at -;; http://www.unicode.org/Public/UNIDATA/UnicodeData.txt. -;; See lisp/international/README for the copyright and permission notice. - +;; Automatically generated by unidata-gen.el. ;; FILE: uni-name.el (define-char-code-property 'name "uni-name.el" "Unicode character name. @@ -45,7 +41,7 @@ ;; FILE: uni-mirrored.el (define-char-code-property 'mirrored "uni-mirrored.el" "Unicode bidi mirrored flag. -Property value is a symbol `Y' or `N'.") +Property value is a symbol `Y' or `N'. See also the property `mirroring'.") ;; FILE: uni-old-name.el (define-char-code-property 'old-name "uni-old-name.el" "Unicode old names as published in Unicode 1.0. @@ -66,6 +62,11 @@ (define-char-code-property 'titlecase "uni-titlecase.el" "Unicode simple titlecase mapping. Property value is a character.") +;; FILE: uni-mirrored.el +(define-char-code-property 'mirroring "uni-mirrored.el" + "Unicode bidi-mirroring characters. +Property value is a character that has the corresponding mirroring image, +or nil for non-mirrored character.") ;; Local Variables: ;; coding: utf-8 ;; no-byte-compile: t === modified file 'lisp/international/mule-cmds.el' --- lisp/international/mule-cmds.el 2011-06-20 16:02:31 +0000 +++ lisp/international/mule-cmds.el 2011-07-06 22:43:48 +0000 @@ -2709,16 +2709,6 @@ ;;; Character property -;; Each element has the form (PROP . TABLE). -;; PROP is a symbol representing a character property. -;; TABLE is a char-table containing the property value for each character. -;; TABLE may be a name of file to load to build a char-table. -;; Don't modify this variable directly but use `define-char-code-property'. - -(defvar char-code-property-alist nil - "Alist of character property name vs char-table containing property values. -Internal use only.") - (put 'char-code-property-table 'char-table-extra-slots 5) (defun define-char-code-property (name table &optional docstring) @@ -2770,32 +2760,23 @@ (defun get-char-code-property (char propname) "Return the value of CHAR's PROPNAME property." - (let ((slot (assq propname char-code-property-alist))) - (if slot - (let (table value func) - (if (stringp (cdr slot)) - (load (cdr slot) nil t)) - (setq table (cdr slot) - value (aref table char) - func (char-table-extra-slot table 1)) + (let ((table (unicode-property-table-internal propname))) + (if table + (let ((func (char-table-extra-slot table 1))) (if (functionp func) - (setq value (funcall func char value table))) - value) + (funcall func char (aref table char) table) + (get-unicode-property-internal table char))) (plist-get (aref char-code-property-table char) propname)))) (defun put-char-code-property (char propname value) "Store CHAR's PROPNAME property with VALUE. It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." - (let ((slot (assq propname char-code-property-alist))) - (if slot - (let (table func) - (if (stringp (cdr slot)) - (load (cdr slot) nil t)) - (setq table (cdr slot) - func (char-table-extra-slot table 2)) + (let ((table (unicode-property-table-internal propname))) + (if table + (let ((func (char-table-extra-slot table 2))) (if (functionp func) (funcall func char value table) - (aset table char value))) + (put-unicode-property-internal table char value))) (let* ((plist (aref char-code-property-table char)) (x (plist-put plist propname value))) (or (eq x plist) @@ -2805,13 +2786,9 @@ (defun char-code-property-description (prop value) "Return a description string of character property PROP's value VALUE. If there's no description string for VALUE, return nil." - (let ((slot (assq prop char-code-property-alist))) - (if slot - (let (table func) - (if (stringp (cdr slot)) - (load (cdr slot) nil t)) - (setq table (cdr slot) - func (char-table-extra-slot table 3)) + (let ((table (unicode-property-table-internal prop))) + (if table + (let ((func (char-table-extra-slot table 3))) (if (functionp func) (funcall func value)))))) === modified file 'lisp/international/uni-bidi.el' Binary files lisp/international/uni-bidi.el 2010-09-05 02:06:39 +0000 and lisp/international/uni-bidi.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-category.el' Binary files lisp/international/uni-category.el 2010-09-05 02:06:39 +0000 and lisp/international/uni-category.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-combining.el' Binary files lisp/international/uni-combining.el 2010-09-05 02:06:39 +0000 and lisp/international/uni-combining.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-comment.el' Binary files lisp/international/uni-comment.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-comment.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-decimal.el' Binary files lisp/international/uni-decimal.el 2010-09-05 02:06:39 +0000 and lisp/international/uni-decimal.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-decomposition.el' Binary files lisp/international/uni-decomposition.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-decomposition.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-digit.el' Binary files lisp/international/uni-digit.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-digit.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-lowercase.el' Binary files lisp/international/uni-lowercase.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-lowercase.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-mirrored.el' Binary files lisp/international/uni-mirrored.el 2010-09-05 02:06:39 +0000 and lisp/international/uni-mirrored.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-name.el' Binary files lisp/international/uni-name.el 2010-09-05 02:06:39 +0000 and lisp/international/uni-name.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-numeric.el' Binary files lisp/international/uni-numeric.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-numeric.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-old-name.el' Binary files lisp/international/uni-old-name.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-old-name.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-titlecase.el' Binary files lisp/international/uni-titlecase.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-titlecase.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/international/uni-uppercase.el' Binary files lisp/international/uni-uppercase.el 2010-06-09 15:46:41 +0000 and lisp/international/uni-uppercase.el 2011-07-06 22:43:48 +0000 differ === modified file 'lisp/loadup.el' --- lisp/loadup.el 2011-06-11 09:50:37 +0000 +++ lisp/loadup.el 2011-07-06 22:43:48 +0000 @@ -123,11 +123,11 @@ ;; multilingual text. (load "international/mule-cmds") (load "case-table") -(load "international/characters") -(load "composite") ;; This file doesn't exist when building a development version of Emacs ;; from the repository. It is generated just after temacs is built. (load "international/charprop.el" t) +(load "international/characters") +(load "composite") ;; Load language-specific files. (load "language/chinese") === modified file 'src/ChangeLog' --- src/ChangeLog 2011-07-07 03:24:33 +0000 +++ src/ChangeLog 2011-07-07 04:20:12 +0000 @@ -1,3 +1,45 @@ +2011-07-07 Kenichi Handa + + * character.h (unicode_category_t): New enum type. + + * chartab.c (uniprop_decoder_t, uniprop_encoder_t): New types. + (Qchar_code_property_table): New variable. + (UNIPROP_TABLE_P, UNIPROP_GET_DECODER) + (UNIPROP_COMPRESSED_FORM_P): New macros. + (char_table_ascii): Uncompress the compressed values. + (sub_char_table_ref): New arg is_uniprop. Callers changed. + Uncompress the compressed values. + (sub_char_table_ref_and_range): Likewise. + (char_table_ref_and_range): Uncompress the compressed values. + (sub_char_table_set): New arg is_uniprop. Callers changed. + Uncompress the compressed values. + (sub_char_table_set_range): Args changed. Callers changed. + (char_table_set_range): Adjuted for the above change. + (map_sub_char_table): Delete args default_val and parent. Add arg + top. Give decoded values to a Lisp function. + (map_char_table): Adjusted for the above change. Give decoded + values to a Lisp function. Gcpro more variables. + (uniprop_table_uncompress) + (uniprop_decode_value_run_length): New functions. + (uniprop_decoder, uniprop_decoder_count): New variables. + (uniprop_get_decoder, uniprop_encode_value_character) + (uniprop_encode_value_run_length, uniprop_encode_value_numeric): + New functions. + (uniprop_encoder, uniprop_encoder_count): New variables. + (uniprop_get_encoder, uniprop_table) + (Funicode_property_table_internal, Fget_unicode_property_internal) + (Fput_unicode_property_internal): New functions. + (syms_of_chartab): DEFSYM Qchar_code_property_table, defsubr + Sunicode_property_table_internal, Sget_unicode_property_internal, + and Sput_unicode_property_internal. Defvar_lisp + char-code-property-alist. + + * composite.c (CHAR_COMPOSABLE_P): Adjusted for the change of + Vunicode_category_table. + + * font.c (font_range): Adjusted for the change of + Vunicode_category_table. + 2011-07-07 Dan Nicolaescu * m/iris4d.h: Remove file, move contents ... === modified file 'src/character.h' --- src/character.h 2011-06-24 21:25:22 +0000 +++ src/character.h 2011-07-06 23:28:00 +0000 @@ -597,6 +597,45 @@ : (c) <= 0xDFFF ? 2 \ : 0) +/* Data type for Unicode general category. + + The order of members must be in sync with the 8th element of the + member of unidata-prop-alist (in admin/unidata/unidata-getn.el) for + Unicode character property `general-category'. */ + +typedef enum { + UNICODE_CATEGORY_UNKNOWN = 0, + UNICODE_CATEGORY_Lu, + UNICODE_CATEGORY_Ll, + UNICODE_CATEGORY_Lt, + UNICODE_CATEGORY_Lm, + UNICODE_CATEGORY_Lo, + UNICODE_CATEGORY_Mn, + UNICODE_CATEGORY_Mc, + UNICODE_CATEGORY_Me, + UNICODE_CATEGORY_Nd, + UNICODE_CATEGORY_Nl, + UNICODE_CATEGORY_No, + UNICODE_CATEGORY_Pc, + UNICODE_CATEGORY_Pd, + UNICODE_CATEGORY_Ps, + UNICODE_CATEGORY_Pe, + UNICODE_CATEGORY_Pi, + UNICODE_CATEGORY_Pf, + UNICODE_CATEGORY_Po, + UNICODE_CATEGORY_Sm, + UNICODE_CATEGORY_Sc, + UNICODE_CATEGORY_Sk, + UNICODE_CATEGORY_So, + UNICODE_CATEGORY_Zs, + UNICODE_CATEGORY_Zl, + UNICODE_CATEGORY_Zp, + UNICODE_CATEGORY_Cc, + UNICODE_CATEGORY_Cf, + UNICODE_CATEGORY_Cs, + UNICODE_CATEGORY_Co, + UNICODE_CATEGORY_Cn +} unicode_category_t; extern int char_resolve_modifier_mask (int); extern int char_string (unsigned, unsigned char *); === modified file 'src/chartab.c' --- src/chartab.c 2011-06-13 01:38:25 +0000 +++ src/chartab.c 2011-07-07 04:16:52 +0000 @@ -53,7 +53,38 @@ #define CHARTAB_IDX(c, depth, min_char) \ (((c) - (min_char)) >> chartab_bits[(depth)]) - + +/* Preamble for uniprop (Unicode character property) tables. See the + comment of "Unicode character property tables". */ + +/* Purpose of uniprop tables. */ +static Lisp_Object Qchar_code_property_table; + +/* Types of decoder and encoder functions for uniprop values. */ +typedef Lisp_Object (*uniprop_decoder_t) (Lisp_Object, Lisp_Object); +typedef Lisp_Object (*uniprop_encoder_t) (Lisp_Object, Lisp_Object); + +static Lisp_Object uniprop_table_uncompress (Lisp_Object, int); +static uniprop_decoder_t uniprop_get_decoder (Lisp_Object); + +/* 1 iff TABLE is a uniprop table. */ +#define UNIPROP_TABLE_P(TABLE) \ + (EQ (XCHAR_TABLE (TABLE)->purpose, Qchar_code_property_table) \ + && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (TABLE)) == 5) + +/* Return a decoder for values in the uniprop table TABLE. */ +#define UNIPROP_GET_DECODER(TABLE) \ + (UNIPROP_TABLE_P (TABLE) ? uniprop_get_decoder (TABLE) : NULL) + +/* Nonzero iff OBJ is a string representing uniprop values of 128 + succeeding characters (the bottom level of a char-table) by a + compressed format. We are sure that no property value has a string + starting with '\001' nor '\002'. */ +#define UNIPROP_COMPRESSED_FORM_P(OBJ) \ + (STRINGP (OBJ) && SCHARS (OBJ) > 0 \ + && ((SREF (OBJ, 0) == 1 || (SREF (OBJ, 0) == 2)))) + + DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0, doc: /* Return a newly created char-table, with purpose PURPOSE. Each element is initialized to INIT, which defaults to nil. @@ -107,7 +138,7 @@ static Lisp_Object char_table_ascii (Lisp_Object table) { - Lisp_Object sub; + Lisp_Object sub, val; sub = XCHAR_TABLE (table)->contents[0]; if (! SUB_CHAR_TABLE_P (sub)) @@ -115,7 +146,10 @@ sub = XSUB_CHAR_TABLE (sub)->contents[0]; if (! SUB_CHAR_TABLE_P (sub)) return sub; - return XSUB_CHAR_TABLE (sub)->contents[0]; + val = XSUB_CHAR_TABLE (sub)->contents[0]; + if (UNIPROP_TABLE_P (table) && UNIPROP_COMPRESSED_FORM_P (val)) + val = uniprop_table_uncompress (sub, 0); + return val; } static Lisp_Object @@ -169,16 +203,19 @@ } static Lisp_Object -sub_char_table_ref (Lisp_Object table, int c) +sub_char_table_ref (Lisp_Object table, int c, int is_uniprop) { struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table); int depth = XINT (tbl->depth); int min_char = XINT (tbl->min_char); Lisp_Object val; + int idx = CHARTAB_IDX (c, depth, min_char); - val = tbl->contents[CHARTAB_IDX (c, depth, min_char)]; + val = tbl->contents[idx]; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val)) + val = uniprop_table_uncompress (table, idx); if (SUB_CHAR_TABLE_P (val)) - val = sub_char_table_ref (val, c); + val = sub_char_table_ref (val, c, is_uniprop); return val; } @@ -198,7 +235,7 @@ { val = tbl->contents[CHARTAB_IDX (c, 0, 0)]; if (SUB_CHAR_TABLE_P (val)) - val = sub_char_table_ref (val, c); + val = sub_char_table_ref (val, c, UNIPROP_TABLE_P (table)); } if (NILP (val)) { @@ -210,7 +247,8 @@ } static Lisp_Object -sub_char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to, Lisp_Object defalt) +sub_char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to, + Lisp_Object defalt, int is_uniprop) { struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table); int depth = XINT (tbl->depth); @@ -219,8 +257,10 @@ Lisp_Object val; val = tbl->contents[chartab_idx]; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val)) + val = uniprop_table_uncompress (table, chartab_idx); if (SUB_CHAR_TABLE_P (val)) - val = sub_char_table_ref_and_range (val, c, from, to, defalt); + val = sub_char_table_ref_and_range (val, c, from, to, defalt, is_uniprop); else if (NILP (val)) val = defalt; @@ -232,8 +272,11 @@ c = min_char + idx * chartab_chars[depth] - 1; idx--; this_val = tbl->contents[idx]; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val)) + this_val = uniprop_table_uncompress (table, idx); if (SUB_CHAR_TABLE_P (this_val)) - this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt); + this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt, + is_uniprop); else if (NILP (this_val)) this_val = defalt; @@ -251,8 +294,11 @@ chartab_idx++; this_val = tbl->contents[chartab_idx]; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val)) + this_val = uniprop_table_uncompress (table, chartab_idx); if (SUB_CHAR_TABLE_P (this_val)) - this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt); + this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt, + is_uniprop); else if (NILP (this_val)) this_val = defalt; if (! EQ (this_val, val)) @@ -277,17 +323,20 @@ struct Lisp_Char_Table *tbl = XCHAR_TABLE (table); int chartab_idx = CHARTAB_IDX (c, 0, 0), idx; Lisp_Object val; + int is_uniprop = UNIPROP_TABLE_P (table); val = tbl->contents[chartab_idx]; if (*from < 0) *from = 0; if (*to < 0) *to = MAX_CHAR; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val)) + val = uniprop_table_uncompress (table, chartab_idx); if (SUB_CHAR_TABLE_P (val)) - val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt); + val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt, + is_uniprop); else if (NILP (val)) val = tbl->defalt; - idx = chartab_idx; while (*from < idx * chartab_chars[0]) { @@ -296,9 +345,11 @@ c = idx * chartab_chars[0] - 1; idx--; this_val = tbl->contents[idx]; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val)) + this_val = uniprop_table_uncompress (table, idx); if (SUB_CHAR_TABLE_P (this_val)) this_val = sub_char_table_ref_and_range (this_val, c, from, to, - tbl->defalt); + tbl->defalt, is_uniprop); else if (NILP (this_val)) this_val = tbl->defalt; @@ -315,9 +366,11 @@ chartab_idx++; c = chartab_idx * chartab_chars[0]; this_val = tbl->contents[chartab_idx]; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val)) + this_val = uniprop_table_uncompress (table, chartab_idx); if (SUB_CHAR_TABLE_P (this_val)) this_val = sub_char_table_ref_and_range (this_val, c, from, to, - tbl->defalt); + tbl->defalt, is_uniprop); else if (NILP (this_val)) this_val = tbl->defalt; if (! EQ (this_val, val)) @@ -332,7 +385,7 @@ static void -sub_char_table_set (Lisp_Object table, int c, Lisp_Object val) +sub_char_table_set (Lisp_Object table, int c, Lisp_Object val, int is_uniprop) { struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table); int depth = XINT ((tbl)->depth); @@ -347,11 +400,17 @@ sub = tbl->contents[i]; if (! SUB_CHAR_TABLE_P (sub)) { - sub = make_sub_char_table (depth + 1, - min_char + i * chartab_chars[depth], sub); - tbl->contents[i] = sub; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (sub)) + sub = uniprop_table_uncompress (table, i); + else + { + sub = make_sub_char_table (depth + 1, + min_char + i * chartab_chars[depth], + sub); + tbl->contents[i] = sub; + } } - sub_char_table_set (sub, c, val); + sub_char_table_set (sub, c, val, is_uniprop); } } @@ -376,7 +435,7 @@ sub = make_sub_char_table (1, i * chartab_chars[0], sub); tbl->contents[i] = sub; } - sub_char_table_set (sub, c, val); + sub_char_table_set (sub, c, val, UNIPROP_TABLE_P (table)); if (ASCII_CHAR_P (c)) tbl->ascii = char_table_ascii (table); } @@ -384,30 +443,40 @@ } static void -sub_char_table_set_range (Lisp_Object *table, int depth, int min_char, int from, int to, Lisp_Object val) +sub_char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val, + int is_uniprop) { - int max_char = min_char + chartab_chars[depth] - 1; + struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table); + int depth = XINT ((tbl)->depth); + int min_char = XINT ((tbl)->min_char); + int chars_in_block = chartab_chars[depth]; + int i, c, lim = chartab_size[depth]; - if (depth == 3 || (from <= min_char && to >= max_char)) - *table = val; - else + if (from < min_char) + from = min_char; + i = CHARTAB_IDX (from, depth, min_char); + c = min_char + chars_in_block * i; + for (; i < lim; i++, c += chars_in_block) { - int i; - unsigned j; - - depth++; - if (! SUB_CHAR_TABLE_P (*table)) - *table = make_sub_char_table (depth, min_char, *table); - if (from < min_char) - from = min_char; - if (to > max_char) - to = max_char; - i = CHARTAB_IDX (from, depth, min_char); - j = CHARTAB_IDX (to, depth, min_char); - min_char += chartab_chars[depth] * i; - for (j++; i < j; i++, min_char += chartab_chars[depth]) - sub_char_table_set_range (XSUB_CHAR_TABLE (*table)->contents + i, - depth, min_char, from, to, val); + if (c > to) + break; + if (from <= c && c + chars_in_block - 1 <= to) + tbl->contents[i] = val; + else + { + Lisp_Object sub = tbl->contents[i]; + if (! SUB_CHAR_TABLE_P (sub)) + { + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (sub)) + sub = uniprop_table_uncompress (table, i); + else + { + sub = make_sub_char_table (depth + 1, c, sub); + tbl->contents[i] = sub; + } + } + sub_char_table_set_range (sub, from, to, val, is_uniprop); + } } } @@ -417,16 +486,33 @@ { struct Lisp_Char_Table *tbl = XCHAR_TABLE (table); Lisp_Object *contents = tbl->contents; - int i; if (from == to) char_table_set (table, from, val); else { - unsigned lim = to / chartab_chars[0] + 1; - for (i = CHARTAB_IDX (from, 0, 0); i < lim; i++) - sub_char_table_set_range (contents + i, 0, i * chartab_chars[0], - from, to, val); + int is_uniprop = UNIPROP_TABLE_P (table); + int lim = CHARTAB_IDX (to, 0, 0); + int i, c; + + for (i = CHARTAB_IDX (from, 0, 0), c = 0; i <= lim; + i++, c += chartab_chars[0]) + { + if (c > to) + break; + if (from <= c && c + chartab_chars[0] - 1 <= to) + tbl->contents[i] = val; + else + { + Lisp_Object sub = tbl->contents[i]; + if (! SUB_CHAR_TABLE_P (sub)) + { + sub = make_sub_char_table (1, i * chartab_chars[0], sub); + tbl->contents[i] = sub; + } + sub_char_table_set_range (sub, from, to, val, is_uniprop); + } + } if (ASCII_CHAR_P (from)) tbl->ascii = char_table_ascii (table); } @@ -504,6 +590,8 @@ (Lisp_Object char_table, Lisp_Object n, Lisp_Object value) { CHECK_CHAR_TABLE (char_table); + if (EQ (XCHAR_TABLE (char_table)->purpose, Qchar_code_property_table)) + error ("Can't change extra-slot of char-code-property-table"); CHECK_NUMBER (n); if (XINT (n) < 0 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) @@ -532,8 +620,9 @@ CHECK_CHARACTER_CAR (range); CHECK_CHARACTER_CDR (range); - val = char_table_ref_and_range (char_table, XFASTINT (XCAR (range)), - &from, &to); + from = XFASTINT (XCAR (range)); + to = XFASTINT (XCDR (range)); + val = char_table_ref_and_range (char_table, from, &from, &to); /* Not yet implemented. */ } else @@ -655,8 +744,7 @@ /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table), calling it for each character or group of characters that share a value. RANGE is a cons (FROM . TO) specifying the range of target - characters, VAL is a value of FROM in TABLE, DEFAULT_VAL is the - default value of the char-table, PARENT is the parent of the + characters, VAL is a value of FROM in TABLE, TOP is the top char-table. ARG is passed to C_FUNCTION when that is called. @@ -669,7 +757,7 @@ static Lisp_Object map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object function, Lisp_Object table, Lisp_Object arg, Lisp_Object val, - Lisp_Object range, Lisp_Object default_val, Lisp_Object parent) + Lisp_Object range, Lisp_Object top) { /* Pointer to the elements of TABLE. */ Lisp_Object *contents; @@ -681,6 +769,8 @@ int chars_in_block; int from = XINT (XCAR (range)), to = XINT (XCDR (range)); int i, c; + int is_uniprop = UNIPROP_TABLE_P (top); + uniprop_decoder_t decoder = UNIPROP_GET_DECODER (top); if (SUB_CHAR_TABLE_P (table)) { @@ -710,28 +800,33 @@ for (c = min_char + chars_in_block * i; c <= max_char; i++, c += chars_in_block) { - Lisp_Object this = contents[i]; + Lisp_Object this = (SUB_CHAR_TABLE_P (table) + ? XSUB_CHAR_TABLE (table)->contents[i] + : XCHAR_TABLE (table)->contents[i]); int nextc = c + chars_in_block; + if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this)) + this = uniprop_table_uncompress (table, i); if (SUB_CHAR_TABLE_P (this)) { if (to >= nextc) XSETCDR (range, make_number (nextc - 1)); val = map_sub_char_table (c_function, function, this, arg, - val, range, default_val, parent); + val, range, top); } else { if (NILP (this)) - this = default_val; + this = XCHAR_TABLE (top)->defalt; if (!EQ (val, this)) { int different_value = 1; if (NILP (val)) { - if (! NILP (parent)) + if (! NILP (XCHAR_TABLE (top)->parent)) { + Lisp_Object parent = XCHAR_TABLE (top)->parent; Lisp_Object temp = XCHAR_TABLE (parent)->parent; /* This is to get a value of FROM in PARENT @@ -742,8 +837,7 @@ XSETCDR (range, make_number (c - 1)); val = map_sub_char_table (c_function, function, parent, arg, val, range, - XCHAR_TABLE (parent)->defalt, - XCHAR_TABLE (parent)->parent); + parent); if (EQ (val, this)) different_value = 0; } @@ -756,14 +850,22 @@ if (c_function) (*c_function) (arg, XCAR (range), val); else - call2 (function, XCAR (range), val); + { + if (decoder) + val = decoder (top, val); + call2 (function, XCAR (range), val); + } } else { if (c_function) (*c_function) (arg, range, val); else - call2 (function, range, val); + { + if (decoder) + val = decoder (top, val); + call2 (function, range, val); + } } } val = this; @@ -783,35 +885,39 @@ ARG is passed to C_FUNCTION when that is called. */ void -map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object function, Lisp_Object table, Lisp_Object arg) +map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), + Lisp_Object function, Lisp_Object table, Lisp_Object arg) { - Lisp_Object range, val; - struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object range, val, parent; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + uniprop_decoder_t decoder = UNIPROP_GET_DECODER (table); range = Fcons (make_number (0), make_number (MAX_CHAR)); - GCPRO3 (table, arg, range); + parent = XCHAR_TABLE (table)->parent; + + GCPRO4 (table, arg, range, parent); val = XCHAR_TABLE (table)->ascii; if (SUB_CHAR_TABLE_P (val)) val = XSUB_CHAR_TABLE (val)->contents[0]; val = map_sub_char_table (c_function, function, table, arg, val, range, - XCHAR_TABLE (table)->defalt, - XCHAR_TABLE (table)->parent); + table); + /* If VAL is nil and TABLE has a parent, we must consult the parent recursively. */ while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent)) { - Lisp_Object parent = XCHAR_TABLE (table)->parent; - Lisp_Object temp = XCHAR_TABLE (parent)->parent; + Lisp_Object temp; int from = XINT (XCAR (range)); + parent = XCHAR_TABLE (table)->parent; + temp = XCHAR_TABLE (parent)->parent; /* This is to get a value of FROM in PARENT without checking the parent of PARENT. */ XCHAR_TABLE (parent)->parent = Qnil; val = CHAR_TABLE_REF (parent, from); XCHAR_TABLE (parent)->parent = temp; val = map_sub_char_table (c_function, function, parent, arg, val, range, - XCHAR_TABLE (parent)->defalt, - XCHAR_TABLE (parent)->parent); + parent); table = parent; } @@ -822,14 +928,22 @@ if (c_function) (*c_function) (arg, XCAR (range), val); else - call2 (function, XCAR (range), val); + { + if (decoder) + val = decoder (table, val); + call2 (function, XCAR (range), val); + } } else { if (c_function) (*c_function) (arg, range, val); else - call2 (function, range, val); + { + if (decoder) + val = decoder (table, val); + call2 (function, range, val); + } } } @@ -984,9 +1098,315 @@ } +/* Unicode character property tables. + + This section provides a convenient and efficient way to get a + Unicode character property from C code (from Lisp, you must use + get-char-code-property). + + The typical usage is to get a char-table for a specific property at + a proper initialization time as this: + + Lisp_Object bidi_class_table = uniprop_table (intern ("bidi-class")); + + and get a property value for character CH as this: + + Lisp_Object bidi_class = CHAR_TABLE_REF (CH, bidi_class_table); + + In this case, what you actually get is an index number to the + vector of property values (symbols nil, L, R, etc). + + A table for Unicode character property has these characteristics: + + o The purpose is `char-code-property-table', which implies that the + table has 5 extra slots. + + o The second extra slot is a Lisp function, an index (integer) to + the array uniprop_decoder[], or nil. If it is a Lisp function, we + can't use such a table from C (at the moment). If it is nil, it + means that we don't have to decode values. + + o The third extra slot is a Lisp function, an index (integer) to + the array uniprop_enncoder[], or nil. If it is a Lisp function, we + can't use such a table from C (at the moment). If it is nil, it + means that we don't have to encode values. */ + + +/* Uncompress the IDXth element of sub-char-table TABLE. */ + +static Lisp_Object +uniprop_table_uncompress (Lisp_Object table, int idx) +{ + Lisp_Object val = XSUB_CHAR_TABLE (table)->contents[idx]; + int min_char = (XINT (XSUB_CHAR_TABLE (table)->min_char) + + chartab_chars[2] * idx); + Lisp_Object sub = make_sub_char_table (3, min_char, Qnil); + struct Lisp_Sub_Char_Table *subtbl = XSUB_CHAR_TABLE (sub); + const unsigned char *p, *pend; + int i; + + XSUB_CHAR_TABLE (table)->contents[idx] = sub; + p = SDATA (val), pend = p + SBYTES (val); + if (*p == 1) + { + /* SIMPLE TABLE */ + p++; + idx = STRING_CHAR_ADVANCE (p); + while (p < pend && idx < chartab_chars[2]) + { + int v = STRING_CHAR_ADVANCE (p); + subtbl->contents[idx++] = v > 0 ? make_number (v) : Qnil; + } + } + else if (*p == 2) + { + /* RUN-LENGTH TABLE */ + p++; + for (idx = 0; p < pend; ) + { + int v = STRING_CHAR_ADVANCE (p); + int count = 1; + int len; + + if (p < pend) + { + count = STRING_CHAR_AND_LENGTH (p, len); + if (count < 128) + count = 1; + else + { + count -= 128; + p += len; + } + } + while (count-- > 0) + subtbl->contents[idx++] = make_number (v); + } + } +/* It seems that we don't need this function because C code won't need + to get a property that is compressed in this form. */ +#if 0 + else if (*p == 0) + { + /* WORD-LIST TABLE */ + } +#endif + return sub; +} + + +/* Decode VALUE as an elemnet of char-table TABLE. */ + +static Lisp_Object +uniprop_decode_value_run_length (Lisp_Object table, Lisp_Object value) +{ + if (VECTORP (XCHAR_TABLE (table)->extras[4])) + { + Lisp_Object valvec = XCHAR_TABLE (table)->extras[4]; + + if (XINT (value) >= 0 && XINT (value) < ASIZE (valvec)) + value = AREF (valvec, XINT (value)); + } + return value; +} + +static uniprop_decoder_t uniprop_decoder [] = + { uniprop_decode_value_run_length }; + +static int uniprop_decoder_count + = (sizeof uniprop_decoder) / sizeof (uniprop_decoder[0]); + + +/* Return the decoder of char-table TABLE or nil if none. */ + +static uniprop_decoder_t +uniprop_get_decoder (Lisp_Object table) +{ + int i; + + if (! INTEGERP (XCHAR_TABLE (table)->extras[1])) + return NULL; + i = XINT (XCHAR_TABLE (table)->extras[1]); + if (i < 0 || i >= uniprop_decoder_count) + return NULL; + return uniprop_decoder[i]; +} + + +/* Encode VALUE as an element of char-table TABLE which contains + characters as elements. */ + +static Lisp_Object +uniprop_encode_value_character (Lisp_Object table, Lisp_Object value) +{ + if (! NILP (value) && ! CHARACTERP (value)) + wrong_type_argument (Qintegerp, value); + return value; +} + + +/* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH + compression. */ + +static Lisp_Object +uniprop_encode_value_run_length (Lisp_Object table, Lisp_Object value) +{ + Lisp_Object *value_table = XVECTOR (XCHAR_TABLE (table)->extras[4])->contents; + int i, size = ASIZE (XCHAR_TABLE (table)->extras[4]); + + for (i = 0; i < size; i++) + if (EQ (value, value_table[i])) + break; + if (i == size) + wrong_type_argument (build_string ("Unicode property value"), value); + return make_number (i); +} + + +/* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH + compression and contains numbers as elements . */ + +static Lisp_Object +uniprop_encode_value_numeric (Lisp_Object table, Lisp_Object value) +{ + Lisp_Object *value_table = XVECTOR (XCHAR_TABLE (table)->extras[4])->contents; + int i, size = ASIZE (XCHAR_TABLE (table)->extras[4]); + + CHECK_NUMBER (value); + for (i = 0; i < size; i++) + if (EQ (value, value_table[i])) + break; + value = make_number (i); + if (i == size) + { + Lisp_Object args[2]; + + args[0] = XCHAR_TABLE (table)->extras[4]; + args[1] = Fmake_vector (make_number (1), value); + XCHAR_TABLE (table)->extras[4] = Fvconcat (2, args); + } + return make_number (i); +} + +static uniprop_encoder_t uniprop_encoder[] = + { uniprop_encode_value_character, + uniprop_encode_value_run_length, + uniprop_encode_value_numeric }; + +static int uniprop_encoder_count + = (sizeof uniprop_encoder) / sizeof (uniprop_encoder[0]); + + +/* Return the encoder of char-table TABLE or nil if none. */ + +static uniprop_decoder_t +uniprop_get_encoder (Lisp_Object table) +{ + int i; + + if (! INTEGERP (XCHAR_TABLE (table)->extras[2])) + return NULL; + i = XINT (XCHAR_TABLE (table)->extras[2]); + if (i < 0 || i >= uniprop_encoder_count) + return NULL; + return uniprop_encoder[i]; +} + +/* Return a char-table for Unicode character property PROP. This + function may load a Lisp file and thus may cause + garbage-collection. */ + +Lisp_Object +uniprop_table (Lisp_Object prop) +{ + Lisp_Object val, table, result; + + val = Fassq (prop, Vchar_code_property_alist); + if (! CONSP (val)) + return Qnil; + table = XCDR (val); + if (STRINGP (table)) + { + struct gcpro gcpro1; + GCPRO1 (val); + result = Fload (concat2 (build_string ("international/"), table), + Qt, Qt, Qt, Qt); + UNGCPRO; + if (NILP (result)) + return Qnil; + table = XCDR (val); + } + if (! CHAR_TABLE_P (table) + || ! UNIPROP_TABLE_P (table)) + return Qnil; + val = XCHAR_TABLE (table)->extras[1]; + if (INTEGERP (val) + ? (XINT (val) < 0 || XINT (val) >= uniprop_decoder_count) + : ! NILP (val)) + return Qnil; + /* Prepare ASCII values in advance for CHAR_TABLE_REF. */ + XCHAR_TABLE (table)->ascii = char_table_ascii (table); + return table; +} + +DEFUN ("unicode-property-table-internal", Funicode_property_table_internal, + Sunicode_property_table_internal, 1, 1, 0, + doc: /* Return a char-table for Unicode character property PROP. +Use `get-unicode-property-internal' and +`put-unicode-property-internal' instead of `aref' and `aset' to get +and put an element value. */) + (Lisp_Object prop) +{ + Lisp_Object table = uniprop_table (prop); + + if (CHAR_TABLE_P (table)) + return table; + return Fcdr (Fassq (prop, Vchar_code_property_alist)); +} + +DEFUN ("get-unicode-property-internal", Fget_unicode_property_internal, + Sget_unicode_property_internal, 2, 2, 0, + doc: /* Return an element of CHAR-TABLE for character CH. +CHAR-TABLE must be what returned by `unicode-property-table-internal'. */) + (Lisp_Object char_table, Lisp_Object ch) +{ + Lisp_Object val; + uniprop_decoder_t decoder; + + CHECK_CHAR_TABLE (char_table); + CHECK_CHARACTER (ch); + if (! UNIPROP_TABLE_P (char_table)) + error ("Invalid Unicode property table"); + val = CHAR_TABLE_REF (char_table, XINT (ch)); + decoder = uniprop_get_decoder (char_table); + return (decoder ? decoder (char_table, val) : val); +} + +DEFUN ("put-unicode-property-internal", Fput_unicode_property_internal, + Sput_unicode_property_internal, 3, 3, 0, + doc: /* Set an element of CHAR-TABLE for character CH to VALUE. +CHAR-TABLE must be what returned by `unicode-property-table-internal'. */) + (Lisp_Object char_table, Lisp_Object ch, Lisp_Object value) +{ + uniprop_encoder_t encoder; + + CHECK_CHAR_TABLE (char_table); + CHECK_CHARACTER (ch); + if (! UNIPROP_TABLE_P (char_table)) + error ("Invalid Unicode property table"); + encoder = uniprop_get_encoder (char_table); + if (encoder) + value = encoder (char_table, value); + CHAR_TABLE_SET (char_table, XINT (ch), value); + return Qnil; +} + + void syms_of_chartab (void) { + DEFSYM (Qchar_code_property_table, "char-code-property-table"); + defsubr (&Smake_char_table); defsubr (&Schar_table_parent); defsubr (&Schar_table_subtype); @@ -998,4 +1418,19 @@ defsubr (&Sset_char_table_default); defsubr (&Soptimize_char_table); defsubr (&Smap_char_table); + defsubr (&Sunicode_property_table_internal); + defsubr (&Sget_unicode_property_internal); + defsubr (&Sput_unicode_property_internal); + + /* Each element has the form (PROP . TABLE). + PROP is a symbol representing a character property. + TABLE is a char-table containing the property value for each character. + TABLE may be a name of file to load to build a char-table. + This variable should be modified only through + `define-char-code-property'. */ + + DEFVAR_LISP ("char-code-property-alist", Vchar_code_property_alist, + doc: /* Alist of character property name vs char-table containing property values. +Internal use only. */); + Vchar_code_property_alist = Qnil; } === modified file 'src/composite.c' --- src/composite.c 2011-06-24 21:25:22 +0000 +++ src/composite.c 2011-07-06 23:28:00 +0000 @@ -976,9 +976,8 @@ ((C) > ' ' \ && ((C) == 0x200C || (C) == 0x200D \ || (_work_val = CHAR_TABLE_REF (Vunicode_category_table, (C)), \ - (SYMBOLP (_work_val) \ - && (_work_char = SDATA (SYMBOL_NAME (_work_val))[0]) != 'C' \ - && _work_char != 'Z')))) + (INTEGERP (_work_val) \ + && (XINT (_work_val) <= UNICODE_CATEGORY_So))))) /* Update cmp_it->stop_pos to the next position after CHARPOS (and BYTEPOS) where character composition may happen. If BYTEPOS is === modified file 'src/dispextern.h' --- src/dispextern.h 2011-06-22 18:15:23 +0000 +++ src/dispextern.h 2011-07-06 22:43:48 +0000 @@ -1773,7 +1773,11 @@ /* Data type for describing the bidirectional character types. The first 7 must be at the beginning, because they are the only values valid in the `bidi_type' member of `struct glyph'; we only reserve - 3 bits for it, so we cannot use there values larger than 7. */ + 3 bits for it, so we cannot use there values larger than 7. + + The order of members must be in sync with the 8th element of the + member of unidata-prop-alist (in admin/unidata/unidata-getn.el) for + Unicode character property `bidi-class'. */ typedef enum { UNKNOWN_BT = 0, STRONG_L, /* strong left-to-right */ === modified file 'src/font.c' --- src/font.c 2011-06-22 06:18:06 +0000 +++ src/font.c 2011-07-06 22:43:48 +0000 @@ -3739,8 +3739,9 @@ else FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte); category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (EQ (category, QCf) - || CHAR_VARIATION_SELECTOR_P (c)) + if (INTEGERP (category) + && (XINT (category) == UNICODE_CATEGORY_Cf + || CHAR_VARIATION_SELECTOR_P (c))) continue; if (NILP (font_object)) { ------------------------------------------------------------ revno: 105006 committer: Dan Nicolaescu branch nick: trunk timestamp: Wed 2011-07-06 20:24:33 -0700 message: Simplify Irix build, remove iris4d.h file. * configure.in: Remove reference to iris4d.h. * src/m/iris4d.h: Remove file, move contents ... * src/s/irix6-5.h: ... here. diff: === modified file 'ChangeLog' --- ChangeLog 2011-07-05 08:21:38 +0000 +++ ChangeLog 2011-07-07 03:24:33 +0000 @@ -1,3 +1,7 @@ +2011-07-07 Dan Nicolaescu + + * configure.in: Remove reference to iris4d.h. + 2011-07-05 Jan Djärv * configure.in (HAVE_GCONF): Allow both HAVE_GCONF and HAVE_GSETTINGS. === modified file 'configure.in' --- configure.in 2011-07-05 08:21:38 +0000 +++ configure.in 2011-07-07 03:24:33 +0000 @@ -536,7 +536,7 @@ ## Silicon Graphics machines ## Iris 4D mips-sgi-irix6.5 ) - machine=iris4d opsys=irix6-5 + opsys=irix6-5 # Without defining _LANGUAGE_C, things get masked out in the headers # so that, for instance, grepping for `free' in stdlib.h fails and # AC_HEADER_STD_C fails. (MIPSPro 7.2.1.2m compilers, Irix 6.5.3m). === modified file 'src/ChangeLog' --- src/ChangeLog 2011-07-06 22:22:32 +0000 +++ src/ChangeLog 2011-07-07 03:24:33 +0000 @@ -1,3 +1,8 @@ +2011-07-07 Dan Nicolaescu + + * m/iris4d.h: Remove file, move contents ... + * s/irix6-5.h: ... here. + 2011-07-06 Paul Eggert Remove unportable assumption about struct layout (Bug#8884). === removed file 'src/m/iris4d.h' --- src/m/iris4d.h 2011-01-25 04:08:28 +0000 +++ src/m/iris4d.h 1970-01-01 00:00:00 +0000 @@ -1,26 +0,0 @@ -/* machine description file for Iris-4D machines. Use with s/irix*.h. - -Copyright (C) 1987, 2001-2011 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or -(at your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see . */ - - -/* DATA_SEG_BITS forces extra bits to be or'd in with any pointers which - were stored in a Lisp_Object (as Emacs uses fewer than 32 bits for - the value field of a LISP_OBJECT). */ -#define DATA_START 0x10000000 -#define DATA_SEG_BITS 0x10000000 - === modified file 'src/s/irix6-5.h' --- src/s/irix6-5.h 2011-03-17 02:36:27 +0000 +++ src/s/irix6-5.h 2011-07-07 03:24:33 +0000 @@ -96,3 +96,10 @@ /* Tested on Irix 6.5. SCM worked on earlier versions. */ #define GC_SETJMP_WORKS 1 #define GC_MARK_STACK GC_MAKE_GCPROS_NOOPS + + +/* DATA_SEG_BITS forces extra bits to be or'd in with any pointers which + were stored in a Lisp_Object (as Emacs uses fewer than 32 bits for + the value field of a LISP_OBJECT). */ +#define DATA_START 0x10000000 +#define DATA_SEG_BITS 0x10000000 ------------------------------------------------------------ revno: 105005 committer: Chong Yidong branch nick: trunk timestamp: Wed 2011-07-06 21:48:14 -0400 message: Tweak to `button' face in custom themes. * etc/themes/dichromacy-theme.el: * etc/themes/tango-theme.el: * etc/themes/tango-dark-theme.el: * etc/themes/wheatgrass-theme.el: Don't define button face separately; it inherits from link now. diff: === modified file 'etc/ChangeLog' --- etc/ChangeLog 2011-07-06 16:50:34 +0000 +++ etc/ChangeLog 2011-07-07 01:48:14 +0000 @@ -1,3 +1,11 @@ +2011-07-07 Chong Yidong + + * themes/dichromacy-theme.el: + * themes/tango-theme.el: + * themes/tango-dark-theme.el: + * themes/wheatgrass-theme.el: Don't define button face separately; + it inherits from link now. + 2011-07-06 Lars Magne Ingebrigtsen * NEWS: Clarify that `smtpmail-starttls-credentials' doesn't exist. === modified file 'etc/themes/dichromacy-theme.el' --- etc/themes/dichromacy-theme.el 2011-06-14 05:00:35 +0000 +++ etc/themes/dichromacy-theme.el 2011-07-07 01:48:14 +0000 @@ -72,7 +72,6 @@ `(font-lock-warning-face ((,class (:weight bold :slant italic :foreground ,vermillion)))) ;; Button and link faces - `(button ((,class (:underline t :foreground ,blue)))) `(link ((,class (:underline t :foreground ,blue)))) `(link-visited ((,class (:underline t :foreground ,redpurple)))) ;; Gnus faces === modified file 'etc/themes/tango-dark-theme.el' --- etc/themes/tango-dark-theme.el 2011-06-14 05:06:26 +0000 +++ etc/themes/tango-dark-theme.el 2011-07-07 01:48:14 +0000 @@ -86,7 +86,6 @@ `(font-lock-variable-name-face ((,class (:foreground ,orange-1)))) `(font-lock-warning-face ((,class (:foreground ,red-0)))) ;; Button and link faces - `(button ((,class (:underline t :foreground ,blue-1)))) `(link ((,class (:underline t :foreground ,blue-1)))) `(link-visited ((,class (:underline t :foreground ,blue-2)))) ;; Gnus faces === modified file 'etc/themes/tango-theme.el' --- etc/themes/tango-theme.el 2011-06-14 05:06:26 +0000 +++ etc/themes/tango-theme.el 2011-07-07 01:48:14 +0000 @@ -77,7 +77,6 @@ `(font-lock-variable-name-face ((,class (:foreground ,orange-4)))) `(font-lock-warning-face ((,class (:foreground ,red-2)))) ;; Button and link faces - `(button ((,class (:underline t :foreground ,blue-3)))) `(link ((,class (:underline t :foreground ,blue-3)))) `(link-visited ((,class (:underline t :foreground ,blue-2)))) ;; Gnus faces === modified file 'etc/themes/wheatgrass-theme.el' --- etc/themes/wheatgrass-theme.el 2011-06-14 05:06:26 +0000 +++ etc/themes/wheatgrass-theme.el 2011-07-07 01:48:14 +0000 @@ -47,7 +47,6 @@ `(font-lock-variable-name-face ((,class (:foreground "yellow green")))) `(font-lock-warning-face ((,class (:foreground "salmon1")))) ;; Button and link faces - `(button ((,class (:underline t :foreground "cyan")))) `(link ((,class (:underline t :foreground "cyan")))) `(link-visited ((,class (:underline t :foreground "dark cyan")))) ;; Gnus faces ------------------------------------------------------------ revno: 105004 committer: Chong Yidong branch nick: trunk timestamp: Wed 2011-07-06 21:46:59 -0400 message: Error in next-buffer or previous-buffer if called from minibuffer. * lisp/window.el (next-buffer, previous-buffer): Signal an error if called from a minibuffer window. * lisp/bindings.el: Revert 2011-07-04 change. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 22:43:46 +0000 +++ lisp/ChangeLog 2011-07-07 01:46:59 +0000 @@ -1,3 +1,10 @@ +2011-07-07 Chong Yidong + + * window.el (next-buffer, previous-buffer): Signal an error if + called from a minibuffer window. + + * bindings.el: Revert 2011-07-04 change. + 2011-07-06 Richard Stallman * mail/rmailmm.el (rmail-mime-process): Use markers for buf positions. === modified file 'lisp/bindings.el' --- lisp/bindings.el 2011-07-05 15:31:22 +0000 +++ lisp/bindings.el 2011-07-07 01:46:59 +0000 @@ -807,8 +807,6 @@ (define-key map [up] 'previous-history-element) (define-key map "\es" 'next-matching-history-element) (define-key map "\er" 'previous-matching-history-element) - (define-key map [remap next-buffer] 'ignore) - (define-key map [remap previous-buffer] 'ignore) ;; Override the global binding (which calls indent-relative via ;; indent-for-tab-command). The alignment that indent-relative tries to ;; do doesn't make much sense here since the prompt messes it up. === modified file 'lisp/mail/rmail.el' --- lisp/mail/rmail.el 2011-06-27 10:23:19 +0000 +++ lisp/mail/rmail.el 2011-07-07 01:46:59 +0000 @@ -4379,7 +4379,7 @@ ;;;*** -;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "30ab95e291380f184dff5fa6cde75520") +;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "a7d3e7205efa4e20ca9038c9b260ce83") ;;; Generated autoloads from rmailmm.el (autoload 'rmail-mime "rmailmm" "\ === modified file 'lisp/window.el' --- lisp/window.el 2011-07-06 02:46:22 +0000 +++ lisp/window.el 2011-07-07 01:46:59 +0000 @@ -2819,11 +2819,15 @@ (defun next-buffer () "In selected window switch to next buffer." (interactive) + (if (window-minibuffer-p) + (error "Cannot switch buffers in minibuffer window")) (switch-to-next-buffer)) (defun previous-buffer () "In selected window switch to previous buffer." (interactive) + (if (window-minibuffer-p) + (error "Cannot switch buffers in minibuffer window")) (switch-to-prev-buffer)) (defun delete-windows-on (&optional buffer-or-name frame) ------------------------------------------------------------ revno: 105003 committer: Richard Stallman branch nick: trunk timestamp: Wed 2011-07-06 18:43:46 -0400 message: Rmail mime: Use markers for positions in entities. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 21:34:13 +0000 +++ lisp/ChangeLog 2011-07-06 22:43:46 +0000 @@ -1,3 +1,10 @@ +2011-07-06 Richard Stallman + + * mail/rmailmm.el (rmail-mime-process): Use markers for buf positions. + (rmail-mime-insert-bulk, rmail-mime-insert-text): + Treat markers like ints. + (rmail-mime-entity): Doc fix. + 2011-07-06 Lars Magne Ingebrigtsen * mail/smtpmail.el (smtpmail-default-smtp-server): Made into a === modified file 'lisp/mail/rmailmm.el' --- lisp/mail/rmailmm.el 2011-07-06 16:48:37 +0000 +++ lisp/mail/rmailmm.el 2011-07-06 22:43:46 +0000 @@ -193,8 +193,8 @@ raw: displayed by the raw MIME data (for the header and body only) HEADER and BODY are vectors [BEG END DISPLAY-FLAG], where BEG and -END specify the region of the header or body lines in RMAIL's -data (mbox) buffer, and DISPLAY-FLAG non-nil means that the +END are markers that specify the region of the header or body lines +in RMAIL's data (mbox) buffer, and DISPLAY-FLAG non-nil means that the header or body is, by default, displayed by the decoded presentation form. @@ -547,7 +547,7 @@ (beg (point)) (segment (rmail-mime-entity-segment (point) entity))) - (or (integerp (aref body 0)) + (or (integerp (aref body 0)) (markerp (aref body 0)) (let ((data (buffer-string))) (aset body 0 data) (delete-region (point-min) (point-max)))) @@ -704,7 +704,7 @@ (segment (rmail-mime-entity-segment (point) entity)) beg data size) - (if (integerp (aref body 0)) + (if (or (integerp (aref body 0)) (markerp (aref body 0))) (setq data entity size (car bulk-data)) (if (stringp (aref body 0)) @@ -1129,9 +1129,10 @@ (if parse-tag (let* ((is-inline (string= (car content-disposition) "inline")) - (header (vector (point-min) end nil)) + (hdr-end (copy-marker end)) + (header (vector (point-min-marker) hdr-end nil)) (tagline (vector parse-tag (cons nil nil) t)) - (body (vector end (point-max) is-inline)) + (body (vector hdr-end (point-max-marker) is-inline)) (new (vector (aref header 2) (aref tagline 2) (aref body 2))) children handler entity) (cond ((string-match "multipart/.*" (car content-type)) @@ -1180,11 +1181,11 @@ ;; Hide headers and handle the part. (put-text-property (point-min) (point-max) 'rmail-mime-entity (rmail-mime-entity - content-type content-disposition - content-transfer-encoding - (vector (vector 'raw nil 'raw) (vector 'raw nil 'raw)) - (vector nil nil 'raw) (vector "" (cons nil nil) nil) - (vector nil nil 'raw) nil nil)) + content-type content-disposition + content-transfer-encoding + (vector (vector 'raw nil 'raw) (vector 'raw nil 'raw)) + (vector nil nil 'raw) (vector "" (cons nil nil) nil) + (vector nil nil 'raw) nil nil)) (save-restriction (cond ((string= (car content-type) "message/rfc822") (narrow-to-region end (point-max))) ------------------------------------------------------------ revno: 105002 committer: Katsumi Yamaoka branch nick: trunk timestamp: Wed 2011-07-06 22:39:47 +0000 message: lisp/gnus/ChangeLog (2011-07-04): Add missing entry. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-07-06 02:45:24 +0000 +++ lisp/gnus/ChangeLog 2011-07-06 22:39:47 +0000 @@ -34,6 +34,9 @@ 2011-07-04 Lars Magne Ingebrigtsen + * gnus-group.el (gnus-read-ephemeral-bug-group): Allow fetching several + bug reports at once. + * nnimap.el (nnimap-request-scan): Say that splitting has finished. 2011-07-04 Katsumi Yamaoka ------------------------------------------------------------ revno: 105001 [merge] committer: Paul Eggert branch nick: trunk timestamp: Wed 2011-07-06 15:23:30 -0700 message: Merge: Remove more assumptions re struct layout (Bug#8884). diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2011-07-06 21:53:56 +0000 +++ src/ChangeLog 2011-07-06 22:22:32 +0000 @@ -1,7 +1,9 @@ 2011-07-06 Paul Eggert Remove unportable assumption about struct layout (Bug#8884). - * buffer.c (clone_per_buffer_values): Don't assume that + * alloc.c (mark_buffer): + * buffer.c (reset_buffer_local_variables, Fbuffer_local_variables) + (clone_per_buffer_values): Don't assume that sizeof (struct buffer) is a multiple of sizeof (Lisp_Object). This isn't true in general, and it's particularly not true if Emacs is configured with --with-wide-int. === modified file 'src/alloc.c' --- src/alloc.c 2011-06-24 21:25:22 +0000 +++ src/alloc.c 2011-07-06 22:22:32 +0000 @@ -5619,7 +5619,8 @@ /* buffer-local Lisp variables start at `undo_list', tho only the ones from `name' on are GC'd normally. */ for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name); - (char *)ptr < (char *)buffer + sizeof (struct buffer); + ptr <= &PER_BUFFER_VALUE (buffer, + PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER)); ptr++) mark_object (*ptr); === modified file 'src/buffer.c' --- src/buffer.c 2011-07-06 21:53:56 +0000 +++ src/buffer.c 2011-07-06 22:22:32 +0000 @@ -830,8 +830,8 @@ /* buffer-local Lisp variables start at `undo_list', tho only the ones from `name' on are GC'd normally. */ - for (offset = PER_BUFFER_VAR_OFFSET (undo_list); - offset < sizeof *b; + for (offset = PER_BUFFER_VAR_OFFSET (FIRST_FIELD_PER_BUFFER); + offset <= PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER); offset += sizeof (Lisp_Object)) { int idx = PER_BUFFER_IDX (offset); @@ -1055,8 +1055,8 @@ /* buffer-local Lisp variables start at `undo_list', tho only the ones from `name' on are GC'd normally. */ - for (offset = PER_BUFFER_VAR_OFFSET (undo_list); - offset < sizeof (struct buffer); + for (offset = PER_BUFFER_VAR_OFFSET (FIRST_FIELD_PER_BUFFER); + offset <= PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER); /* sizeof EMACS_INT == sizeof Lisp_Object */ offset += (sizeof (EMACS_INT))) { ------------------------------------------------------------ revno: 105000 [merge] fixes bug(s): http://debbugs.gnu.org/8884 committer: Paul Eggert branch nick: trunk timestamp: Wed 2011-07-06 14:56:44 -0700 message: Merge: Remove unportable assumption about struct layout (Bug#8884). * buffer.c (clone_per_buffer_values): Don't assume that sizeof (struct buffer) is a multiple of sizeof (Lisp_Object). This isn't true in general, and it's particularly not true if Emacs is configured with --with-wide-int. * buffer.h (FIRST_FIELD_PER_BUFFER, LAST_FIELD_PER_BUFFER): New macros, used in the buffer.c change. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2011-07-05 09:51:56 +0000 +++ src/ChangeLog 2011-07-06 21:53:56 +0000 @@ -1,3 +1,13 @@ +2011-07-06 Paul Eggert + + Remove unportable assumption about struct layout (Bug#8884). + * buffer.c (clone_per_buffer_values): Don't assume that + sizeof (struct buffer) is a multiple of sizeof (Lisp_Object). + This isn't true in general, and it's particularly not true + if Emacs is configured with --with-wide-int. + * buffer.h (FIRST_FIELD_PER_BUFFER, LAST_FIELD_PER_BUFFER): + New macros, used in the buffer.c change. + 2011-07-05 Jan Djärv * xsettings.c: Use both GConf and GSettings if both are available. === modified file 'src/buffer.c' --- src/buffer.c 2011-07-04 15:32:22 +0000 +++ src/buffer.c 2011-07-06 21:53:56 +0000 @@ -471,8 +471,8 @@ /* buffer-local Lisp variables start at `undo_list', tho only the ones from `name' on are GC'd normally. */ - for (offset = PER_BUFFER_VAR_OFFSET (undo_list); - offset < sizeof *to; + for (offset = PER_BUFFER_VAR_OFFSET (FIRST_FIELD_PER_BUFFER); + offset <= PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER); offset += sizeof (Lisp_Object)) { Lisp_Object obj; === modified file 'src/buffer.h' --- src/buffer.h 2011-06-21 21:32:10 +0000 +++ src/buffer.h 2011-07-06 21:53:56 +0000 @@ -612,6 +612,7 @@ /* Everything from here down must be a Lisp_Object. */ /* buffer-local Lisp variables start at `undo_list', tho only the ones from `name' on are GC'd normally. */ + #define FIRST_FIELD_PER_BUFFER undo_list /* Changes in the buffer are recorded here for undo. t means don't record anything. @@ -846,6 +847,9 @@ t means to use hollow box cursor. See `cursor-type' for other values. */ Lisp_Object BUFFER_INTERNAL_FIELD (cursor_in_non_selected_windows); + + /* This must be the last field in the above list. */ + #define LAST_FIELD_PER_BUFFER cursor_in_non_selected_windows }; ------------------------------------------------------------ revno: 104999 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 23:34:13 +0200 message: * mail/smtpmail.el (smtpmail-default-smtp-server): Made into a defcustom again for backwards compatibility. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 19:44:09 +0000 +++ lisp/ChangeLog 2011-07-06 21:34:13 +0000 @@ -1,5 +1,8 @@ 2011-07-06 Lars Magne Ingebrigtsen + * mail/smtpmail.el (smtpmail-default-smtp-server): Made into a + defcustom again for backwards compatibility. + * simple.el (shell-command-on-region): Fill. * dired-aux.el (dired-kill-line): Add a doc string. === modified file 'lisp/mail/smtpmail.el' --- lisp/mail/smtpmail.el 2011-06-28 15:30:45 +0000 +++ lisp/mail/smtpmail.el 2011-07-06 21:34:13 +0000 @@ -71,9 +71,11 @@ :group 'mail) -(defvar smtpmail-default-smtp-server nil +(defcustom smtpmail-default-smtp-server nil "Specify default SMTP server. -This only has effect if you specify it before loading the smtpmail library.") +This only has effect if you specify it before loading the smtpmail library." + :type '(choice (const nil) string) + :group 'smtpmail) (defcustom smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) ------------------------------------------------------------ revno: 104998 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 21:44:09 +0200 message: * simple.el (shell-command-on-region): Fill. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 18:26:29 +0000 +++ lisp/ChangeLog 2011-07-06 19:44:09 +0000 @@ -1,5 +1,7 @@ 2011-07-06 Lars Magne Ingebrigtsen + * simple.el (shell-command-on-region): Fill. + * dired-aux.el (dired-kill-line): Add a doc string. * dabbrev.el (dabbrev-abbrev-char-regexp): Note that nil defaults === modified file 'lisp/simple.el' --- lisp/simple.el 2011-07-02 20:59:18 +0000 +++ lisp/simple.el 2011-07-06 19:44:09 +0000 @@ -2533,7 +2533,8 @@ (< 0 (nth 7 (file-attributes error-file)))) (format "some error output%s" (if shell-command-default-error-buffer - (format " to the \"%s\" buffer" shell-command-default-error-buffer) + (format " to the \"%s\" buffer" + shell-command-default-error-buffer) "")) "no output"))) (cond ((null exit-status) ------------------------------------------------------------ revno: 104997 fixes bug(s): http://debbugs.gnu.org/1001 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 20:34:55 +0200 message: * functions.texi (Calling Functions): Link to the "Interactive Call" node. diff: === modified file 'doc/lispref/ChangeLog' --- doc/lispref/ChangeLog 2011-07-06 02:42:10 +0000 +++ doc/lispref/ChangeLog 2011-07-06 18:34:55 +0000 @@ -1,3 +1,8 @@ +2011-07-06 Lars Magne Ingebrigtsen + + * functions.texi (Calling Functions): Link to the "Interactive + Call" node (bug#1001). + 2011-07-06 Chong Yidong * customize.texi (Composite Types): Move alist and plist to here === modified file 'doc/lispref/functions.texi' --- doc/lispref/functions.texi 2011-07-03 12:33:37 +0000 +++ doc/lispref/functions.texi 2011-07-06 18:34:55 +0000 @@ -790,6 +790,12 @@ This function ignores any arguments and returns @code{nil}. @end defun + Emacs Lisp functions can also be user-visible @dfn{commands}. A +command is a function that has an @dfn{interactive} specification. +You may want to call these functions as if they were called +interactively. See @ref{Interactive Call} for details on how to do +that. + @node Mapping Functions @section Mapping Functions @cindex mapping functions ------------------------------------------------------------ revno: 104996 fixes bug(s): http://debbugs.gnu.org/957 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 20:26:29 +0200 message: * dired-aux.el (dired-kill-line): Add a doc string. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 17:45:01 +0000 +++ lisp/ChangeLog 2011-07-06 18:26:29 +0000 @@ -1,5 +1,7 @@ 2011-07-06 Lars Magne Ingebrigtsen + * dired-aux.el (dired-kill-line): Add a doc string. + * dabbrev.el (dabbrev-abbrev-char-regexp): Note that nil defaults to "\\sw\\|\\s_" (bug#358). === modified file 'lisp/dired-aux.el' --- lisp/dired-aux.el 2011-07-05 09:51:56 +0000 +++ lisp/dired-aux.el 2011-07-06 18:26:29 +0000 @@ -699,6 +699,9 @@ ;; Commands that delete or redisplay part of the dired buffer. (defun dired-kill-line (&optional arg) + "Kill the current line (not the files). +With a prefix argument, kill that many lines starting with the current line. +\(A negative argument kills backward.)" (interactive "P") (setq arg (prefix-numeric-value arg)) (let (buffer-read-only file) ------------------------------------------------------------ revno: 104995 fixes bug(s): http://debbugs.gnu.org/358 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 19:45:01 +0200 message: * dabbrev.el (dabbrev-abbrev-char-regexp): Note that nil defaults to "\\sw\\|\\s_" (bug#358). diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 17:10:36 +0000 +++ lisp/ChangeLog 2011-07-06 17:45:01 +0000 @@ -1,5 +1,8 @@ 2011-07-06 Lars Magne Ingebrigtsen + * dabbrev.el (dabbrev-abbrev-char-regexp): Note that nil defaults + to "\\sw\\|\\s_" (bug#358). + * dired.el (dired-mode): Clarify "unmark or unflag" (bug#8770). (dired-unmark-backward): Ditto. (dired-flag-backup-files): Ditto. === modified file 'lisp/dabbrev.el' --- lisp/dabbrev.el 2011-04-19 13:44:55 +0000 +++ lisp/dabbrev.el 2011-07-06 17:45:01 +0000 @@ -206,7 +206,8 @@ expanding `yes-or-no-' signals an error because `-' is not part of a word; but expanding `yes-or-no' looks for a word starting with `no'. -The recommended value is \"\\\\sw\\\\|\\\\s_\"." +The recommended value is nil, which will make dabbrev default to +using \"\\\\sw\\\\|\\\\s_\"." :type '(choice (const nil) regexp) :group 'dabbrev) ------------------------------------------------------------ revno: 104994 fixes bug(s): http://debbugs.gnu.org/8770 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 19:10:36 +0200 message: * dired.el (dired-mode): Clarify "unmark or unflag". (dired-unmark-backward): Ditto. (dired-flag-backup-files): Ditto. * dired-x.el (dired-mark-sexp): Ditto. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 16:48:37 +0000 +++ lisp/ChangeLog 2011-07-06 17:10:36 +0000 @@ -1,3 +1,11 @@ +2011-07-06 Lars Magne Ingebrigtsen + + * dired.el (dired-mode): Clarify "unmark or unflag" (bug#8770). + (dired-unmark-backward): Ditto. + (dired-flag-backup-files): Ditto. + + * dired-x.el (dired-mark-sexp): Ditto. + 2011-07-06 Richard Stallman * mail/rmailmm.el: Give entity a new slot, TRUNCATED. === modified file 'lisp/dired-x.el' --- lisp/dired-x.el 2011-06-18 20:17:30 +0000 +++ lisp/dired-x.el 2011-07-06 17:10:36 +0000 @@ -1406,7 +1406,7 @@ (defun dired-mark-sexp (predicate &optional unflag-p) "Mark files for which PREDICATE returns non-nil. -With a prefix arg, unflag those files instead. +With a prefix arg, unmark or unflag those files instead. PREDICATE is a lisp expression that can refer to the following symbols: === modified file 'lisp/dired.el' --- lisp/dired.el 2011-07-05 10:24:56 +0000 +++ lisp/dired.el 2011-07-06 17:10:36 +0000 @@ -1812,7 +1812,7 @@ Mark-using commands display a list of failures afterwards. Type \\[dired-summary] to see why something went wrong. Type \\[dired-unmark] to Unmark a file or all files of an inserted subdirectory. -Type \\[dired-unmark-backward] to back up one line and unflag. +Type \\[dired-unmark-backward] to back up one line and unmark or unflag. Type \\[dired-do-flagged-delete] to delete (eXecute) the files flagged `D'. Type \\[dired-find-file] to Find the current line's file (or dired it in another buffer, if it is a directory). @@ -3028,8 +3028,9 @@ (dired-mark arg))) (defun dired-unmark-backward (arg) - "In Dired, move up lines and remove deletion flag there. -Optional prefix ARG says how many lines to unflag; default is one line." + "In Dired, move up lines and remove marks or deletion flags there. +Optional prefix ARG says how many lines to unmark/unflag; default +is one line." (interactive "p") (dired-unmark (- arg))) @@ -3123,14 +3124,14 @@ (defun dired-mark-symlinks (unflag-p) "Mark all symbolic links. -With prefix argument, unflag all those files." +With prefix argument, unmark or unflag all those files." (interactive "P") (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) (dired-mark-if (looking-at dired-re-sym) "symbolic link"))) (defun dired-mark-directories (unflag-p) "Mark all directory file lines except `.' and `..'. -With prefix argument, unflag all those files." +With prefix argument, unmark or unflag all those files." (interactive "P") (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) (dired-mark-if (and (looking-at dired-re-dir) @@ -3139,7 +3140,7 @@ (defun dired-mark-executables (unflag-p) "Mark all executable files. -With prefix argument, unflag all those files." +With prefix argument, unmark or unflag all those files." (interactive "P") (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) (dired-mark-if (looking-at dired-re-exe) "executable file"))) @@ -3149,7 +3150,7 @@ (defun dired-flag-auto-save-files (&optional unflag-p) "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unflag those files instead." +A prefix argument says to unmark or unflag those files instead." (interactive "P") (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) (dired-mark-if @@ -3189,7 +3190,7 @@ (defun dired-flag-backup-files (&optional unflag-p) "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unflag these files." +With prefix argument, unmark or unflag these files." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-del-marker))) (dired-mark-if ------------------------------------------------------------ revno: 104993 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 18:50:34 +0200 message: * NEWS: Clarify that `smtpmail-starttls-credentials' doesn't exist. diff: === modified file 'etc/ChangeLog' --- etc/ChangeLog 2011-07-05 11:38:44 +0000 +++ etc/ChangeLog 2011-07-06 16:50:34 +0000 @@ -1,3 +1,7 @@ +2011-07-06 Lars Magne Ingebrigtsen + + * NEWS: Clarify that `smtpmail-starttls-credentials' doesn't exist. + 2011-07-05 Juanma Barranquero * NEWS: Document new emacs-lock.el and renaming of old one. === modified file 'etc/NEWS' --- etc/NEWS 2011-07-05 17:44:15 +0000 +++ etc/NEWS 2011-07-06 16:50:34 +0000 @@ -130,8 +130,8 @@ you will be prompted for the user name and the password instead, and they will then be saved to ~/.authinfo. -** Similarly, if you had `smtpmail-starttls-credentials' set, then -then you need to put +** Similarly, `smtpmail-starttls-credentials' no longer exists. If +you had thet set, then then you need to put machine smtp.whatever.foo port 25 key "~/.my_smtp_tls.key" cert "~/.my_smtp_tls.cert" ------------------------------------------------------------ revno: 104992 committer: Richard Stallman branch nick: trunk timestamp: Wed 2011-07-06 12:48:37 -0400 message: Fix rmail mime search bug when entity is a string. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 16:46:27 +0000 +++ lisp/ChangeLog 2011-07-06 16:48:37 +0000 @@ -8,6 +8,9 @@ (rmail-mime-toggle-hidden): Likewise, for showing. (rmail-mime-process-multipart): Record when an entity is truncated. + * mail/rmailmm.el (rmail-search-mime-message): Don't get confused + if ENTITY is a string. + 2011-07-06 Lars Magne Ingebrigtsen * emacs-lisp/lisp-mode.el (eval-defun-1): Update the documentation === modified file 'lisp/mail/rmailmm.el' --- lisp/mail/rmailmm.el 2011-07-06 16:44:33 +0000 +++ lisp/mail/rmailmm.el 2011-07-06 16:48:37 +0000 @@ -1408,6 +1408,8 @@ (re-search-forward regexp nil t)) ;; Next, search the body. (if (and entity + ;; RMS: I am not sure why, but sometimes this is a string. + (not (stringp entity)) (let* ((content-type (rmail-mime-entity-type entity)) (charset (cdr (assq 'charset (cdr content-type))))) (or (not (string-match "text/.*" (car content-type))) ------------------------------------------------------------ revno: 104991 fixes bug(s): http://debbugs.gnu.org/8378 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 18:46:27 +0200 message: * emacs-lisp/lisp-mode.el (eval-defun-1): Update the documentation of faces when `M-C-x'-ing their definitions. Also clean up the code slightly. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 16:44:33 +0000 +++ lisp/ChangeLog 2011-07-06 16:46:27 +0000 @@ -10,6 +10,10 @@ 2011-07-06 Lars Magne Ingebrigtsen + * emacs-lisp/lisp-mode.el (eval-defun-1): Update the documentation + of faces when `M-C-x'-ing their definitions (bug#8378). Also + clean up the code slightly. + * progmodes/grep.el (rgrep): Don't bind `process-connection-type', because that makes the colours go away. === modified file 'lisp/emacs-lisp/lisp-mode.el' --- lisp/emacs-lisp/lisp-mode.el 2011-07-05 18:26:33 +0000 +++ lisp/emacs-lisp/lisp-mode.el 2011-07-06 16:46:27 +0000 @@ -789,25 +789,25 @@ ;; `defface' is macroexpanded to `custom-declare-face'. ((eq (car form) 'custom-declare-face) ;; Reset the face. - (setq face-new-frame-defaults - (assq-delete-all (eval (nth 1 form) lexical-binding) - face-new-frame-defaults)) - (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil) - ;; Setting `customized-face' to the new spec after calling - ;; the form, but preserving the old saved spec in `saved-face', - ;; imitates the situation when the new face spec is set - ;; temporarily for the current session in the customize - ;; buffer, thus allowing `face-user-default-spec' to use the - ;; new customized spec instead of the saved spec. - ;; Resetting `saved-face' temporarily to nil is needed to let - ;; `defface' change the spec, regardless of a saved spec. - (prog1 `(prog1 ,form - (put ,(nth 1 form) 'saved-face - ',(get (eval (nth 1 form) lexical-binding) - 'saved-face)) - (put ,(nth 1 form) 'customized-face - ,(nth 2 form))) - (put (eval (nth 1 form) lexical-binding) 'saved-face nil))) + (let ((face-symbol (eval (nth 1 form) lexical-binding))) + (setq face-new-frame-defaults + (assq-delete-all face-symbol face-new-frame-defaults)) + (put face-symbol 'face-defface-spec nil) + (put face-symbol 'face-documentation (nth 3 form)) + ;; Setting `customized-face' to the new spec after calling + ;; the form, but preserving the old saved spec in `saved-face', + ;; imitates the situation when the new face spec is set + ;; temporarily for the current session in the customize + ;; buffer, thus allowing `face-user-default-spec' to use the + ;; new customized spec instead of the saved spec. + ;; Resetting `saved-face' temporarily to nil is needed to let + ;; `defface' change the spec, regardless of a saved spec. + (prog1 `(prog1 ,form + (put ,(nth 1 form) 'saved-face + ',(get face-symbol 'saved-face)) + (put ,(nth 1 form) 'customized-face + ,(nth 2 form))) + (put face-symbol 'saved-face nil)))) ((eq (car form) 'progn) (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) (t form))) ------------------------------------------------------------ revno: 104990 committer: Richard Stallman branch nick: trunk timestamp: Wed 2011-07-06 12:44:33 -0400 message: rmailmm.el: record truncated mime entities. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 15:49:19 +0000 +++ lisp/ChangeLog 2011-07-06 16:44:33 +0000 @@ -1,3 +1,13 @@ +2011-07-06 Richard Stallman + + * mail/rmailmm.el: Give entity a new slot, TRUNCATED. + (rmail-mime-entity): New arg TRUNCATED. + (rmail-mime-entity-truncated, rmail-mime-entity-set-truncated): + New functions. + (rmail-mime-save): Warn if entity is truncated. + (rmail-mime-toggle-hidden): Likewise, for showing. + (rmail-mime-process-multipart): Record when an entity is truncated. + 2011-07-06 Lars Magne Ingebrigtsen * progmodes/grep.el (rgrep): Don't bind `process-connection-type', === modified file 'lisp/mail/rmailmm.el' --- lisp/mail/rmailmm.el 2011-06-27 08:01:30 +0000 +++ lisp/mail/rmailmm.el 2011-07-06 16:44:33 +0000 @@ -153,20 +153,21 @@ ;;; MIME-entity object (defun rmail-mime-entity (type disposition transfer-encoding - display header tagline body children handler) + display header tagline body children handler + &optional truncated) "Retrun a newly created MIME-entity object from arguments. -A MIME-entity is a vector of 9 elements: +A MIME-entity is a vector of 10 elements: [TYPE DISPOSITION TRANSFER-ENCODING DISPLAY HEADER TAGLINE BODY - CHILDREN HANDLER] + CHILDREN HANDLER TRUNCATED] TYPE and DISPOSITION correspond to MIME headers Content-Type and -Cotent-Disposition respectively, and has this format: +Content-Disposition respectively, and have this format: \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) -VALUE is a string and ATTRIBUTE is a symbol. +Each VALUE is a string and each ATTRIBUTE is a string. Consider the following header, for example: @@ -208,9 +209,12 @@ has just one child. Any other entity has no child. HANDLER is a function to insert the entity according to DISPLAY. -It is called with one argument ENTITY." +It is called with one argument ENTITY. + +TRUNCATED is non-nil if the text of this entity was truncated." + (vector type disposition transfer-encoding - display header tagline body children handler)) + display header tagline body children handler truncated)) ;; Accessors for a MIME-entity object. (defsubst rmail-mime-entity-type (entity) (aref entity 0)) @@ -222,6 +226,9 @@ (defsubst rmail-mime-entity-body (entity) (aref entity 6)) (defsubst rmail-mime-entity-children (entity) (aref entity 7)) (defsubst rmail-mime-entity-handler (entity) (aref entity 8)) +(defsubst rmail-mime-entity-truncated (entity) (aref entity 9)) +(defsubst rmail-mime-entity-set-truncated (entity truncated) + (aset entity 9 truncated)) (defsubst rmail-mime-message-p () "Non-nil if and only if the current message is a MIME." @@ -237,6 +244,10 @@ (directory (button-get button 'directory)) (data (button-get button 'data)) (ofilename filename)) + (if (and (not (stringp data)) + (rmail-mime-entity-truncated data)) + (unless (y-or-n-p "This entity is truncated; save anyway? ") + (error "Aborted"))) (setq filename (expand-file-name (read-file-name (format "Save as (default: %s): " filename) directory @@ -387,6 +398,11 @@ (if (and rmail-mime-mbox-buffer (= (aref segment 1) (point-min))) (let ((new (aref (rmail-mime-entity-display entity) 1))) (aset new 0 t)))) + ;; Query as a warning before showing if truncated. + (if (and (not (stringp entity)) + (rmail-mime-entity-truncated entity)) + (unless (y-or-n-p "This entity is truncated; show anyway? ") + (error "Aborted"))) ;; Enter the shown mode. (rmail-mime-shown-mode entity) ;; Force this body shown. @@ -816,7 +832,7 @@ (let ((boundary (cdr (assq 'boundary content-type))) (subtype (cadr (split-string (car content-type) "/"))) (index 0) - beg end next entities) + beg end next entities truncated) (unless boundary (rmail-mm-get-boundary-error-message "No boundary defined" content-type content-disposition @@ -845,7 +861,7 @@ (setq beg (point-min)) (while (or (and (search-forward boundary nil t) - (setq end (match-beginning 0))) + (setq truncated nil end (match-beginning 0))) ;; If the boundary does not appear at all, ;; the message was truncated. ;; Handle the rest of the truncated message @@ -854,7 +870,7 @@ (and (save-excursion (skip-chars-forward "\n") (> (point-max) (point))) - (setq end (point-max)))) + (setq truncated t end (point-max)))) ;; If this is the last boundary according to RFC 2046, hide the ;; epilogue, else hide the boundary only. Use a marker for ;; `next' because `rmail-mime-show' may change the buffer. @@ -862,7 +878,7 @@ (setq next (point-max-marker))) ((looking-at "[ \t]*\n") (setq next (copy-marker (match-end 0) t))) - ((= end (point-max)) + (truncated ;; We're handling what's left of a truncated message. (setq next (point-max-marker))) (t @@ -886,6 +902,7 @@ ;; Display a tagline. (aset (aref (rmail-mime-entity-display child) 1) 1 (aset (rmail-mime-entity-tagline child) 2 t)) + (rmail-mime-entity-set-truncated child truncated) (push child entities))) (delete-region end next) ------------------------------------------------------------ revno: 104989 committer: Paul Eggert branch nick: trunk timestamp: Wed 2011-07-06 09:19:38 -0700 message: * m4/alloca.m4: Merge whitespace changes from gnulib. diff: === modified file 'm4/alloca.m4' --- m4/alloca.m4 2011-06-21 16:15:07 +0000 +++ m4/alloca.m4 2011-07-06 16:19:38 +0000 @@ -1,4 +1,4 @@ -# alloca.m4 serial 12 +# alloca.m4 serial 13 dnl Copyright (C) 2002-2004, 2006-2007, 2009-2011 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation @@ -76,17 +76,17 @@ if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do AC_CHECK_FUNC($ac_func, - [AC_DEFINE_UNQUOTED(CRAY_STACKSEG_END, $ac_func, - [Define to one of `_getb67', `GETB67', - `getb67' for Cray-2 and Cray-YMP - systems. This function is required for - `alloca.c' support on those systems.]) + [AC_DEFINE_UNQUOTED(CRAY_STACKSEG_END, $ac_func, + [Define to one of `_getb67', `GETB67', + `getb67' for Cray-2 and Cray-YMP + systems. This function is required for + `alloca.c' support on those systems.]) break]) done fi AC_CACHE_CHECK([stack direction for C alloca], - [ac_cv_c_stack_direction], + [ac_cv_c_stack_direction], [AC_RUN_IFELSE([AC_LANG_SOURCE( [AC_INCLUDES_DEFAULT int @@ -105,16 +105,16 @@ { return find_stack_direction (0, argc + !argv + 20) < 0; }])], - [ac_cv_c_stack_direction=1], - [ac_cv_c_stack_direction=-1], - [ac_cv_c_stack_direction=0])]) + [ac_cv_c_stack_direction=1], + [ac_cv_c_stack_direction=-1], + [ac_cv_c_stack_direction=0])]) AH_VERBATIM([STACK_DIRECTION], [/* If using the C implementation of alloca, define if you know the direction of stack growth for your system; otherwise it will be automatically deduced at runtime. - STACK_DIRECTION > 0 => grows toward higher addresses - STACK_DIRECTION < 0 => grows toward lower addresses - STACK_DIRECTION = 0 => direction of growth unknown */ + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown */ @%:@undef STACK_DIRECTION])dnl AC_DEFINE_UNQUOTED(STACK_DIRECTION, $ac_cv_c_stack_direction) ])# _AC_LIBOBJ_ALLOCA ------------------------------------------------------------ revno: 104988 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 17:49:19 +0200 message: * progmodes/grep.el (rgrep): Don't bind `process-connection-type', because that makes the colours go away. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 15:45:00 +0000 +++ lisp/ChangeLog 2011-07-06 15:49:19 +0000 @@ -1,5 +1,8 @@ 2011-07-06 Lars Magne Ingebrigtsen + * progmodes/grep.el (rgrep): Don't bind `process-connection-type', + because that makes the colours go away. + * mail/sendmail.el (send-mail-function): Change the default to `sendmail-query-once'. (sendmail-query-once): Add an autoload cookie. === modified file 'lisp/progmodes/grep.el' --- lisp/progmodes/grep.el 2011-06-30 01:09:13 +0000 +++ lisp/progmodes/grep.el 2011-07-06 15:49:19 +0000 @@ -966,8 +966,7 @@ (setq dir default-directory)) (if (null files) (if (not (string= regexp grep-find-command)) - (let ((process-connection-type nil)) - (compilation-start regexp 'grep-mode))) + (compilation-start regexp 'grep-mode)) (setq dir (file-name-as-directory (expand-file-name dir))) (require 'find-dired) ; for `find-name-arg' (let ((command (grep-expand-template ------------------------------------------------------------ revno: 104987 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 17:45:00 +0200 message: (sendmail-query-once): Add an autoload cookie. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 15:39:32 +0000 +++ lisp/ChangeLog 2011-07-06 15:45:00 +0000 @@ -2,6 +2,7 @@ * mail/sendmail.el (send-mail-function): Change the default to `sendmail-query-once'. + (sendmail-query-once): Add an autoload cookie. * net/network-stream.el (network-stream-open-starttls): Try using a plain connection even if the server offered STARTTLS, and we === modified file 'lisp/mail/sendmail.el' --- lisp/mail/sendmail.el 2011-07-06 15:39:32 +0000 +++ lisp/mail/sendmail.el 2011-07-06 15:45:00 +0000 @@ -168,6 +168,7 @@ (defvar sendmail-query-once-function 'query "Either a function to send email, or the symbol `query'.") +;;;###autoload (defun sendmail-query-once () "Send an email via `sendmail-query-once-function'. If `sendmail-query-once-function' is `query', ask the user what ------------------------------------------------------------ revno: 104986 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 17:39:32 +0200 message: * mail/sendmail.el (send-mail-function): Change the default to `sendmail-query-once'. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 15:09:11 +0000 +++ lisp/ChangeLog 2011-07-06 15:39:32 +0000 @@ -1,5 +1,8 @@ 2011-07-06 Lars Magne Ingebrigtsen + * mail/sendmail.el (send-mail-function): Change the default to + `sendmail-query-once'. + * net/network-stream.el (network-stream-open-starttls): Try using a plain connection even if the server offered STARTTLS, and we kinda wanted to use it, if Emacs doesn't have any STARTTLS === modified file 'lisp/mail/sendmail.el' --- lisp/mail/sendmail.el 2011-06-29 20:21:29 +0000 +++ lisp/mail/sendmail.el 2011-07-06 15:39:32 +0000 @@ -144,19 +144,11 @@ ;;;###autoload (put 'send-mail-function 'standard-value ;; MS-Windows can access the clipboard even under -nw. - '((if (or (and window-system (eq system-type 'darwin)) - (eq system-type 'windows-nt)) - 'mailclient-send-it - 'sendmail-send-it))) + '('sendmail-query-once)) ;; Useful to set in site-init.el ;;;###autoload -(defcustom send-mail-function - (if (or (and window-system (eq system-type 'darwin)) - ;; MS-Windows can access the clipboard even under -nw. - (eq system-type 'windows-nt)) - 'mailclient-send-it - 'sendmail-send-it) +(defcustom send-mail-function 'sendmail-query-once "Function to call to send the current buffer as mail. The headers should be delimited by a line which is not a valid RFC822 header or continuation line, @@ -170,6 +162,7 @@ (function-item mailclient-send-it :tag "Use Mailclient package") function) :initialize 'custom-initialize-delay + :version "24.1" :group 'sendmail) (defvar sendmail-query-once-function 'query ------------------------------------------------------------ revno: 104985 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Wed 2011-07-06 17:09:11 +0200 message: * net/network-stream.el (network-stream-open-starttls): Try using a plain connection even if the server offered STARTTLS, and we kinda wanted to use it, if Emacs doesn't have any STARTTLS capability. This should make smtpmail.el work in slightly more configurations. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 09:48:20 +0000 +++ lisp/ChangeLog 2011-07-06 15:09:11 +0000 @@ -1,3 +1,11 @@ +2011-07-06 Lars Magne Ingebrigtsen + + * net/network-stream.el (network-stream-open-starttls): Try using + a plain connection even if the server offered STARTTLS, and we + kinda wanted to use it, if Emacs doesn't have any STARTTLS + capability. This should make smtpmail.el work in slightly more + configurations. + 2011-07-06 Michael Albinus * net/tramp-compat.el (tramp-compat-pop-to-buffer-same-window): === modified file 'lisp/net/network-stream.el' --- lisp/net/network-stream.el 2011-07-03 13:48:59 +0000 +++ lisp/net/network-stream.el 2011-07-06 15:09:11 +0000 @@ -281,18 +281,14 @@ (network-stream-command stream capability-command eo-capa)))) ;; If TLS is mandatory, close the connection if it's unencrypted. - (when (and (or require-tls - ;; The server said it was possible to do STARTTLS, - ;; and we wanted to use it... - (and starttls-command - (plist-get parameters :use-starttls-if-possible))) + (when (and require-tls ;; ... but Emacs wasn't able to -- either no built-in ;; support, or no gnutls-cli installed. (eq resulting-type 'plain)) - (setq error - (if require-tls - "Server does not support TLS" - "Server supports STARTTLS, but Emacs does not have support for it")) + (setq error + (if require-tls + "Server does not support TLS" + "Server supports STARTTLS, but Emacs does not have support for it")) (delete-process stream) (setq stream nil)) ;; Return value: ------------------------------------------------------------ revno: 104984 committer: Michael Albinus branch nick: trunk timestamp: Wed 2011-07-06 11:48:20 +0200 message: * net/tramp-compat.el (tramp-compat-pop-to-buffer-same-window): New defun. * net/tramp-cmds.el (tramp-append-tramp-buffers): Use it. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 03:51:48 +0000 +++ lisp/ChangeLog 2011-07-06 09:48:20 +0000 @@ -1,3 +1,9 @@ +2011-07-06 Michael Albinus + + * net/tramp-compat.el (tramp-compat-pop-to-buffer-same-window): + New defun. + * net/tramp-cmds.el (tramp-append-tramp-buffers): Use it. + 2011-07-06 Michael R. Mauger * progmodes/sql.el: Version 3.0 === modified file 'lisp/net/tramp-cmds.el' --- lisp/net/tramp-cmds.el 2011-07-05 15:31:22 +0000 +++ lisp/net/tramp-cmds.el 2011-07-06 09:48:20 +0000 @@ -308,7 +308,7 @@ ;; There is at least one Tramp buffer. (when buffer-list - (pop-to-buffer-same-window (list-buffers-noselect nil)) + (tramp-compat-pop-to-buffer-same-window (list-buffers-noselect nil)) (delete-other-windows) (setq buffer-read-only nil) (goto-char (point-min)) @@ -343,7 +343,7 @@ ;; OK, let's send. First we delete the buffer list. (progn (kill-buffer nil) - (pop-to-buffer-same-window curbuf) + (tramp-compat-pop-to-buffer-same-window curbuf) (goto-char (point-max)) (insert "\n\ This is a special notion of the `gnus/message' package. If you === modified file 'lisp/net/tramp-compat.el' --- lisp/net/tramp-compat.el 2011-03-12 19:19:47 +0000 +++ lisp/net/tramp-compat.el 2011-07-06 09:48:20 +0000 @@ -23,9 +23,9 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is GNU Emacs 24. This -;; package provides compatibility functions for GNU Emacs 22, GNU -;; Emacs 23 and XEmacs 21.4+. +;; Tramp's main Emacs version for development is Emacs 24. This +;; package provides compatibility functions for Emacs 22, Emacs 23, +;; XEmacs 21.4+ and SXEmacs 22. ;;; Code: @@ -286,9 +286,8 @@ (tramp-compat-funcall 'file-attributes filename id-format) (wrong-number-of-arguments (file-attributes filename)))))) -;; PRESERVE-UID-GID has been introduced with Emacs 23. It does not -;; hurt to ignore it for other (X)Emacs versions. -;; PRESERVE-SELINUX-CONTEXT has been introduced with Emacs 24. +;; PRESERVE-UID-GID does not exist in XEmacs. +;; PRESERVE-SELINUX-CONTEXT has been introduced with Emacs 24.1. (defun tramp-compat-copy-file (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-selinux-context) @@ -484,10 +483,7 @@ (tramp-compat-funcall 'set-process-query-on-exit-flag process flag) (tramp-compat-funcall 'process-kill-without-query process flag))) -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-compat 'force))) - +;; There exist different implementations for this function. (defun tramp-compat-coding-system-change-eol-conversion (coding-system eol-type) "Return a coding system like CODING-SYSTEM but with given EOL-TYPE. EOL-TYPE can be one of `dos', `unix', or `mac'." @@ -506,6 +502,19 @@ "`dos', `unix', or `mac'"))))) (t (error "Can't change EOL conversion -- is MULE missing?")))) +;; `pop-to-buffer-same-window' has been introduced with Emacs 24.1. +(defun tramp-compat-pop-to-buffer-same-window + (&optional buffer-or-name norecord label) + "Pop to buffer specified by BUFFER-OR-NAME in the selected window." + (if (fboundp 'pop-to-buffer-same-window) + (tramp-compat-funcall + 'pop-to-buffer-same-window buffer-or-name norecord label) + (tramp-compat-funcall 'switch-to-buffer buffer-or-name norecord))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-compat 'force))) + (provide 'tramp-compat) ;;; TODO: ------------------------------------------------------------ revno: 104983 committer: Julien Danjou branch nick: trunk timestamp: Wed 2011-07-06 09:47:15 +0200 message: * url-cache.el (url-cache-extract): Set buffer multibyte flag to nil (bug#8827). diff: === modified file 'lisp/url/ChangeLog' --- lisp/url/ChangeLog 2011-07-03 16:03:47 +0000 +++ lisp/url/ChangeLog 2011-07-06 07:47:15 +0000 @@ -1,3 +1,8 @@ +2011-07-06 Nick Dokos (tiny change) + + * url-cache.el (url-cache-extract): Set buffer multibyte flag to + nil (bug#8827). + 2011-07-03 Nicolas Avrutin (tiny change) * url-http.el (url-http-create-request): Remove double carriage === modified file 'lisp/url/url-cache.el' --- lisp/url/url-cache.el 2011-01-25 04:08:28 +0000 +++ lisp/url/url-cache.el 2011-07-06 07:47:15 +0000 @@ -192,6 +192,7 @@ (defun url-cache-extract (fnam) "Extract FNAM from the local disk cache." (erase-buffer) + (set-buffer-multibyte nil) (insert-file-contents-literally fnam)) (defun url-cache-expired (url &optional expire-time) ------------------------------------------------------------ revno: 104982 committer: Michael Mauger branch nick: trunk timestamp: Tue 2011-07-05 23:51:48 -0400 message: * progmodes/sql.el: Version 3.0 (sql-product-alist): Added product :completion-object, :completion-column, and :statement attributes. (sql-mode-menu, sql-interactive-mode-map): Fixed List entries. (sql-mode-syntax-table): Mark all punctuation. (sql-font-lock-keywords-builder): Temporarily removed fallback on ansi keywords. (sql-regexp-abbrev, sql-regexp-abbrev-list): New functions. (sql-mode-oracle-font-lock-keywords): Improved. (sql-oracle-show-reserved-words): New function for development. (sql-product-font-lock): Simplify for source code buffers. (sql-product-syntax-table, sql-product-font-lock-syntax-alist): New functions. (sql-highlight-product): Set product specific syntax table. (sql-mode-map): Added statement movement functions. (sql-ansi-statement-starters, sql-oracle-statement-starters): New variable. (sql-statement-regexp, sql-beginning-of-statement) (sql-end-of-statement, sql-signum): New functions. (sql-buffer-live-p, sql=find-sqli-buffer): Added CONNECTION parameter. (sql-show-sqli-buffer): Bug fix. (sql-interactive-mode): Store connection data as buffer local. (sql-connect): Added NEW-NAME parameter. Redesigned interaction with sql-interactive-mode. (sql-save-connection): Save buffer local settings. (sql-connection-menu-filter): Changed menu entry name. (sql-product-interactive): Bug fix. (sql-preoutput-hold): New variable. (sql-interactive-remove-continuation-prompt): Bug fixes. (sql-debug-redirect): New variable. (sql-str-literal): New function. (sql-redirect, sql-redirect-one, sql-redirect-value, sql-execute): Redesigned. (sql-oracle-save-settings, sql-oracle-restore-settings) (sql-oracle-list-all, sql-oracle-list-table): New functions. (sql-completion-object, sql-completion-column) (sql-completion-sqlbuf): New variables. (sql-build-completions-1, sql-build-completions) (sql-try-completion): New functions. (sql-read-table-name): Use them. (sql-contains-names): New buffer local variable. (sql-list-all, sql-list-table): Use it. (sql-oracle-completion-types): New variable. (sql-oracle-completion-object, sql-sqlite-completion-object) (sql-postgres-completion-object): New functions. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 02:46:22 +0000 +++ lisp/ChangeLog 2011-07-06 03:51:48 +0000 @@ -1,3 +1,52 @@ +2011-07-06 Michael R. Mauger + + * progmodes/sql.el: Version 3.0 + (sql-product-alist): Added product :completion-object, + :completion-column, and :statement attributes. + (sql-mode-menu, sql-interactive-mode-map): Fixed List entries. + (sql-mode-syntax-table): Mark all punctuation. + (sql-font-lock-keywords-builder): Temporarily removed fallback on + ansi keywords. + (sql-regexp-abbrev, sql-regexp-abbrev-list): New functions. + (sql-mode-oracle-font-lock-keywords): Improved. + (sql-oracle-show-reserved-words): New function for development. + (sql-product-font-lock): Simplify for source code buffers. + (sql-product-syntax-table, sql-product-font-lock-syntax-alist): + New functions. + (sql-highlight-product): Set product specific syntax table. + (sql-mode-map): Added statement movement functions. + (sql-ansi-statement-starters, sql-oracle-statement-starters): New + variable. + (sql-statement-regexp, sql-beginning-of-statement) + (sql-end-of-statement, sql-signum): New functions. + (sql-buffer-live-p, sql=find-sqli-buffer): Added CONNECTION + parameter. + (sql-show-sqli-buffer): Bug fix. + (sql-interactive-mode): Store connection data as buffer local. + (sql-connect): Added NEW-NAME parameter. Redesigned interaction + with sql-interactive-mode. + (sql-save-connection): Save buffer local settings. + (sql-connection-menu-filter): Changed menu entry name. + (sql-product-interactive): Bug fix. + (sql-preoutput-hold): New variable. + (sql-interactive-remove-continuation-prompt): Bug fixes. + (sql-debug-redirect): New variable. + (sql-str-literal): New function. + (sql-redirect, sql-redirect-one, sql-redirect-value, sql-execute): + Redesigned. + (sql-oracle-save-settings, sql-oracle-restore-settings) + (sql-oracle-list-all, sql-oracle-list-table): New functions. + (sql-completion-object, sql-completion-column) + (sql-completion-sqlbuf): New variables. + (sql-build-completions-1, sql-build-completions) + (sql-try-completion): New functions. + (sql-read-table-name): Use them. + (sql-contains-names): New buffer local variable. + (sql-list-all, sql-list-table): Use it. + (sql-oracle-completion-types): New variable. + (sql-oracle-completion-object, sql-sqlite-completion-object) + (sql-postgres-completion-object): New functions. + 2011-07-06 Glenn Morris * window.el (pop-to-buffer): Doc fix. === modified file 'lisp/progmodes/sql.el' --- lisp/progmodes/sql.el 2011-05-23 17:57:17 +0000 +++ lisp/progmodes/sql.el 2011-07-06 03:51:48 +0000 @@ -4,10 +4,9 @@ ;; Author: Alex Schroeder ;; Maintainer: Michael Mauger -;; Version: 2.8 +;; Version: 3.0 ;; Keywords: comm languages processes ;; URL: http://savannah.gnu.org/projects/emacs/ -;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode ;; This file is part of GNU Emacs. @@ -46,7 +45,7 @@ ;; available in early versions of sql.el. This support has been ;; extended and formalized in later versions. Part of the impetus for ;; the improved support of SQL flavors was borne out of the current -;; maintainer's consulting experience. In the past fifteen years, I +;; maintainers consulting experience. In the past twenty years, I ;; have used Oracle, Sybase, Informix, MySQL, Postgres, and SQLServer. ;; On some assignments, I have used two or more of these concurrently. @@ -130,7 +129,7 @@ ;; identifier characters. ;; (sql-set-product-feature 'xyz -;; :syntax-alist ((?# . "w"))) +;; :syntax-alist ((?# . "_"))) ;; 4) Define the interactive command interpreter for the database ;; product. @@ -184,7 +183,7 @@ ;; (sql-set-product-feature 'xyz ;; :sqli-comint-func 'my-sql-comint-xyz) -;; 6) Define a convienence function to invoke the SQL interpreter. +;; 6) Define a convenience function to invoke the SQL interpreter. ;; (defun my-sql-xyz (&optional buffer) ;; "Run ixyz by XyzDB as an inferior process." @@ -230,9 +229,18 @@ (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) (defvar font-lock-string-face) @@ -327,7 +335,8 @@ (defvar sql-product-alist '((ansi :name "ANSI" - :font-lock sql-mode-ansi-font-lock-keywords) + :font-lock sql-mode-ansi-font-lock-keywords + :statement sql-ansi-statement-starters) (db2 :name "DB2" @@ -392,7 +401,7 @@ :sqli-comint-func sql-comint-ms :prompt-regexp "^[0-9]*>" :prompt-length 5 - :syntax-alist ((?@ . "w")) + :syntax-alist ((?@ . "_")) :terminator ("^go" . "go")) (mysql @@ -408,6 +417,7 @@ :prompt-regexp "^mysql> " :prompt-length 6 :prompt-cont-regexp "^ -> " + :syntax-alist ((?# . "< b")) :input-filter sql-remove-tabs-filter) (oracle @@ -417,11 +427,15 @@ :sqli-options sql-oracle-options :sqli-login sql-oracle-login-params :sqli-comint-func sql-comint-oracle + :list-all sql-oracle-list-all + :list-table sql-oracle-list-table + :completion-object sql-oracle-completion-object :prompt-regexp "^SQL> " :prompt-length 5 - :prompt-cont-regexp "^\\s-*\\d+> " - :syntax-alist ((?$ . "w") (?# . "w")) - :terminator ("\\(^/\\|;\\)" . "/") + :prompt-cont-regexp "^\\s-*[[:digit:]]+ " + :statement sql-oracle-statement-starters + :syntax-alist ((?$ . "_") (?# . "_")) + :terminator ("\\(^/\\|;\\)$" . "/") :input-filter sql-placeholders-filter) (postgres @@ -434,11 +448,12 @@ :sqli-comint-func sql-comint-postgres :list-all ("\\d+" . "\\dS+") :list-table ("\\d+ %s" . "\\dS+ %s") - :prompt-regexp "^.*=[#>] " + :completion-object sql-postgres-completion-object + :prompt-regexp "^\\w*=[#>] " :prompt-length 5 - :prompt-cont-regexp "^.*[-(][#>] " + :prompt-cont-regexp "^\\w*[-(][#>] " :input-filter sql-remove-tabs-filter - :terminator ("\\(^\\s-*\\\\g\\|;\\)" . ";")) + :terminator ("\\(^\\s-*\\\\g$\\|;\\)" . "\\g")) (solid :name "Solid" @@ -460,9 +475,10 @@ :sqli-comint-func sql-comint-sqlite :list-all ".tables" :list-table ".schema %s" + :completion-object sql-sqlite-completion-object :prompt-regexp "^sqlite> " :prompt-length 8 - :prompt-cont-regexp "^ ...> " + :prompt-cont-regexp "^ \.\.\.> " :terminator ";") (sybase @@ -474,7 +490,7 @@ :sqli-comint-func sql-comint-sybase :prompt-regexp "^SQL> " :prompt-length 5 - :syntax-alist ((?@ . "w")) + :syntax-alist ((?@ . "_")) :terminator ("^go" . "go")) ) "An alist of product specific configuration settings. @@ -513,10 +529,11 @@ :sqli-comint-func name of a function which accepts no parameters that will use the values of `sql-user', `sql-password', - `sql-database' and `sql-server' to open a - comint buffer and connect to the - database. Do product specific - configuration of comint in this function. + `sql-database', `sql-server' and + `sql-port' to open a comint buffer and + connect to the database. Do product + specific configuration of comint in this + function. :list-all Command string or function which produces a listing of all objects in the database. @@ -535,6 +552,20 @@ produces the standard list and the cdr produces an enhanced list. + :completion-object A function that returns a list of + objects. Called with a single + parameter--if nil then list objects + accessible in the current schema, if + not-nil it is the name of a schema whose + objects should be listed. + + :completion-column A function that returns a list of + columns. Called with a single + parameter--if nil then list objects + accessible in the current schema, if + not-nil it is the name of a schema whose + objects should be listed. + :prompt-regexp regular expression string that matches the prompt issued by the product interpreter. @@ -555,6 +586,9 @@ filtered string. May also be a list of such functions. + :statement name of a variable containing a regexp that + matches the beginning of SQL statements. + :terminator the terminator to be sent after a `sql-send-string', `sql-send-region', `sql-send-paragraph' and @@ -574,7 +608,7 @@ settings.") (defvar sql-indirect-features - '(:font-lock :sqli-program :sqli-options :sqli-login)) + '(:font-lock :sqli-program :sqli-options :sqli-login :statement)) (defcustom sql-connection-alist nil "An alist of connection parameters for interacting with a SQL @@ -683,6 +717,13 @@ :version "22.2" :group 'SQL) +(defvar sql-contains-names nil + "When non-nil, the current buffer contains database names. + +Globally should be set to nil; it will be non-nil in `sql-mode', +`sql-interactive-mode' and list all buffers.") + + (defcustom sql-pop-to-buffer-after-send-region nil "When non-nil, pop to the buffer SQL statements are sent to. @@ -770,6 +811,19 @@ :type 'hook :group 'SQL) +;; 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 + +All products share this list; products should define a regexp to +identify additional keywords in a variable defined by +the :statement feature.") + ;; Customization for Oracle (defcustom sql-oracle-program "sqlplus" @@ -795,18 +849,22 @@ :version "24.1" :group 'SQL) +(defcustom sql-oracle-statement-starters (regexp-opt '("declare" "begin" "with")) + "Additional statement starting keywords in Oracle.") + (defcustom sql-oracle-scan-on t "Non-nil if placeholders should be replaced in Oracle SQLi. When non-nil, Emacs will scan text sent to sqlplus and prompt for replacement text for & placeholders as sqlplus does. This -is needed on Windows where sqlplus output is buffered and the +is needed on Windows where SQL*Plus output is buffered and the prompts are not shown until after the text is entered. -You will probably want to issue the following command in sqlplus -to be safe: - - SET SCAN OFF" +You need to issue the following command in SQL*Plus to be safe: + + SET DEFINE OFF + +In older versions of SQL*Plus, this was the SET SCAN OFF command." :type 'boolean :group 'SQL) @@ -833,7 +891,7 @@ :version "24.1" :group 'SQL) -;; Customization for MySql +;; Customization for MySQL (defcustom sql-mysql-program "mysql" "Command to start mysql by TcX. @@ -851,7 +909,7 @@ :group 'SQL) (defcustom sql-mysql-login-params '(user password database server) - "List of login parameters needed to connect to MySql." + "List of login parameters needed to connect to MySQL." :type 'sql-login-params :version "24.1" :group 'SQL) @@ -1085,13 +1143,13 @@ Used by `sql-rename-buffer'.") -(defun sql-buffer-live-p (buffer &optional product) +(defun sql-buffer-live-p (buffer &optional product connection) "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." +`sql-interactive-mode', and, if PRODUCT or CONNECTION are +specified, it's `sql-product' or `sql-connection' must match." (when buffer (setq buffer (get-buffer buffer)) @@ -1102,7 +1160,9 @@ (with-current-buffer buffer (and (derived-mode-p 'sql-interactive-mode) (or (not product) - (eq product sql-product))))))) + (eq product sql-product)) + (or (not connection) + (eq connection sql-connection))))))) ;; Keymap for sql-interactive-mode. @@ -1136,6 +1196,8 @@ (define-key map (kbd "C-c C-i") 'sql-product-interactive) (define-key map (kbd "C-c C-l a") 'sql-list-all) (define-key map (kbd "C-c C-l t") 'sql-list-table) + (define-key map [remap beginning-of-defun] 'sql-beginning-of-statement) + (define-key map [remap end-of-defun] 'sql-end-of-statement) map) "Mode map used for `sql-mode'.") @@ -1151,8 +1213,10 @@ ["Send Buffer" sql-send-buffer (sql-buffer-live-p sql-buffer)] ["Send String" sql-send-string (sql-buffer-live-p sql-buffer)] "--" - ["List all objects" sql-list-all (sql-buffer-live-p sql-buffer)] - ["List table details" sql-list-table (sql-buffer-live-p sql-buffer)] + ["List all objects" sql-list-all (and (sql-buffer-live-p sql-buffer) + (sql-get-product-feature sql-product :list-all))] + ["List table details" sql-list-table (and (sql-buffer-live-p sql-buffer) + (sql-get-product-feature sql-product :list-table))] "--" ["Start SQLi session" sql-product-interactive :visible (not sql-connection-alist) @@ -1194,8 +1258,8 @@ ["Rename Buffer" sql-rename-buffer t] ["Save Connection" sql-save-connection (not sql-connection)] "--" - ["List all objects" sql-list-all t] - ["List table details" sql-list-table t])) + ["List all objects" sql-list-all (sql-get-product-feature sql-product :list-all)] + ["List table details" sql-list-table (sql-get-product-feature sql-product :list-table)])) ;; Abbreviations -- if you want more of them, define them in your ;; ~/.emacs file. Abbrevs have to be enabled in your ~/.emacs, too. @@ -1238,8 +1302,9 @@ (modify-syntax-entry ?' "\"" table) ;; double quotes (") don't delimit strings (modify-syntax-entry ?\" "." table) - ;; backslash is no escape character - (modify-syntax-entry ?\\ "." table) + ;; Make these all punctuation + (mapc (lambda (c) (modify-syntax-entry c "." table)) + (string-to-list "!#$%&+,.:;<=>?@\\|")) table) "Syntax table used in `sql-mode' and `sql-interactive-mode'.") @@ -1298,20 +1363,45 @@ ;; Remove keywords that are defined in ANSI (setq kwd keywords) - (dolist (k keywords) - (catch 'next - (dolist (a sql-mode-ansi-font-lock-keywords) - (when (and (eq face (cdr a)) - (eq (string-match (car a) k 0) 0) - (eq (match-end 0) (length k))) - (setq kwd (delq k kwd)) - (throw 'next nil))))) + ;; (dolist (k keywords) + ;; (catch 'next + ;; (dolist (a sql-mode-ansi-font-lock-keywords) + ;; (when (and (eq face (cdr a)) + ;; (eq (string-match (car a) k 0) 0) + ;; (eq (match-end 0) (length k))) + ;; (setq kwd (delq k kwd)) + ;; (throw 'next nil))))) ;; Create a properly formed font-lock-keywords item (cons (concat (car bdy) (regexp-opt kwd t) (cdr bdy)) - face)))) + face))) + + (defun sql-regexp-abbrev (keyword) + (let ((brk (string-match "[~]" keyword)) + (len (length keyword)) + (sep "\\(?:") + re i) + (if (not brk) + keyword + (setq re (substring keyword 0 brk) + i (+ 2 brk) + brk (1+ brk)) + (while (<= i len) + (setq re (concat re sep (substring keyword brk i)) + sep "\\|" + i (1+ i))) + (concat re "\\)?")))) + + (defun sql-regexp-abbrev-list (&rest keyw-list) + (let ((re nil) + (sep "\\<\\(?:")) + (while keyw-list + (setq re (concat re sep (sql-regexp-abbrev (car keyw-list))) + sep "\\|" + keyw-list (cdr keyw-list))) + (concat re "\\)\\>")))) (eval-when-compile (setq sql-mode-ansi-font-lock-keywords @@ -1346,6 +1436,7 @@ "user_defined_type_catalog" "user_defined_type_name" "user_defined_type_schema" ) + ;; ANSI Reserved keywords (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "absolute" "action" "add" "admin" "after" "aggregate" "alias" "all" @@ -1395,6 +1486,7 @@ "substring" "sum" "system_user" "translate" "treat" "trim" "upper" "user" ) + ;; ANSI Data Types (sql-font-lock-keywords-builder 'font-lock-type-face nil "array" "binary" "bit" "blob" "boolean" "char" "character" "clob" @@ -1414,86 +1506,142 @@ 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 () + ;; 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) + (not (eq sql-product 'oracle))) + (error "Not an Oracle buffer") + + (let ((b "*RESERVED WORDS*")) + (sql-execute sql-buffer b + (concat "SELECT " + " keyword " + ", reserved AS \"Res\" " + ", res_type AS \"Type\" " + ", res_attr AS \"Attr\" " + ", res_semi AS \"Semi\" " + ", duplicate AS \"Dup\" " + "FROM V$RESERVED_WORDS " + "WHERE length > 1 " + "AND SUBSTR(keyword, 1, 1) BETWEEN 'A' AND 'Z' " + "ORDER BY 2 DESC, 3 DESC, 4 DESC, 5 DESC, 6 DESC, 1;") + nil nil) + (with-current-buffer b + (set (make-local-variable 'sql-product) 'oracle) + (sql-product-font-lock t nil) + (font-lock-mode +1))))) + (defvar sql-mode-oracle-font-lock-keywords (eval-when-compile (list ;; Oracle SQL*Plus Commands - (cons + ;; Only recognized in they start in column 1 and the + ;; abbreviation is followed by a space or the end of line. + + "\\|" + (list (concat "^" (sql-regexp-abbrev "rem~ark") "\\(?:\\s-.*\\)?$") + 0 'font-lock-comment-face t) + + (list (concat - "^\\s-*\\(?:\\(?:" (regexp-opt '( -"@" "@@" "accept" "append" "archive" "attribute" "break" -"btitle" "change" "clear" "column" "connect" "copy" "define" -"del" "describe" "disconnect" "edit" "execute" "exit" "get" "help" -"host" "input" "list" "password" "pause" "print" "prompt" "recover" -"remark" "repfooter" "repheader" "run" "save" "show" "shutdown" -"spool" "start" "startup" "store" "timing" "ttitle" "undefine" -"variable" "whenever" -) t) - - "\\)\\|" - "\\(?:compute\\s-+\\(?:avg\\|cou\\|min\\|max\\|num\\|sum\\|std\\|var\\)\\)\\|" - "\\(?:set\\s-+\\(" - - (regexp-opt - '("appi" "appinfo" "array" "arraysize" "auto" "autocommit" - "autop" "autoprint" "autorecovery" "autot" "autotrace" "blo" - "blockterminator" "buffer" "closecursor" "cmds" "cmdsep" - "colsep" "com" "compatibility" "con" "concat" "constraint" - "constraints" "copyc" "copycommit" "copytypecheck" "database" - "def" "define" "document" "echo" "editf" "editfile" "emb" - "embedded" "esc" "escape" "feed" "feedback" "flagger" "flu" - "flush" "hea" "heading" "heads" "headsep" "instance" "lin" - "linesize" "lobof" "loboffset" "logsource" "long" "longc" - "longchunksize" "maxdata" "newp" "newpage" "null" "num" - "numf" "numformat" "numwidth" "pages" "pagesize" "pau" - "pause" "recsep" "recsepchar" "role" "scan" "serveroutput" - "shift" "shiftinout" "show" "showmode" "space" "sqlbl" - "sqlblanklines" "sqlc" "sqlcase" "sqlco" "sqlcontinue" "sqln" - "sqlnumber" "sqlp" "sqlpluscompat" "sqlpluscompatibility" - "sqlpre" "sqlprefix" "sqlprompt" "sqlt" "sqlterminator" - "statement_id" "suf" "suffix" "tab" "term" "termout" "ti" - "time" "timi" "timing" "transaction" "trim" "trimout" "trims" - "trimspool" "truncate" "und" "underline" "ver" "verify" "wra" - "wrap")) "\\)\\)" - - "\\)\\b.*" - ) - 'font-lock-doc-face) - '("^\\s-*rem\\(?:ark\\)?\\>.*" . font-lock-comment-face) + "^\\(?:" + (sql-regexp-abbrev-list + "[@]\\{1,2\\}" "acc~ept" "a~ppend" "archive" "attribute" + "bre~ak" "bti~tle" "c~hange" "cl~ear" "col~umn" "conn~ect" + "copy" "def~ine" "del" "desc~ribe" "disc~onnect" "ed~it" + "exec~ute" "exit" "get" "help" "ho~st" "[$]" "i~nput" "l~ist" + "passw~ord" "pau~se" "pri~nt" "pro~mpt" "quit" "recover" + "repf~ooter" "reph~eader" "r~un" "sav~e" "sho~w" "shutdown" + "spo~ol" "sta~rt" "startup" "store" "tim~ing" "tti~tle" + "undef~ine" "var~iable" "whenever") + "\\|" + (concat "\\(?:" + (sql-regexp-abbrev "comp~ute") + "\\s-+" + (sql-regexp-abbrev-list + "avg" "cou~nt" "min~imum" "max~imum" "num~ber" "sum" + "std" "var~iance") + "\\)") + "\\|" + (concat "\\(?:set\\s-+" + (sql-regexp-abbrev-list + "appi~nfo" "array~size" "auto~commit" "autop~rint" + "autorecovery" "autot~race" "blo~ckterminator" + "cmds~ep" "colsep" "com~patibility" "con~cat" + "copyc~ommit" "copytypecheck" "def~ine" "describe" + "echo" "editf~ile" "emb~edded" "esc~ape" "feed~back" + "flagger" "flu~sh" "hea~ding" "heads~ep" "instance" + "lin~esize" "lobof~fset" "long" "longc~hunksize" + "mark~up" "newp~age" "null" "numf~ormat" "num~width" + "pages~ize" "pau~se" "recsep" "recsepchar" + "scan" "serverout~put" "shift~inout" "show~mode" + "sqlbl~anklines" "sqlc~ase" "sqlco~ntinue" + "sqln~umber" "sqlpluscompat~ibility" "sqlpre~fix" + "sqlp~rompt" "sqlt~erminator" "suf~fix" "tab" + "term~out" "ti~me" "timi~ng" "trim~out" "trims~pool" + "und~erline" "ver~ify" "wra~p") + "\\)") + + "\\)\\(?:\\s-.*\\)?\\(?:[-]\n.*\\)*$") + 0 'font-lock-doc-face t) ;; Oracle Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil -"abs" "acos" "add_months" "ascii" "asciistr" "asin" "atan" "atan2" -"avg" "bfilename" "bin_to_num" "bitand" "cast" "ceil" "chartorowid" -"chr" "coalesce" "compose" "concat" "convert" "corr" "cos" "cosh" -"count" "covar_pop" "covar_samp" "cume_dist" "current_date" -"current_timestamp" "current_user" "dbtimezone" "decode" "decompose" -"dense_rank" "depth" "deref" "dump" "empty_clob" "existsnode" "exp" -"extract" "extractvalue" "first" "first_value" "floor" "following" -"from_tz" "greatest" "group_id" "grouping_id" "hextoraw" "initcap" -"instr" "lag" "last" "last_day" "last_value" "lead" "least" "length" -"ln" "localtimestamp" "lower" "lpad" "ltrim" "make_ref" "max" "min" -"mod" "months_between" "new_time" "next_day" "nls_charset_decl_len" +"abs" "acos" "add_months" "appendchildxml" "ascii" "asciistr" "asin" +"atan" "atan2" "avg" "bfilename" "bin_to_num" "bitand" "cardinality" +"cast" "ceil" "chartorowid" "chr" "cluster_id" "cluster_probability" +"cluster_set" "coalesce" "collect" "compose" "concat" "convert" "corr" +"corr_k" "corr_s" "cos" "cosh" "count" "covar_pop" "covar_samp" +"cube_table" "cume_dist" "currrent_date" "currrent_timestamp" "cv" +"dataobj_to_partition" "dbtimezone" "decode" "decompose" "deletexml" +"dense_rank" "depth" "deref" "dump" "empty_blob" "empty_clob" +"existsnode" "exp" "extract" "extractvalue" "feature_id" "feature_set" +"feature_value" "first" "first_value" "floor" "from_tz" "greatest" +"grouping" "grouping_id" "group_id" "hextoraw" "initcap" +"insertchildxml" "insertchildxmlafter" "insertchildxmlbefore" +"insertxmlafter" "insertxmlbefore" "instr" "instr2" "instr4" "instrb" +"instrc" "iteration_number" "lag" "last" "last_day" "last_value" +"lead" "least" "length" "length2" "length4" "lengthb" "lengthc" +"listagg" "ln" "lnnvl" "localtimestamp" "log" "lower" "lpad" "ltrim" +"make_ref" "max" "median" "min" "mod" "months_between" "nanvl" "nchr" +"new_time" "next_day" "nlssort" "nls_charset_decl_len" "nls_charset_id" "nls_charset_name" "nls_initcap" "nls_lower" -"nls_upper" "nlssort" "ntile" "nullif" "numtodsinterval" -"numtoyminterval" "nvl" "nvl2" "over" "path" "percent_rank" -"percentile_cont" "percentile_disc" "power" "preceding" "rank" -"ratio_to_report" "rawtohex" "rawtonhex" "reftohex" "regr_" -"regr_avgx" "regr_avgy" "regr_count" "regr_intercept" "regr_r2" -"regr_slope" "regr_sxx" "regr_sxy" "regr_syy" "replace" "round" -"row_number" "rowidtochar" "rowidtonchar" "rpad" "rtrim" -"sessiontimezone" "sign" "sin" "sinh" "soundex" "sqrt" "stddev" -"stddev_pop" "stddev_samp" "substr" "sum" "sys_connect_by_path" -"sys_context" "sys_dburigen" "sys_extract_utc" "sys_guid" "sys_typeid" -"sys_xmlagg" "sys_xmlgen" "sysdate" "systimestamp" "tan" "tanh" +"nls_upper" "nth_value" "ntile" "nullif" "numtodsinterval" +"numtoyminterval" "nvl" "nvl2" "ora_dst_affected" "ora_dst_convert" +"ora_dst_error" "ora_hash" "path" "percentile_cont" "percentile_disc" +"percent_rank" "power" "powermultiset" "powermultiset_by_cardinality" +"prediction" "prediction_bounds" "prediction_cost" +"prediction_details" "prediction_probability" "prediction_set" +"presentnnv" "presentv" "previous" "rank" "ratio_to_report" "rawtohex" +"rawtonhex" "ref" "reftohex" "regexp_count" "regexp_instr" +"regexp_replace" "regexp_substr" "regr_avgx" "regr_avgy" "regr_count" +"regr_intercept" "regr_r2" "regr_slope" "regr_sxx" "regr_sxy" +"regr_syy" "remainder" "replace" "round" "rowidtochar" "rowidtonchar" +"row_number" "rpad" "rtrim" "scn_to_timestamp" "sessiontimezone" "set" +"sign" "sin" "sinh" "soundex" "sqrt" "stats_binomial_test" +"stats_crosstab" "stats_f_test" "stats_ks_test" "stats_mode" +"stats_mw_test" "stats_one_way_anova" "stats_t_test_indep" +"stats_t_test_indepu" "stats_t_test_one" "stats_t_test_paired" +"stats_wsr_test" "stddev" "stddev_pop" "stddev_samp" "substr" +"substr2" "substr4" "substrb" "substrc" "sum" "sysdate" "systimestamp" +"sys_connect_by_path" "sys_context" "sys_dburigen" "sys_extract_utc" +"sys_guid" "sys_typeid" "sys_xmlagg" "sys_xmlgen" "tan" "tanh" +"timestamp_to_scn" "to_binary_double" "to_binary_float" "to_blob" "to_char" "to_clob" "to_date" "to_dsinterval" "to_lob" "to_multi_byte" "to_nchar" "to_nclob" "to_number" "to_single_byte" "to_timestamp" "to_timestamp_tz" "to_yminterval" "translate" "treat" "trim" "trunc" -"tz_offset" "uid" "unbounded" "unistr" "updatexml" "upper" "user" -"userenv" "var_pop" "var_samp" "variance" "vsize" "width_bucket" "xml" -"xmlagg" "xmlattribute" "xmlcolattval" "xmlconcat" "xmlelement" -"xmlforest" "xmlsequence" "xmltransform" +"tz_offset" "uid" "unistr" "updatexml" "upper" "user" "userenv" +"value" "variance" "var_pop" "var_samp" "vsize" "width_bucket" +"xmlagg" "xmlcast" "xmlcdata" "xmlcolattval" "xmlcomment" "xmlconcat" +"xmldiff" "xmlelement" "xmlexists" "xmlforest" "xmlisvalid" "xmlparse" +"xmlpatch" "xmlpi" "xmlquery" "xmlroot" "xmlsequence" "xmlserialize" +"xmltable" "xmltransform" ) + + ;; See the table V$RESERVED_WORDS ;; Oracle Keywords (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "abort" "access" "accessed" "account" "activate" "add" "admin" @@ -1582,52 +1730,120 @@ "varray" "version" "view" "wait" "when" "whenever" "where" "with" "without" "wnds" "wnps" "work" "write" "xmldata" "xmlschema" "xmltype" ) + ;; Oracle Data Types (sql-font-lock-keywords-builder 'font-lock-type-face nil -"bfile" "blob" "byte" "char" "character" "clob" "date" "dec" "decimal" -"double" "float" "int" "integer" "interval" "long" "national" "nchar" -"nclob" "number" "numeric" "nvarchar2" "precision" "raw" "real" -"rowid" "second" "smallint" "time" "timestamp" "urowid" "varchar" -"varchar2" "varying" "year" "zone" +"bfile" "binary_double" "binary_float" "blob" "byte" "char" "charbyte" +"clob" "date" "day" "float" "interval" "local" "long" "longraw" +"minute" "month" "nchar" "nclob" "number" "nvarchar2" "raw" "rowid" "second" +"time" "timestamp" "urowid" "varchar2" "with" "year" "zone" ) ;; Oracle PL/SQL Attributes - (sql-font-lock-keywords-builder 'font-lock-builtin-face '("" . "\\b") -"%bulk_rowcount" "%found" "%isopen" "%notfound" "%rowcount" "%rowtype" -"%type" + (sql-font-lock-keywords-builder 'font-lock-builtin-face '("%" . "\\b") +"bulk_exceptions" "bulk_rowcount" "found" "isopen" "notfound" +"rowcount" "rowtype" "type" ) ;; Oracle PL/SQL Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil -"extend" "prior" +"delete" "trim" "extend" "exists" "first" "last" "count" "limit" +"prior" "next" +) + + ;; Oracle PL/SQL Reserved words + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil +"all" "alter" "and" "any" "as" "asc" "at" "begin" "between" "by" +"case" "check" "clusters" "cluster" "colauth" "columns" "compress" +"connect" "crash" "create" "cursor" "declare" "default" "desc" +"distinct" "drop" "else" "end" "exception" "exclusive" "fetch" "for" +"from" "function" "goto" "grant" "group" "having" "identified" "if" +"in" "index" "indexes" "insert" "intersect" "into" "is" "like" "lock" +"minus" "mode" "nocompress" "not" "nowait" "null" "of" "on" "option" +"or" "order" "overlaps" "procedure" "public" "resource" "revoke" +"select" "share" "size" "sql" "start" "subtype" "tabauth" "table" +"then" "to" "type" "union" "unique" "update" "values" "view" "views" +"when" "where" "with" + +"true" "false" +"raise_application_error" ) ;; Oracle PL/SQL Keywords (sql-font-lock-keywords-builder 'font-lock-keyword-face nil -"autonomous_transaction" "bulk" "char_base" "collect" "constant" -"cursor" "declare" "do" "elsif" "exception_init" "execute" "exit" -"extends" "false" "fetch" "forall" "goto" "hour" "if" "interface" -"loop" "minute" "number_base" "ocirowid" "opaque" "others" "rowtype" -"separate" "serially_reusable" "sql" "sqlcode" "sqlerrm" "subtype" -"the" "timezone_abbr" "timezone_hour" "timezone_minute" -"timezone_region" "true" "varrying" "while" +"a" "add" "agent" "aggregate" "array" "attribute" "authid" "avg" +"bfile_base" "binary" "blob_base" "block" "body" "both" "bound" "bulk" +"byte" "c" "call" "calling" "cascade" "char" "char_base" "character" +"charset" "charsetform" "charsetid" "clob_base" "close" "collect" +"comment" "commit" "committed" "compiled" "constant" "constructor" +"context" "continue" "convert" "count" "current" "customdatum" +"dangling" "data" "date" "date_base" "day" "define" "delete" +"deterministic" "double" "duration" "element" "elsif" "empty" "escape" +"except" "exceptions" "execute" "exists" "exit" "external" "final" +"fixed" "float" "forall" "force" "general" "hash" "heap" "hidden" +"hour" "immediate" "including" "indicator" "indices" "infinite" +"instantiable" "int" "interface" "interval" "invalidate" "isolation" +"java" "language" "large" "leading" "length" "level" "library" "like2" +"like4" "likec" "limit" "limited" "local" "long" "loop" "map" "max" +"maxlen" "member" "merge" "min" "minute" "mod" "modify" "month" +"multiset" "name" "nan" "national" "native" "nchar" "new" "nocopy" +"number_base" "object" "ocicoll" "ocidate" "ocidatetime" "ociduration" +"ociinterval" "ociloblocator" "ocinumber" "ociraw" "ociref" +"ocirefcursor" "ocirowid" "ocistring" "ocitype" "old" "only" "opaque" +"open" "operator" "oracle" "oradata" "organization" "orlany" "orlvary" +"others" "out" "overriding" "package" "parallel_enable" "parameter" +"parameters" "parent" "partition" "pascal" "pipe" "pipelined" "pragma" +"precision" "prior" "private" "raise" "range" "raw" "read" "record" +"ref" "reference" "relies_on" "rem" "remainder" "rename" "result" +"result_cache" "return" "returning" "reverse" "rollback" "row" +"sample" "save" "savepoint" "sb1" "sb2" "sb4" "second" "segment" +"self" "separate" "sequence" "serializable" "set" "short" "size_t" +"some" "sparse" "sqlcode" "sqldata" "sqlname" "sqlstate" "standard" +"static" "stddev" "stored" "string" "struct" "style" "submultiset" +"subpartition" "substitutable" "sum" "synonym" "tdo" "the" "time" +"timestamp" "timezone_abbr" "timezone_hour" "timezone_minute" +"timezone_region" "trailing" "transaction" "transactional" "trusted" +"ub1" "ub2" "ub4" "under" "unsigned" "untrusted" "use" "using" +"valist" "value" "variable" "variance" "varray" "varying" "void" +"while" "work" "wrapped" "write" "year" "zone" +;; Pragma +"autonomous_transaction" "exception_init" "inline" +"restrict_references" "serially_reusable" ) ;; Oracle PL/SQL Data Types (sql-font-lock-keywords-builder 'font-lock-type-face nil -"binary_integer" "boolean" "naturaln" "pls_integer" "positive" -"positiven" "record" "signtype" "string" +"\"BINARY LARGE OBJECT\"" "\"CHAR LARGE OBJECT\"" "\"CHAR VARYING\"" +"\"CHARACTER LARGE OBJECT\"" "\"CHARACTER VARYING\"" +"\"DOUBLE PRECISION\"" "\"INTERVAL DAY TO SECOND\"" +"\"INTERVAL YEAR TO MONTH\"" "\"LONG RAW\"" "\"NATIONAL CHAR\"" +"\"NATIONAL CHARACTER LARGE OBJECT\"" "\"NATIONAL CHARACTER\"" +"\"NCHAR LARGE OBJECT\"" "\"NCHAR\"" "\"NCLOB\"" "\"NVARCHAR2\"" +"\"TIME WITH TIME ZONE\"" "\"TIMESTAMP WITH LOCAL TIME ZONE\"" +"\"TIMESTAMP WITH TIME ZONE\"" +"bfile" "bfile_base" "binary_double" "binary_float" "binary_integer" +"blob" "blob_base" "boolean" "char" "character" "char_base" "clob" +"clob_base" "cursor" "date" "day" "dec" "decimal" +"dsinterval_unconstrained" "float" "int" "integer" "interval" "local" +"long" "mlslabel" "month" "natural" "naturaln" "nchar_cs" "number" +"number_base" "numeric" "pls_integer" "positive" "positiven" "raw" +"real" "ref" "rowid" "second" "signtype" "simple_double" +"simple_float" "simple_integer" "smallint" "string" "time" "timestamp" +"timestamp_ltz_unconstrained" "timestamp_tz_unconstrained" +"timestamp_unconstrained" "time_tz_unconstrained" "time_unconstrained" +"to" "urowid" "varchar" "varchar2" "with" "year" +"yminterval_unconstrained" "zone" ) ;; Oracle PL/SQL Exceptions (sql-font-lock-keywords-builder 'font-lock-warning-face nil "access_into_null" "case_not_found" "collection_is_null" "cursor_already_open" "dup_val_on_index" "invalid_cursor" -"invalid_number" "login_denied" "no_data_found" "not_logged_on" -"program_error" "rowtype_mismatch" "self_is_null" "storage_error" -"subscript_beyond_count" "subscript_outside_limit" "sys_invalid_rowid" -"timeout_on_resource" "too_many_rows" "value_error" "zero_divide" -"exception" "notfound" +"invalid_number" "login_denied" "no_data_found" "no_data_needed" +"not_logged_on" "program_error" "rowtype_mismatch" "self_is_null" +"storage_error" "subscript_beyond_count" "subscript_outside_limit" +"sys_invalid_rowid" "timeout_on_resource" "too_many_rows" +"value_error" "zero_divide" ))) "Oracle SQL keywords used by font-lock. @@ -2296,10 +2512,7 @@ (let ;; Get the product-specific syntax-alist. - ((syntax-alist - (append - (sql-get-product-feature sql-product :syntax-alist) - '((?_ . "w") (?. . "w"))))) + ((syntax-alist (sql-product-font-lock-syntax-alist))) ;; Get the product-specific keywords. (set (make-local-variable 'sql-mode-font-lock-keywords) @@ -2388,9 +2601,30 @@ ;;; Functions to switch highlighting +(defun sql-product-syntax-table () + (let ((table (copy-syntax-table sql-mode-syntax-table))) + (mapc (lambda (entry) + (modify-syntax-entry (car entry) (cdr entry) table)) + (sql-get-product-feature sql-product :syntax-alist)) + table)) + +(defun sql-product-font-lock-syntax-alist () + (append + ;; Change all symbol character to word characters + (mapcar + (lambda (entry) (if (string= (substring (cdr entry) 0 1) "_") + (cons (car entry) + (concat "w" (substring (cdr entry) 1))) + entry)) + (sql-get-product-feature sql-product :syntax-alist)) + '((?_ . "w")))) + (defun sql-highlight-product () "Turn on the font highlighting for the SQL product selected." (when (derived-mode-p 'sql-mode) + ;; Enhance the syntax table for the product + (set-syntax-table (sql-product-syntax-table)) + ;; Setup font-lock (sql-product-font-lock nil t) @@ -2418,11 +2652,77 @@ ;; comint-line-beginning-position is defined in Emacs 21 (defun comint-line-beginning-position () "Return the buffer position of the beginning of the line, after any prompt. -The prompt is assumed to be any text at the beginning of the line matching -the regular expression `comint-prompt-regexp', a buffer local variable." +The prompt is assumed to be any text at the beginning of the line +matching the regular expression `comint-prompt-regexp', a buffer +local variable." (save-excursion (comint-bol nil) (point)))) - +;;; Motion Functions + +(defun sql-statement-regexp (prod) + (let* ((ansi-stmt (sql-get-product-feature 'ansi :statement)) + (prod-stmt (sql-get-product-feature prod :statement))) + (concat "^\\<" + (if prod-stmt + ansi-stmt + (concat "\\(" ansi-stmt "\\|" prod-stmt "\\)")) + "\\>"))) + +(defun sql-beginning-of-statement (arg) + "Moves the cursor to the beginning of the current SQL statement." + (interactive "p") + + (let ((here (point)) + (regexp (sql-statement-regexp sql-product)) + last next) + + ;; Go to the end of the statement before the start we desire + (setq last (or (sql-end-of-statement (- arg)) + (point-min))) + ;; And find the end after that + (setq next (or (sql-end-of-statement 1) + (point-max))) + + ;; Our start must be between them + (goto-char last) + ;; Find an beginning-of-stmt that's not in a comment + (while (and (re-search-forward regexp next t 1) + (nth 7 (syntax-ppss))) + (goto-char (match-end 0))) + (goto-char + (if (match-data) + (match-beginning 0) + last)) + (beginning-of-line) + ;; If we didn't move, try again + (when (= here (point)) + (sql-beginning-of-statement (* 2 (sql-signum arg)))))) + +(defun sql-end-of-statement (arg) + "Moves the cursor 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)) + (here (point)) + (n 0)) + (when (consp term) + (setq term (car term))) + ;; Iterate until we've moved the desired number of stmt ends + (while (not (= (sql-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))) + (setq n 2) + (setq n 1)) + ;; If we found another end-of-stmt + (if (not (apply re-search term nil t n nil)) + (setq arg 0) + ;; count it if we're not in a comment + (unless (nth 7 (syntax-ppss)) + (setq arg (- arg (sql-signum arg)))))) + (goto-char (if (match-data) + (match-end 0) + here)))) ;;; Small functions @@ -2456,7 +2756,7 @@ (defun sql-help-list-products (indent freep) "Generate listing of products available for use under SQLi. -List products with :free-softare attribute set to FREEP. Indent +List products with :free-software attribute set to FREEP. Indent each line with INDENT." (let (sqli-func doc) @@ -2649,7 +2949,7 @@ nil (append '(:number t) plist))))))) what)) -(defun sql-find-sqli-buffer (&optional product) +(defun sql-find-sqli-buffer (&optional product connection) "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." @@ -2657,16 +2957,16 @@ (prod (or product sql-product))) (or ;; Current sql-buffer, if there is one. - (and (sql-buffer-live-p buf prod) + (and (sql-buffer-live-p buf prod connection) buf) ;; Global sql-buffer (and (setq buf (default-value 'sql-buffer)) - (sql-buffer-live-p buf prod) + (sql-buffer-live-p buf prod connection) buf) ;; Look thru each buffer (car (apply 'append (mapcar (lambda (b) - (and (sql-buffer-live-p b prod) + (and (sql-buffer-live-p b prod connection) (list (buffer-name b)))) (buffer-list))))))) @@ -2722,7 +3022,8 @@ This is the buffer SQL strings are sent to. It is stored in the variable `sql-buffer'. See `sql-help' on how to create such a buffer." (interactive) - (if (null (buffer-live-p (get-buffer sql-buffer))) + (if (or (null sql-buffer) + (null (buffer-live-p (get-buffer sql-buffer)))) (message "%s has no SQLi buffer set." (buffer-name (current-buffer))) (if (null (get-buffer-process sql-buffer)) (message "Buffer %s has no process." sql-buffer) @@ -2932,37 +3233,58 @@ ;;; Strip out continuation prompts +(defvar sql-preoutput-hold nil) + (defun sql-interactive-remove-continuation-prompt (oline) "Strip out continuation prompts out of the OLINE. Added to the `comint-preoutput-filter-functions' hook in a SQL -interactive buffer. If `sql-outut-newline-count' is greater than +interactive buffer. If `sql-output-newline-count' is greater than zero, then an output line matching the continuation prompt is filtered -out. If the count is one, then the prompt is replaced with a newline -to force the output from the query to appear on a new line." - (if (and sql-prompt-cont-regexp - sql-output-newline-count - (numberp sql-output-newline-count) - (>= sql-output-newline-count 1)) - (progn - (while (and oline - sql-output-newline-count - (> sql-output-newline-count 0) - (string-match sql-prompt-cont-regexp oline)) - - (setq oline - (replace-match (if (and - (= 1 sql-output-newline-count) - sql-output-by-send) - "\n" "") - nil nil oline) - sql-output-newline-count - (1- sql-output-newline-count))) - (if (= sql-output-newline-count 0) - (setq sql-output-newline-count nil)) - (setq sql-output-by-send nil)) - (setq sql-output-newline-count nil)) - oline) +out. If the count is zero, then a newline is inserted into the output +to force the output from the query to appear on a new line. + +The complication to this filter is that the continuation prompts +may arrive in multiple chunks. If they do, then the function +saves any unfiltered output in a buffer and prepends that buffer +to the next chunk to properly match the broken-up prompt. + +If the filter gets confused, it should reset and stop filtering +to avoid deleting non-prompt output." + + (let (did-filter) + (setq oline (concat (or sql-preoutput-hold "") oline) + sql-preoutput-hold nil) + + (if (and comint-prompt-regexp + (integerp sql-output-newline-count) + (>= sql-output-newline-count 1)) + (progn + (while (and (not (string= oline "")) + (> sql-output-newline-count 0) + (string-match comint-prompt-regexp oline) + (= (match-beginning 0) 0)) + + (setq oline (replace-match "" nil nil oline) + sql-output-newline-count (1- sql-output-newline-count) + did-filter t)) + + (if (= sql-output-newline-count 0) + (setq sql-output-newline-count nil + oline (concat "\n" oline) + sql-output-by-send nil) + + (setq sql-preoutput-hold oline + oline "")) + + (unless did-filter + (setq oline (or sql-preoutput-hold "") + sql-preoutput-hold nil + sql-output-newline-count nil))) + + (setq sql-output-newline-count nil)) + + oline)) ;;; Sending the region to the SQLi buffer. @@ -3066,16 +3388,35 @@ ;;; Redirect output functions -(defun sql-redirect (command combuf &optional outbuf save-prior) +(defvar sql-debug-redirect nil + "If non-nil, display messages related to the use of redirection.") + +(defun sql-str-literal (s) + (concat "'" (replace-regexp-in-string "[']" "''" s) "'")) + +(defun sql-redirect (sqlbuf command &optional outbuf save-prior) "Execute the SQL command and send output to OUTBUF. -COMBUF must be an active SQL interactive buffer. OUTBUF may be +SQLBUF 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 +of commands accepted by the SQLi program. COMMAND may also be a +list of SQLi command strings." + + (let* ((visible (and outbuf + (not (string= " " (substring outbuf 0 1)))))) + (when visible + (message "Executing SQL command...")) + (if (consp command) + (mapc (lambda (c) (sql-redirect-one sqlbuf c outbuf save-prior)) + command) + (sql-redirect-one sqlbuf command outbuf save-prior)) + (when visible + (message "Executing SQL command...done")))) + +(defun sql-redirect-one (sqlbuf command outbuf save-prior) + (with-current-buffer sqlbuf (let ((buf (get-buffer-create (or outbuf " *SQL-Redirect*"))) (proc (get-buffer-process (current-buffer))) (comint-prompt-regexp (sql-get-product-feature sql-product @@ -3090,12 +3431,13 @@ (insert "\n")) (setq start (point))) + (when sql-debug-redirect + (message ">>SQL> %S" command)) + ;; Run the command - (message "Executing SQL command...") (comint-redirect-send-command-to-process command buf proc nil t) (while (null comint-redirect-completed) (accept-process-output nil 1)) - (message "Executing SQL command...done") ;; Clean up the output results (with-current-buffer buf @@ -3107,12 +3449,16 @@ (goto-char start) (when (looking-at (concat "^" (regexp-quote command) "[\\n]")) (delete-region (match-beginning 0) (match-end 0))) + ;; Remove Ctrl-Ms + (goto-char start) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) (goto-char start))))) -(defun sql-redirect-value (command combuf regexp &optional regexp-groups) +(defun sql-redirect-value (sqlbuf command regexp &optional regexp-groups) "Execute the SQL command and return part of result. -COMBUF must be an active SQL interactive buffer. COMMAND should +SQLBUF 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 @@ -3122,18 +3468,19 @@ (let ((outbuf " *SQL-Redirect-values*") (results nil)) - (sql-redirect command combuf outbuf nil) + (sql-redirect sqlbuf command 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) + (let ((i (/ (length (match-data)) 2)) (r nil)) - (while (match-beginning i) + (while (> i 0) + (setq i (1- i)) (push (match-string i) r)) - (nreverse r))) + r)) ;; one group specified ((numberp regexp-groups) (match-string regexp-groups)) @@ -3152,10 +3499,14 @@ (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" regexp-groups))) results))) - (nreverse results))) - -(defun sql-execute (sqlbuf outbuf command arg) - "Executes a command in a SQL interacive buffer and captures the output. + + (when sql-debug-redirect + (message ">>SQL> = %S" (reverse results))) + + (nreverse results))) + +(defun sql-execute (sqlbuf outbuf command enhanced arg) + "Executes a command in a SQL interactive buffer and captures 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. @@ -3168,9 +3519,9 @@ (lambda (c) (cond ((stringp c) - (sql-redirect (if arg (format c arg) c) sqlbuf outbuf) t) + (sql-redirect sqlbuf (if arg (format c arg) c) outbuf) t) ((functionp c) - (apply c sqlbuf outbuf arg)) + (apply c sqlbuf outbuf enhanced arg nil)) (t (error "Unknown sql-execute item %s" c)))) (if (consp command) command (cons command nil))) @@ -3197,14 +3548,92 @@ (setq command (if enhanced (cdr command) (car command)))) - (sql-execute sqlbuf outbuf command arg))) + (sql-execute sqlbuf outbuf command enhanced arg))) + +(defvar sql-completion-object nil + "A list of database objects used for completion. + +The list is maintained in SQL interactive buffers.") + +(defvar sql-completion-column nil + "A list of column names used for completion. + +The list is maintained in SQL interactive buffers.") + +(defun sql-build-completions-1 (schema completion-list feature) + "Generate a list of objects in the database for use as completions." + (let ((f (sql-get-product-feature sql-product feature))) + (when f + (set completion-list + (let (cl) + (dolist (e (append (symbol-value completion-list) + (apply f (current-buffer) (cons schema nil))) + cl) + (unless (member e cl) (setq cl (cons e cl)))) + (sort cl (function string<))))))) + +(defun sql-build-completions (schema) + "Generate a list of names in the database for use as completions." + (sql-build-completions-1 schema 'sql-completion-object :completion-object) + (sql-build-completions-1 schema 'sql-completion-column :completion-column)) + +(defvar sql-completion-sqlbuf nil) + +(defun sql-try-completion (string collection &optional predicate) + (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))))))) (defun sql-read-table-name (prompt) "Read the name of a database table." - ;; TODO: Fetch table/view names from database and provide completion. - ;; Also implement thing-at-point if the buffer has valid names in it - ;; (i.e. sql-mode, sql-interactive-mode, or sql-list-all buffers) - (read-from-minibuffer prompt)) + (let* ((tname + (and (buffer-local-value 'sql-contains-names (current-buffer)) + (thing-at-point-looking-at + (concat "\\_<\\sw\\(:?\\sw\\|\\s_\\)*" + "\\(?:[.]+\\sw\\(?:\\sw\\|\\s_\\)*\\)*\\_>")) + (buffer-substring-no-properties (match-beginning 0) + (match-end 0)))) + (sql-completion-sqlbuf (sql-find-sqli-buffer)) + (product (with-current-buffer sql-completion-sqlbuf sql-product)) + (completion-ignore-case t)) + + (if (sql-get-product-feature product :completion-object) + (completing-read prompt (function sql-try-completion) + nil nil tname) + (read-from-minibuffer prompt tname)))) (defun sql-list-all (&optional enhanced) "List all database objects." @@ -3212,7 +3641,11 @@ (let ((sqlbuf (sql-find-sqli-buffer))) (unless sqlbuf (error "No SQL interactive buffer found")) - (sql-execute-feature sqlbuf "*List All*" :list-all enhanced nil))) + (sql-execute-feature sqlbuf "*List All*" :list-all enhanced nil) + (with-current-buffer sqlbuf + ;; Contains the name of database objects + (set (make-local-variable 'sql-contains-names) t) + (set (make-local-variable 'sql-buffer) sqlbuf)))) (defun sql-list-table (name &optional enhanced) "List the details of a database table. " @@ -3226,7 +3659,6 @@ (error "No table name specified")) (sql-execute-feature sqlbuf (format "*List %s*" name) :list-table enhanced name))) - ;;; SQL mode -- uses SQL interactive mode @@ -3277,6 +3709,8 @@ (set (make-local-variable 'paragraph-start) "[\n\f]") ;; Abbrevs (setq 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 (add-hook 'hack-local-variables-hook 'sql-highlight-product t t)) @@ -3362,7 +3796,7 @@ sql-product)) ;; Setup the mode. - (setq major-mode 'sql-interactive-mode) ;FIXME: Use define-derived-mode. + (setq major-mode 'sql-interactive-mode) (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name) (symbol-name sql-product)) "]")) @@ -3385,9 +3819,18 @@ (setq abbrev-all-caps 1) ;; Exiting the process will call sql-stop. (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop) - ;; Save the connection name - (make-local-variable 'sql-connection) - ;; Create a usefull name for renaming this buffer later. + ;; Save the connection and login params + (set (make-local-variable 'sql-user) sql-user) + (set (make-local-variable 'sql-database) sql-database) + (set (make-local-variable 'sql-server) sql-server) + (set (make-local-variable 'sql-port) sql-port) + (set (make-local-variable 'sql-connection) sql-connection) + ;; Contains the name of database objects + (set (make-local-variable 'sql-contains-names) t) + ;; Keep track of existing object names + (set (make-local-variable 'sql-completion-object) nil) + (set (make-local-variable 'sql-completion-column) nil) + ;; Create a useful name for renaming this buffer later. (set (make-local-variable 'sql-alternate-buffer-name) (sql-make-alternate-buffer-name)) ;; User stuff. Initialize before the hook. @@ -3398,6 +3841,7 @@ (set (make-local-variable 'sql-prompt-cont-regexp) (sql-get-product-feature sql-product :prompt-cont-regexp)) (make-local-variable 'sql-output-newline-count) + (make-local-variable 'sql-preoutput-hold) (make-local-variable 'sql-output-by-send) (add-hook 'comint-preoutput-filter-functions 'sql-interactive-remove-continuation-prompt nil t) @@ -3450,7 +3894,7 @@ nil t initial 'sql-connection-history default))) ;;;###autoload -(defun sql-connect (connection) +(defun sql-connect (connection &optional new-name) "Connect to an interactive session using CONNECTION settings. See `sql-connection-alist' to see how to define connections and @@ -3462,7 +3906,8 @@ ;; Prompt for the connection from those defined in the alist (interactive (if sql-connection-alist - (list (sql-read-connection "Connection: " nil '(nil))) + (list (sql-read-connection "Connection: " nil '(nil)) + current-prefix-arg) nil)) ;; Are there connections defined @@ -3500,14 +3945,15 @@ (unless (member token set-params) (if plist (cons token plist) - token))))) - ;; Remember the connection - (sql-connection connection)) + token)))))) ;; Set the remaining parameters and start the ;; interactive session - (eval `(let ((,param-var ',rem-params)) - (sql-product-interactive sql-product))))) + (eval `(let ((sql-connection ,connection) + (,param-var ',rem-params)) + (sql-product-interactive sql-product + new-name))))) + (message "SQL Connection <%s> does not exist" connection) nil))) (message "No SQL Connections defined") @@ -3521,39 +3967,51 @@ (interactive "sNew connection name: ") - (if sql-connection - (message "This session was started by a connection; it's already been saved.") - - (let ((login (sql-get-product-feature sql-product :sqli-login)) - (alist sql-connection-alist) - connect) - - ;; Remove the existing connection if the user says so - (when (and (assoc name alist) - (yes-or-no-p (format "Replace connection definition <%s>? " name))) - (setq alist (assq-delete-all name alist))) - - ;; Add the new connection if it doesn't exist - (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 ',sql-product)) - ((eq token 'user) `(sql-user ,sql-user)) - ((eq token 'database) `(sql-database ,sql-database)) - ((eq token 'server) `(sql-server ,sql-server)) - ((eq token 'port) `(sql-port ,sql-port))))))) - - (setq alist (append alist (list connect))) - - ;; confirm whether we want to save the connections - (if (yes-or-no-p "Save the connections for future sessions? ") - (customize-save-variable 'sql-connection-alist alist) - (customize-set-variable 'sql-connection-alist alist)))))) + (unless (derived-mode-p 'sql-interactive-mode) + (error "Not in a SQL interactive mode!")) + + ;; Capture the buffer local settings + (let* ((buf (current-buffer)) + (connection (buffer-local-value 'sql-connection buf)) + (product (buffer-local-value 'sql-product buf)) + (user (buffer-local-value 'sql-user buf)) + (database (buffer-local-value 'sql-database buf)) + (server (buffer-local-value 'sql-server buf)) + (port (buffer-local-value 'sql-port buf))) + + (if connection + (message "This session was started by a connection; it's already been saved.") + + (let ((login (sql-get-product-feature product :sqli-login)) + (alist sql-connection-alist) + connect) + + ;; Remove the existing connection if the user says so + (when (and (assoc name alist) + (yes-or-no-p (format "Replace connection definition <%s>? " name))) + (setq alist (assq-delete-all name alist))) + + ;; Add the new connection if it doesn't exist + (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))))))) + + (setq alist (append alist (list connect))) + + ;; confirm whether we want to save the connections + (if (yes-or-no-p "Save the connections for future sessions? ") + (customize-save-variable 'sql-connection-alist alist) + (customize-set-variable 'sql-connection-alist alist))))))) (defun sql-connection-menu-filter (tail) "Generates menu entries for using each connection." @@ -3561,7 +4019,10 @@ (mapcar (lambda (conn) (vector - (format "Connection <%s>" (car conn)) + (format "Connection <%s>\t%s" (car conn) + (let ((sql-user "") (sql-database "") + (sql-server "") (sql-port 0)) + (eval `(let ,(cdr conn) (sql-make-alternate-buffer-name))))) (list 'sql-connect (car conn)) t)) sql-connection-alist) @@ -3599,10 +4060,10 @@ ;; Get the value of product that we need (setq product (cond + ((= (prefix-numeric-value product) 4) ; C-u, prompt for product + (sql-read-product "SQL product: " sql-product)) ((and product ; Product specified (symbolp product)) product) - ((= (prefix-numeric-value product) 4) ; C-u, prompt for product - (sql-read-product "SQL product: " sql-product)) (t sql-product))) ; Default to sql-product ;; If we have a product and it has a interactive mode @@ -3610,7 +4071,7 @@ (when (sql-get-product-feature product :sqli-comint-func) ;; If no new name specified, try to pop to an active SQL ;; interactive for the same product - (let ((buf (sql-find-sqli-buffer product))) + (let ((buf (sql-find-sqli-buffer product sql-connection))) (if (and (not new-name) buf) (pop-to-buffer buf) @@ -3629,23 +4090,24 @@ (sql-get-product-feature product :sqli-options)) ;; Set SQLi mode. - (setq new-sqli-buffer (current-buffer)) (let ((sql-interactive-product product)) (sql-interactive-mode)) ;; Set the new buffer name + (setq new-sqli-buffer (current-buffer)) (when new-name (sql-rename-buffer new-name)) - - ;; Set `sql-buffer' in the new buffer and the start buffer (setq sql-buffer (buffer-name new-sqli-buffer)) + + ;; Set `sql-buffer' in the start buffer (with-current-buffer start-buffer - (setq sql-buffer (buffer-name new-sqli-buffer)) - (run-hooks 'sql-set-sqli-hook)) + (when (derived-mode-p 'sql-mode) + (setq sql-buffer (buffer-name new-sqli-buffer)) + (run-hooks 'sql-set-sqli-hook))) ;; All done. (message "Login...done") - (pop-to-buffer sql-buffer))))) + (pop-to-buffer new-sqli-buffer))))) (message "No default SQL product defined. Set `sql-product'."))) (defun sql-comint (product params) @@ -3720,6 +4182,157 @@ (setq parameter options)) (sql-comint product parameter))) +(defun sql-oracle-save-settings (sqlbuf) + "Saves most SQL*Plus settings so they may be reset by \\[sql-redirect]." + ;; Note: does not capture the following settings: + ;; + ;; APPINFO + ;; BTITLE + ;; COMPATIBILITY + ;; COPYTYPECHECK + ;; MARKUP + ;; RELEASE + ;; REPFOOTER + ;; REPHEADER + ;; SQLPLUSCOMPATIBILITY + ;; TTITLE + ;; USER + ;; + + (append + ;; (apply 'concat (append + ;; '("SET") + + ;; option value... + (sql-redirect-value + sqlbuf + (concat "SHOW ARRAYSIZE AUTOCOMMIT AUTOPRINT AUTORECOVERY AUTOTRACE" + " CMDSEP COLSEP COPYCOMMIT DESCRIBE ECHO EDITFILE EMBEDDED" + " ESCAPE FLAGGER FLUSH HEADING INSTANCE LINESIZE LNO LOBOFFSET" + " LOGSOURCE LONG LONGCHUNKSIZE NEWPAGE NULL NUMFORMAT NUMWIDTH" + " PAGESIZE PAUSE PNO RECSEP SERVEROUTPUT SHIFTINOUT SHOWMODE" + " SPOOL SQLBLANKLINES SQLCASE SQLCODE SQLCONTINUE SQLNUMBER" + " SQLPROMPT SUFFIX TAB TERMOUT TIMING TRIMOUT TRIMSPOOL VERIFY") + "^.+$" + "SET \\&") + + ;; option "c" (hex xx) + (sql-redirect-value + sqlbuf + (concat "SHOW BLOCKTERMINATOR CONCAT DEFINE SQLPREFIX SQLTERMINATOR" + " UNDERLINE HEADSEP RECSEPCHAR") + "^\\(.+\\) (hex ..)$" + "SET \\1") + + ;; FEDDBACK ON for 99 or more rows + ;; feedback OFF + (sql-redirect-value + sqlbuf + "SHOW FEEDBACK" + "^\\(?:FEEDBACK ON for \\([[:digit:]]+\\) or more rows\\|feedback \\(OFF\\)\\)" + "SET FEEDBACK \\1\\2") + + ;; wrap : lines will be wrapped + ;; wrap : lines will be truncated + (list (concat "SET WRAP " + (if (string= + (car (sql-redirect-value + sqlbuf + "SHOW WRAP" + "^wrap : lines will be \\(wrapped\\|truncated\\)" 1)) + "wrapped") + "ON" "OFF"))))) + +(defun sql-oracle-restore-settings (sqlbuf saved-settings) + "Restore the SQL*Plus settings in SAVED-SETTINGS." + + ;; Remove any settings that haven't changed + (mapc + (lambda (one-cur-setting) + (setq saved-settings (delete one-cur-setting saved-settings))) + (sql-oracle-save-settings sqlbuf)) + + ;; Restore the changed settings + (sql-redirect sqlbuf saved-settings)) + +(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 + (concat + "SELECT INITCAP(x.object_type) AS SQL_EL_TYPE " + ", x.object_name AS SQL_EL_NAME " + "FROM user_objects x " + "WHERE x.object_type NOT LIKE '%% BODY' " + "ORDER BY 2, 1;")) + (enhanced-sql + (concat + "SELECT INITCAP(x.object_type) AS SQL_EL_TYPE " + ", x.owner ||'.'|| x.object_name AS SQL_EL_NAME " + "FROM all_objects x " + "WHERE x.object_type NOT LIKE '%% BODY' " + "AND x.owner <> 'SYS' " + "ORDER BY 2, 1;"))) + + (sql-redirect sqlbuf + (concat "SET LINESIZE 80 PAGESIZE 50000 TRIMOUT ON" + " TAB OFF TIMING OFF FEEDBACK OFF")) + + (sql-redirect sqlbuf + (list "COLUMN SQL_EL_TYPE HEADING \"Type\" FORMAT A19" + "COLUMN SQL_EL_NAME HEADING \"Name\"" + (format "COLUMN SQL_EL_NAME FORMAT A%d" + (if enhanced 60 35)))) + + (sql-redirect sqlbuf + (if enhanced enhanced-sql simple-sql) + outbuf) + + (sql-redirect sqlbuf + '("COLUMN SQL_EL_NAME CLEAR" + "COLUMN SQL_EL_TYPE CLEAR")) + + (sql-oracle-restore-settings sqlbuf settings))) + +(defun sql-oracle-list-table (sqlbuf outbuf enhanced table-name) + "Implements :list-table under Oracle." + (let ((settings (sql-oracle-save-settings sqlbuf))) + + (sql-redirect sqlbuf + (format + (concat "SET LINESIZE %d PAGESIZE 50000" + " DESCRIBE DEPTH 1 LINENUM OFF INDENT ON") + (max 65 (min 120 (window-width))))) + + (sql-redirect sqlbuf (format "DESCRIBE %s" table-name) + outbuf) + + (sql-oracle-restore-settings sqlbuf settings))) + +(defcustom sql-oracle-completion-types '("FUNCTION" "PACKAGE" "PROCEDURE" + "SEQUENCE" "SYNONYM" "TABLE" "TRIGGER" + "TYPE" "VIEW") + "List of object types to include for completion under Oracle. + +See the distinct values in ALL_OBJECTS.OBJECT_TYPE for possible values." + :version "24.1" + :type '(repeat string) + :group 'SQL) + +(defun sql-oracle-completion-object (sqlbuf schema) + (sql-redirect-value + sqlbuf + (concat + "SELECT CHR(1)||" + (if schema + (format "owner||'.'||object_name AS o FROM all_objects WHERE owner = %s AND " + (sql-str-literal (upcase schema))) + "object_name AS o FROM user_objects WHERE ") + "temporary = 'N' AND generated = 'N' AND secondary = 'N' AND " + "object_type IN (" + (mapconcat (function sql-str-literal) sql-oracle-completion-types ",") + ");") + "^[\001]\\(.+\\)$" 1)) ;;;###autoload @@ -3858,6 +4471,9 @@ (setq params (append options params)) (sql-comint product params))) +(defun sql-sqlite-completion-object (sqlbuf schema) + (sql-redirect-value sqlbuf ".tables" "\\sw\\(?:\\sw\\|\\s_\\)*" 0)) + ;;;###autoload @@ -4112,6 +4728,33 @@ (setq params (append (list "-p" sql-port) params))) (sql-comint product params))) +(defun sql-postgres-completion-object (sqlbuf schema) + (let (cl re fs a r) + (sql-redirect sqlbuf "\\t on") + (setq a (car (sql-redirect-value sqlbuf "\\a" "Output format is \\(.*\\)[.]$" 1))) + (when (string= a "aligned") + (sql-redirect sqlbuf "\\a")) + (setq fs (or (car (sql-redirect-value sqlbuf "\\f" "Field separator is \"\\(.\\)[.]$" 1)) "|")) + + (setq re (concat "^\\([^" fs "]*\\)" fs "\\([^" fs "]*\\)" fs "[^" fs "]*" fs "[^" fs "]*$")) + (setq cl (if (not schema) + (sql-redirect-value sqlbuf "\\d" re '(1 2)) + (append (sql-redirect-value sqlbuf (format "\\dt %s.*" schema) re '(1 2)) + (sql-redirect-value sqlbuf (format "\\dv %s.*" schema) re '(1 2)) + (sql-redirect-value sqlbuf (format "\\ds %s.*" schema) re '(1 2))))) + + ;; Restore tuples and alignment to what they were + (sql-redirect sqlbuf "\\t off") + (when (not (string= a "aligned")) + (sql-redirect sqlbuf "\\a")) + + ;; Return the list of table names (public schema name can be omitted) + (mapcar (lambda (tbl) + (if (string= (car tbl) "public") + (cadr tbl) + (format "%s.%s" (car tbl) (cadr tbl)))) + cl))) + ;;;###autoload @@ -4199,8 +4842,7 @@ "Create comint buffer and connect to DB2." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (sql-comint product options) -) + (sql-comint product options)) ;;;###autoload (defun sql-linter (&optional buffer) @@ -4257,3 +4899,6 @@ (provide 'sql) ;;; sql.el ends here + +; LocalWords: sql SQL SQLite sqlite Sybase Informix MySQL +; LocalWords: Postgres SQLServer SQLi ------------------------------------------------------------ revno: 104981 committer: Glenn Morris branch nick: trunk timestamp: Tue 2011-07-05 19:46:22 -0700 message: * lisp/window.el (pop-to-buffer): Doc fix. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-06 02:42:10 +0000 +++ lisp/ChangeLog 2011-07-06 02:46:22 +0000 @@ -1,3 +1,7 @@ +2011-07-06 Glenn Morris + + * window.el (pop-to-buffer): Doc fix. + 2011-07-06 Markus Heiser (tiny change) * progmodes/gud.el (gud-pdb-marker-regexp): Accept \r char (Bug#5653). === modified file 'lisp/window.el' --- lisp/window.el 2011-07-06 02:42:10 +0000 +++ lisp/window.el 2011-07-06 02:46:22 +0000 @@ -5797,31 +5797,30 @@ (defun pop-to-buffer (&optional buffer-or-name specifiers norecord label) "Display buffer specified by BUFFER-OR-NAME and select the window used. Optional argument BUFFER-OR-NAME may be a buffer, a string \(a -buffer name), or nil. If BUFFER-OR-NAME is a string not naming -an existent buffer, create a buffer with that name. If +buffer name), or nil. If BUFFER-OR-NAME is a string naming a buffer +that does not exist, create a buffer with that name. If BUFFER-OR-NAME is nil or omitted, display the current buffer. Interactively, prompt for the buffer name using the minibuffer. -Optional second argument SPECIFIERS must be a list of buffer -display specifiers, a single location specifier, `t' which means -the latter means to display the buffer in any but the selected -window, or nil which means to exclusively apply the specifiers -customized by the user. +Optional second argument SPECIFIERS can be: a list of buffer +display specifiers (see `display-buffer-alist'); a single +location specifier; t, which means to display the buffer in any +but the selected window; or nil, which means to exclusively apply +the specifiers customized by the user. See `display-buffer' for +more details. -Optional argument NORECORD non-nil means do not put the buffer -specified by BUFFER-OR-NAME at the front of the buffer list and -do not make the window displaying it the most recently selected -one. +Optional argument NORECORD non-nil means do not put the displayed +buffer at the front of the buffer list, and do not make the window +displaying it the most recently selected one. The optional argument LABEL, if non-nil, is a symbol specifying the display purpose. Applications should set this when the buffer -shall be displayed in a special way but BUFFER-OR-NAME does not +should be displayed in a special way but BUFFER-OR-NAME does not identify the buffer as special. Buffers that typically fit into this category are those whose names have been derived from the name of the file they are visiting. -Return the buffer specified by BUFFER-OR-NAME or nil if -displaying the buffer failed. +Returns the displayed buffer, or nil if displaying the buffer failed. This uses the function `display-buffer' as a subroutine; see the documentations of `display-buffer' and `display-buffer-alist' for ------------------------------------------------------------ revno: 104980 committer: Glenn Morris branch nick: trunk timestamp: Tue 2011-07-05 19:45:24 -0700 message: * gnus-group.el (gnus-read-ephemeral-emacs-bug-group): Silence compiler. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-07-05 23:06:11 +0000 +++ lisp/gnus/ChangeLog 2011-07-06 02:45:24 +0000 @@ -1,3 +1,7 @@ +2011-07-06 Glenn Morris + + * gnus-group.el (gnus-read-ephemeral-emacs-bug-group): Silence compiler. + 2011-07-05 Lars Magne Ingebrigtsen * gnus.el (gnus-refer-article-method): Remove mention of nnspool, which === modified file 'lisp/gnus/gnus-group.el' --- lisp/gnus/gnus-group.el 2011-07-05 22:27:16 +0000 +++ lisp/gnus/gnus-group.el 2011-07-06 02:45:24 +0000 @@ -2469,6 +2469,8 @@ number (cdr (assoc 'debian gnus-bug-group-download-format-alist)))) +(defvar debbugs-bug-number) ; debbugs-gnu + (defun gnus-read-ephemeral-emacs-bug-group (ids &optional window-conf) "Browse Emacs bugs IDS as an ephemeral group." (interactive (list (string-to-number @@ -2480,7 +2482,7 @@ ids (cdr (assoc 'emacs gnus-bug-group-download-format-alist)) window-conf) - (when (boundp 'debbugs-summary-mode) + (when (fboundp 'debbugs-summary-mode) (with-current-buffer (window-buffer (selected-window)) (debbugs-summary-mode 1) (set (make-local-variable 'debbugs-bug-number) (car ids))))) ------------------------------------------------------------ revno: 104979 [merge] committer: Glenn Morris branch nick: trunk timestamp: Tue 2011-07-05 19:42:10 -0700 message: Merge from emacs-23; up to r100609. diff: === modified file 'doc/lispref/ChangeLog' --- doc/lispref/ChangeLog 2011-07-03 18:44:53 +0000 +++ doc/lispref/ChangeLog 2011-07-06 02:42:10 +0000 @@ -1,3 +1,13 @@ +2011-07-06 Chong Yidong + + * customize.texi (Composite Types): Move alist and plist to here + from Simple Types (Bug#7545). + + * elisp.texi (Top): Update menu description. + + * display.texi (Face Attributes): Document negative line widths + (Bug#6113). + 2011-07-03 Tobias C. Rittweiler (tiny change) * searching.texi (Match Data): Note that match data can be === modified file 'doc/lispref/customize.texi' --- doc/lispref/customize.texi 2011-07-02 23:52:35 +0000 +++ doc/lispref/customize.texi 2011-07-06 02:42:10 +0000 @@ -513,8 +513,7 @@ Introduction, widget, The Emacs Widget Library}, for details. @menu -* Simple Types:: Simple customization types: sexp, integer, number, - string, file, directory, alist. +* Simple Types:: Simple customization types: sexp, integer, etc. * Composite Types:: Build new types from other types or data. * Splicing into Lists:: Splice elements into list with @code{:inline}. * Type Keywords:: Keyword-argument pairs in a customization type. @@ -577,22 +576,103 @@ @code{defcustom} to specify a list of functions recommended for use in the hook; see @ref{Variable Definitions}. -@item alist +@item symbol +The value must be a symbol. It appears in the customization buffer as +the name of the symbol. + +@item function +The value must be either a lambda expression or a function name. When +it is a function name, you can do completion with @kbd{M-@key{TAB}}. + +@item variable +The value must be a variable name, and you can do completion with +@kbd{M-@key{TAB}}. + +@item face +The value must be a symbol which is a face name, and you can do +completion with @kbd{M-@key{TAB}}. + +@item boolean +The value is boolean---either @code{nil} or @code{t}. Note that by +using @code{choice} and @code{const} together (see the next section), +you can specify that the value must be @code{nil} or @code{t}, but also +specify the text to describe each value in a way that fits the specific +meaning of the alternative. + +@item coding-system +The value must be a coding-system name, and you can do completion with +@kbd{M-@key{TAB}}. + +@item color +The value must be a valid color name, and you can do completion with +@kbd{M-@key{TAB}}. A sample is provided. +@end table + +@node Composite Types +@subsection Composite Types +@cindex composite types (customization) + + When none of the simple types is appropriate, you can use composite +types, which build new types from other types or from specified data. +The specified types or data are called the @dfn{arguments} of the +composite type. The composite type normally looks like this: + +@example +(@var{constructor} @var{arguments}@dots{}) +@end example + +@noindent +but you can also add keyword-value pairs before the arguments, like +this: + +@example +(@var{constructor} @r{@{}@var{keyword} @var{value}@r{@}}@dots{} @var{arguments}@dots{}) +@end example + + Here is a table of constructors and how to use them to write +composite types: + +@table @code +@item (cons @var{car-type} @var{cdr-type}) +The value must be a cons cell, its @sc{car} must fit @var{car-type}, and +its @sc{cdr} must fit @var{cdr-type}. For example, @code{(cons string +symbol)} is a customization type which matches values such as +@code{("foo" . foo)}. + +In the customization buffer, the @sc{car} and the @sc{cdr} are +displayed and edited separately, each according to the type +that you specify for it. + +@item (list @var{element-types}@dots{}) +The value must be a list with exactly as many elements as the +@var{element-types} given; and each element must fit the +corresponding @var{element-type}. + +For example, @code{(list integer string function)} describes a list of +three elements; the first element must be an integer, the second a +string, and the third a function. + +In the customization buffer, each element is displayed and edited +separately, according to the type specified for it. + +@item (group @var{element-types}@dots{}) +This works like @code{list} except for the formatting +of text in the Custom buffer. @code{list} labels each +element value with its tag; @code{group} does not. + +@item (vector @var{element-types}@dots{}) +Like @code{list} except that the value must be a vector instead of a +list. The elements work the same as in @code{list}. + +@item (alist :key-type @var{key-type} :value-type @var{value-type}) The value must be a list of cons-cells, the @sc{car} of each cell -representing a key, and the @sc{cdr} of the same cell representing an -associated value. The user can add and delete key/value pairs, and +representing a key of customization type @var{key-type}, and the +@sc{cdr} of the same cell representing a value of customization type +@var{value-type}. The user can add and delete key/value pairs, and edit both the key and the value of each pair. -You can specify the key and value types like this: - -@smallexample -(alist :key-type @var{key-type} :value-type @var{value-type}) -@end smallexample - -@noindent -where @var{key-type} and @var{value-type} are customization type -specifications. The default key type is @code{sexp}, and the default -value type is @code{sexp}. +If omitted, @var{key-type} and @var{value-type} default to +@code{sexp}. The user can add any key matching the specified key type, but you can give some keys a preferential treatment by specifying them with the @@ -687,105 +767,11 @@ :type '(alist :value-type (repeat string))) @end smallexample -@item plist -The @code{plist} custom type is similar to the @code{alist} (see above), -except that the information is stored as a property list, i.e. a list of -this form: - -@smallexample -(@var{key} @var{value} @var{key} @var{value} @var{key} @var{value} @dots{}) -@end smallexample - -The default @code{:key-type} for @code{plist} is @code{symbol}, -rather than @code{sexp}. - -@item symbol -The value must be a symbol. It appears in the customization buffer as -the name of the symbol. - -@item function -The value must be either a lambda expression or a function name. When -it is a function name, you can do completion with @kbd{M-@key{TAB}}. - -@item variable -The value must be a variable name, and you can do completion with -@kbd{M-@key{TAB}}. - -@item face -The value must be a symbol which is a face name, and you can do -completion with @kbd{M-@key{TAB}}. - -@item boolean -The value is boolean---either @code{nil} or @code{t}. Note that by -using @code{choice} and @code{const} together (see the next section), -you can specify that the value must be @code{nil} or @code{t}, but also -specify the text to describe each value in a way that fits the specific -meaning of the alternative. - -@item coding-system -The value must be a coding-system name, and you can do completion with -@kbd{M-@key{TAB}}. - -@item color -The value must be a valid color name, and you can do completion with -@kbd{M-@key{TAB}}. A sample is provided. -@end table - -@node Composite Types -@subsection Composite Types -@cindex composite types (customization) - - When none of the simple types is appropriate, you can use composite -types, which build new types from other types or from specified data. -The specified types or data are called the @dfn{arguments} of the -composite type. The composite type normally looks like this: - -@example -(@var{constructor} @var{arguments}@dots{}) -@end example - -@noindent -but you can also add keyword-value pairs before the arguments, like -this: - -@example -(@var{constructor} @r{@{}@var{keyword} @var{value}@r{@}}@dots{} @var{arguments}@dots{}) -@end example - - Here is a table of constructors and how to use them to write -composite types: - -@table @code -@item (cons @var{car-type} @var{cdr-type}) -The value must be a cons cell, its @sc{car} must fit @var{car-type}, and -its @sc{cdr} must fit @var{cdr-type}. For example, @code{(cons string -symbol)} is a customization type which matches values such as -@code{("foo" . foo)}. - -In the customization buffer, the @sc{car} and the @sc{cdr} are -displayed and edited separately, each according to the type -that you specify for it. - -@item (list @var{element-types}@dots{}) -The value must be a list with exactly as many elements as the -@var{element-types} given; and each element must fit the -corresponding @var{element-type}. - -For example, @code{(list integer string function)} describes a list of -three elements; the first element must be an integer, the second a -string, and the third a function. - -In the customization buffer, each element is displayed and edited -separately, according to the type specified for it. - -@item (group @var{element-types}@dots{}) -This works like @code{list} except for the formatting -of text in the Custom buffer. @code{list} labels each -element value with its tag; @code{group} does not. - -@item (vector @var{element-types}@dots{}) -Like @code{list} except that the value must be a vector instead of a -list. The elements work the same as in @code{list}. +@item (plist :key-type @var{key-type} :value-type @var{value-type}) +This customization type is similar to @code{alist} (see above), except +that (i) the information is stored as a property list, +(@pxref{Property Lists}), and (ii) @var{key-type}, if omitted, +defaults to @code{symbol} rather than @code{sexp}. @item (choice @var{alternative-types}@dots{}) The value must fit at least one of @var{alternative-types}. === modified file 'doc/lispref/display.texi' --- doc/lispref/display.texi 2011-07-02 21:38:19 +0000 +++ doc/lispref/display.texi 2011-07-06 02:42:10 +0000 @@ -2092,7 +2092,10 @@ @item @code{(:line-width @var{width} :color @var{color} :style @var{style})} This way you can explicitly specify all aspects of the box. The value -@var{width} specifies the width of the lines to draw; it defaults to 1. +@var{width} specifies the width of the lines to draw; it defaults to +1. A negative width @var{-n} means to draw a line of width @var{n} +that occupies the space of the underlying text, thus avoiding any +increase in the character height or width. The value @var{color} specifies the color to draw with. The default is the foreground color of the face for simple boxes, and the background === modified file 'doc/lispref/elisp.texi' --- doc/lispref/elisp.texi 2011-05-29 22:41:06 +0000 +++ doc/lispref/elisp.texi 2011-07-06 02:42:10 +0000 @@ -508,8 +508,7 @@ Customization Types -* Simple Types:: Simple customization types: sexp, integer, number, - string, file, directory, alist. +* Simple Types:: Simple customization types: sexp, integer, etc. * Composite Types:: Build new types from other types or data. * Splicing into Lists:: Splice elements into list with @code{:inline}. * Type Keywords:: Keyword-argument pairs in a customization type. === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 20:44:55 +0000 +++ lisp/ChangeLog 2011-07-06 02:42:10 +0000 @@ -1,3 +1,13 @@ +2011-07-06 Markus Heiser (tiny change) + + * progmodes/gud.el (gud-pdb-marker-regexp): Accept \r char (Bug#5653). + +2011-07-06 Chong Yidong + + * window.el (special-display-popup-frame): Doc fix (Bug#8853). + + * info.el (Info-directory-toc-nodes): Minor doc fix (Bug#8833). + 2011-07-05 Chong Yidong * button.el (button): Inherit from link face. Suggested by Dan === modified file 'lisp/info.el' --- lisp/info.el 2011-07-03 22:43:50 +0000 +++ lisp/info.el 2011-07-06 02:42:10 +0000 @@ -2092,7 +2092,7 @@ )) (defun Info-directory-toc-nodes (filename) - "Directory-specific implementation of `Info-directory-toc-nodes'." + "Directory-specific implementation of `Info-toc-nodes'." `(,filename ("Top" nil nil nil))) === modified file 'lisp/progmodes/gud.el' --- lisp/progmodes/gud.el 2011-05-23 17:57:17 +0000 +++ lisp/progmodes/gud.el 2011-07-06 02:42:10 +0000 @@ -1581,7 +1581,8 @@ ;; Last group is for return value, e.g. "> test.py(2)foo()->None" ;; Either file or function name may be omitted: "> (0)?()" (defvar gud-pdb-marker-regexp - "^> \\([-a-zA-Z0-9_/.:\\]*\\|\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|\\)()\\(->[^\n]*\\)?\n") + "^> \\([-a-zA-Z0-9_/.:\\]*\\|\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|\\)()\\(->[^\n\r]*\\)?[\n\r]") + (defvar gud-pdb-marker-regexp-file-group 1) (defvar gud-pdb-marker-regexp-line-group 2) (defvar gud-pdb-marker-regexp-fnname-group 3) === modified file 'lisp/window.el' --- lisp/window.el 2011-07-05 09:51:56 +0000 +++ lisp/window.el 2011-07-06 02:42:10 +0000 @@ -6108,7 +6108,7 @@ If ARGS is a list whose car is a symbol, use (car ARGS) as a function to do the work. Pass it BUFFER as first argument, -and (cdr ARGS) as second." +and (cdr ARGS) as the rest of the arguments." (if (and args (symbolp (car args))) (apply (car args) buffer (cdr args)) (let ((window (get-buffer-window buffer 0))) ------------------------------------------------------------ revno: 104978 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Tue 2011-07-05 23:06:11 +0000 message: gnus.el (gnus-summary-line-format): Link to "Marking Articles" instead of "Read Articles". diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-07-05 22:27:16 +0000 +++ lisp/gnus/ChangeLog 2011-07-05 23:06:11 +0000 @@ -2,6 +2,8 @@ * gnus.el (gnus-refer-article-method): Remove mention of nnspool, which no longer is much used. + (gnus-summary-line-format): Link to "Marking Articles" instead of "Read + Articles". 2011-04-03 Kan-Ru Chen === modified file 'lisp/gnus/gnus.el' --- lisp/gnus/gnus.el 2011-07-05 21:03:54 +0000 +++ lisp/gnus/gnus.el 2011-07-05 23:06:11 +0000 @@ -2963,7 +2963,7 @@ %R \"A\" if this article has been replied to, \" \" otherwise (character) %U \"Read\" status of this article. - See Info node `(gnus)Read Articles' + See Info node `(gnus)Marking Articles' %[ Opening bracket (character, \"[\" or \"<\") %] Closing bracket (character, \"]\" or \">\") %> Spaces of length thread-level (string) ------------------------------------------------------------ revno: 104977 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Tue 2011-07-05 22:49:25 +0000 message: gnus.texi (Filtering New Groups): Clarify how simple the "options -n" format is. (Agent Expiry): Remove mention of `gnus-request-expire-articles', which is internal. diff: === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2011-07-05 22:27:16 +0000 +++ doc/misc/ChangeLog 2011-07-05 22:49:25 +0000 @@ -1,6 +1,9 @@ 2011-07-05 Lars Magne Ingebrigtsen * gnus.texi (Expiring Mail): Document gnus-auto-expirable-marks. + (Filtering New Groups): Clarify how simple the "options -n" format is. + (Agent Expiry): Remove mention of `gnus-request-expire-articles', which + is internal. 2011-07-04 Michael Albinus === modified file 'doc/misc/gnus.texi' --- doc/misc/gnus.texi 2011-07-05 22:27:16 +0000 +++ doc/misc/gnus.texi 2011-07-05 22:49:25 +0000 @@ -1302,6 +1302,10 @@ @code{gnus-subscribe-options-newsgroup-method} is used instead. This variable defaults to @code{gnus-subscribe-alphabetically}. +The ``options -n'' format is very simplistic. The syntax above is all +that is supports -- you can force-subscribe hierarchies, or you can +deny hierarchies, and that's it. + @vindex gnus-options-not-subscribe @vindex gnus-options-subscribe If you don't want to mess with your @file{.newsrc} file, you can just @@ -19006,9 +19010,8 @@ efficient, and it's not a particularly good idea to interrupt them (with @kbd{C-g} or anything else) once you've started one of them. -Note that other functions, e.g. @code{gnus-request-expire-articles}, -might run @code{gnus-agent-expire} for you to keep the agent -synchronized with the group. +Note that other functions might run @code{gnus-agent-expire} for you +to keep the agent synchronized with the group. The agent parameter @code{agent-enable-expiration} may be used to prevent expiration in selected groups. ------------------------------------------------------------ revno: 104976 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Tue 2011-07-05 22:27:16 +0000 message: Merge changes made in Gnus trunk. gnus.texi (Expiring Mail): Document gnus-auto-expirable-marks. nnir.el (nnir-notmuch-program, nnir-notmuch-additional-switches, nnir-notmuch-remove-prefix, nnir-engines, nnir-run-notmuch): New nnir `notmuch' backend. mm-decode.el (mm-text-html-renderer): Doc fix. gnus-msg.el (gnus-bug): Fix the MML tag. pop3.el (pop3-open-server): -ERR is a valid response to CAPA. gnus-start.el (gnus-get-unread-articles): Don't connect to the secondary methods if started with `gnus-no-server'. gnus-group.el (gnus-read-ephemeral-bug-group): Allow fetching several bug reports at once. diff: === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2011-07-04 12:31:55 +0000 +++ doc/misc/ChangeLog 2011-07-05 22:27:16 +0000 @@ -1,3 +1,7 @@ +2011-07-05 Lars Magne Ingebrigtsen + + * gnus.texi (Expiring Mail): Document gnus-auto-expirable-marks. + 2011-07-04 Michael Albinus * tramp.texi (Cleanup remote connections): Add === modified file 'doc/misc/gnus.texi' --- doc/misc/gnus.texi 2011-07-04 00:33:48 +0000 +++ doc/misc/gnus.texi 2011-07-05 22:27:16 +0000 @@ -15648,14 +15648,16 @@ repeating one more time, with some spurious capitalizations: IF you do NOT mark articles as EXPIRABLE, Gnus will NEVER delete those ARTICLES. +@vindex gnus-auto-expirable-marks You do not have to mark articles as expirable by hand. Gnus provides two features, called ``auto-expire'' and ``total-expire'', that can help you with this. In a nutshell, ``auto-expire'' means that Gnus hits @kbd{E} for you when you select an article. And ``total-expire'' means that Gnus considers all articles as expirable that are read. So, in addition to the articles marked @samp{E}, also the articles marked @samp{r}, -@samp{R}, @samp{O}, @samp{K}, @samp{Y} and so on are considered -expirable. +@samp{R}, @samp{O}, @samp{K}, @samp{Y} (and so on) are considered +expirable. @code{gnus-auto-expirable-marks} has the full list of +these marks. When should either auto-expire or total-expire be used? Most people who are subscribed to mailing lists split each list into its own group === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-07-05 21:03:54 +0000 +++ lisp/gnus/ChangeLog 2011-07-05 22:27:16 +0000 @@ -3,6 +3,25 @@ * gnus.el (gnus-refer-article-method): Remove mention of nnspool, which no longer is much used. +2011-04-03 Kan-Ru Chen + + * nnir.el (nnir-notmuch-program, nnir-notmuch-additional-switches) + (nnir-notmuch-remove-prefix, nnir-engines, nnir-run-notmuch): New nnir + `notmuch' backend. + +2011-07-05 Lars Magne Ingebrigtsen + + * mm-decode.el (mm-text-html-renderer): Doc fix. + + * gnus-msg.el (gnus-bug): Fix the MML tag. + + * pop3.el (pop3-open-server): -ERR is a valid response to CAPA. + +2011-07-05 Daiki Ueno + + * gnus-start.el (gnus-get-unread-articles): Don't connect to the + secondary methods if started with `gnus-no-server'. + 2011-07-05 Juanma Barranquero * message.el (message-return-action): Fix typo in docstring. === modified file 'lisp/gnus/gnus-group.el' --- lisp/gnus/gnus-group.el 2011-07-03 22:17:49 +0000 +++ lisp/gnus/gnus-group.el 2011-07-05 22:27:16 +0000 @@ -2428,25 +2428,28 @@ :version "24.1" :type '(repeat (cons (symbol) (string :tag "URL format string")))) -(defun gnus-read-ephemeral-bug-group (number mbox-url &optional window-conf) +(defun gnus-read-ephemeral-bug-group (ids mbox-url &optional window-conf) "Browse bug NUMBER as ephemeral group." (interactive (list (read-string "Enter bug number: " (thing-at-point 'word) nil) ;; FIXME: Add completing-read from ;; `gnus-emacs-bug-group-download-format' ... (cdr (assoc 'emacs gnus-bug-group-download-format-alist)))) - (when (stringp number) - (setq number (string-to-number number))) + (when (stringp ids) + (setq ids (string-to-number ids))) + (unless (listp ids) + (setq ids (list ids))) (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")) (coding-system-for-write 'binary) (coding-system-for-read 'binary)) (with-temp-file tmpfile - (url-insert-file-contents (format mbox-url number)) + (dolist (id ids) + (url-insert-file-contents (format mbox-url id))) (goto-char (point-min)) ;; Add the debbugs address so that we can respond to reports easily. (while (re-search-forward "^To: " nil t) (end-of-line) - (insert (format ", %s@%s" number + (insert (format ", %s@%s" (car ids) (gnus-replace-in-string (gnus-replace-in-string mbox-url "^http://" "") "/.*$" "")))) @@ -2466,19 +2469,21 @@ number (cdr (assoc 'debian gnus-bug-group-download-format-alist)))) -(defun gnus-read-ephemeral-emacs-bug-group (number &optional window-conf) - "Browse Emacs bug NUMBER as ephemeral group." +(defun gnus-read-ephemeral-emacs-bug-group (ids &optional window-conf) + "Browse Emacs bugs IDS as an ephemeral group." (interactive (list (string-to-number (read-string "Enter bug number: " (thing-at-point 'word) nil)))) + (unless (listp ids) + (setq ids (list ids))) (gnus-read-ephemeral-bug-group - number + ids (cdr (assoc 'emacs gnus-bug-group-download-format-alist)) window-conf) (when (boundp 'debbugs-summary-mode) (with-current-buffer (window-buffer (selected-window)) (debbugs-summary-mode 1) - (set (make-local-variable 'debbugs-bug-number) number)))) + (set (make-local-variable 'debbugs-bug-number) (car ids))))) (defun gnus-group-jump-to-group (group &optional prompt) "Jump to newsgroup GROUP. === modified file 'lisp/gnus/gnus-msg.el' --- lisp/gnus/gnus-msg.el 2011-07-03 00:24:28 +0000 +++ lisp/gnus/gnus-msg.el 2011-07-05 22:27:16 +0000 @@ -1480,10 +1480,10 @@ (erase-buffer) (gnus-debug) (setq text (buffer-string))) - (insert (concat "<#part type=application/emacs-lisp" - "disposition=inline description=\"User settings\">\n" - text - "\n<#/part>"))) + (insert "<#part type=application/emacs-lisp " + "disposition=inline description=\"User settings\">\n" + text + "\n<#/part>")) (goto-char (point-min)) (search-forward "Subject: " nil t) (message ""))) === modified file 'lisp/gnus/gnus-start.el' --- lisp/gnus/gnus-start.el 2011-06-10 00:10:24 +0000 +++ lisp/gnus/gnus-start.el 2011-07-05 22:27:16 +0000 @@ -1043,7 +1043,7 @@ ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) - (gnus-get-unread-articles level)))) + (gnus-get-unread-articles level dont-connect)))) (defun gnus-call-subscribe-functions (method group) "Call METHOD to subscribe GROUP. @@ -1606,7 +1606,7 @@ ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' ;; and compute how many unread articles there are in each group. -(defun gnus-get-unread-articles (&optional level) +(defun gnus-get-unread-articles (&optional level dont-connect) (setq gnus-server-method-cache nil) (require 'gnus-agent) (let* ((newsrc (cdr gnus-newsrc-alist)) @@ -1702,12 +1702,13 @@ ;; If we have primary/secondary select methods, but no groups from ;; them, we still want to issue a retrieval request from them. - (dolist (method (cons gnus-select-method - gnus-secondary-select-methods)) - (when (and (not (assoc method type-cache)) - (gnus-check-backend-function 'request-list (car method))) - (with-current-buffer nntp-server-buffer - (gnus-read-active-file-1 method nil)))) + (unless dont-connect + (dolist (method (cons gnus-select-method + gnus-secondary-select-methods)) + (when (and (not (assoc method type-cache)) + (gnus-check-backend-function 'request-list (car method))) + (with-current-buffer nntp-server-buffer + (gnus-read-active-file-1 method nil))))) ;; Start early async retrieval of data. (let ((done-methods nil) === modified file 'lisp/gnus/mm-decode.el' --- lisp/gnus/mm-decode.el 2011-03-25 23:27:18 +0000 +++ lisp/gnus/mm-decode.el 2011-07-05 22:27:16 +0000 @@ -114,14 +114,14 @@ "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: -`shr': use Gnus simple HTML renderer; -`gnus-w3m' : use Gnus renderer based on w3m; -`w3m' : use emacs-w3m; -`w3m-standalone': use w3m; +`shr': use the built-in Gnus HTML renderer; +`gnus-w3m': use Gnus renderer based on w3m; +`w3m': use emacs-w3m; +`w3m-standalone': use plain w3m; `links': use links; -`lynx' : use lynx; -`w3' : use Emacs/W3; -`html2text' : use html2text; +`lynx': use lynx; +`w3': use Emacs/W3; +`html2text': use html2text; nil : use external viewer (default web browser)." :version "24.1" :type '(choice (const shr) === modified file 'lisp/gnus/nnir.el' --- lisp/gnus/nnir.el 2011-07-02 13:26:49 +0000 +++ lisp/gnus/nnir.el 2011-07-05 22:27:16 +0000 @@ -499,6 +499,31 @@ :type '(directory) :group 'nnir) +(defcustom nnir-notmuch-program "notmuch" + "*Name of notmuch search executable." + :type '(string) + :group 'nnir) + +(defcustom nnir-notmuch-additional-switches '() + "*A list of strings, to be given as additional arguments to notmuch. + +Note that this should be a list. Ie, do NOT use the following: + (setq nnir-notmuch-additional-switches \"-i -w\") ; wrong +Instead, use this: + (setq nnir-notmuch-additional-switches '(\"-i\" \"-w\"))" + :type '(repeat (string)) + :group 'nnir) + +(defcustom nnir-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") + "*The prefix to remove from each file name returned by notmuch +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable is very similar to `nnir-namazu-remove-prefix', except +that it is for notmuch, not Namazu." + :type '(regexp) + :group 'nnir) + ;;; Developer Extension Variable: (defvar nnir-engines @@ -519,6 +544,8 @@ ((group . "Swish-e Group spec: "))) (namazu nnir-run-namazu ()) + (notmuch nnir-run-notmuch + ()) (hyrex nnir-run-hyrex ((group . "Hyrex Group spec: "))) (find-grep nnir-run-find-grep @@ -1338,6 +1365,80 @@ (> (nnir-artitem-rsv x) (nnir-artitem-rsv y))))))))) +(defun nnir-run-notmuch (query server &optional group) + "Run QUERY against notmuch. +Returns a vector of (group name, file name) pairs (also vectors, +actually)." + + ;; (when group + ;; (error "The notmuch backend cannot search specific groups")) + + (save-excursion + (let ( (qstring (cdr (assq 'query query))) + (groupspec (cdr (assq 'group query))) + (prefix (nnir-read-server-parm 'nnir-notmuch-remove-prefix server)) + artlist + (article-pattern (if (string= (gnus-group-server server) "nnmaildir") + ":[0-9]+" + "^[0-9]+$")) + artno dirnam filenam) + + (when (equal "" qstring) + (error "notmuch: You didn't enter anything")) + + (set-buffer (get-buffer-create nnir-tmp-buffer)) + (erase-buffer) + + (if groupspec + (message "Doing notmuch query %s on %s..." qstring groupspec) + (message "Doing notmuch query %s..." qstring)) + + (let* ((cp-list `( ,nnir-notmuch-program + nil ; input from /dev/null + t ; output + nil ; don't redisplay + "search" + "--format=text" + "--output=files" + ,@(nnir-read-server-parm 'nnir-notmuch-additional-switches server) + ,qstring ; the query, in notmuch format + )) + (exitstatus + (progn + (message "%s args: %s" nnir-notmuch-program + (mapconcat 'identity (cddddr cp-list) " ")) ;; ??? + (apply 'call-process cp-list)))) + (unless (or (null exitstatus) + (zerop exitstatus)) + (nnheader-report 'nnir "Couldn't run notmuch: %s" exitstatus) + ;; notmuch failure reason is in this buffer, show it if + ;; the user wants it. + (when (> gnus-verbose 6) + (display-buffer nnir-tmp-buffer)))) + + ;; The results are output in the format of: + ;; absolute-path-name + (goto-char (point-min)) + (while (not (eobp)) + (setq filenam (buffer-substring-no-properties (line-beginning-position) + (line-end-position)) + artno (file-name-nondirectory filenam) + dirnam (file-name-directory filenam)) + (forward-line 1) + + ;; don't match directories + (when (string-match article-pattern artno) + (when (not (null dirnam)) + + ;; maybe limit results to matching groups. + (when (or (not groupspec) + (string-match groupspec dirnam)) + (nnir-add-result dirnam artno "" prefix server artlist))))) + + (message "Massaging notmuch output...done") + + artlist))) + (defun nnir-run-find-grep (query server &optional grouplist) "Run find and grep to obtain matching articles." (let* ((method (gnus-server-to-method server)) === modified file 'lisp/gnus/pop3.el' --- lisp/gnus/pop3.el 2011-07-03 22:17:49 +0000 +++ lisp/gnus/pop3.el 2011-07-05 22:27:16 +0000 @@ -307,7 +307,7 @@ (or pop3-stream-type 'network))) :capability-command "CAPA\r\n" :end-of-command "^\\(-ERR\\|+OK \\).*\n" - :end-of-capability "^\\.\r?\n" + :end-of-capability "^\\.\r?\n\\|^-ERR" :success "^\\+OK.*\n" :return-list t :starttls-function ------------------------------------------------------------ revno: 104975 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Tue 2011-07-05 23:03:54 +0200 message: * gnus.el (gnus-refer-article-method): Remove mention of nnspool, which no longer is much used. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2011-07-05 09:51:56 +0000 +++ lisp/gnus/ChangeLog 2011-07-05 21:03:54 +0000 @@ -1,3 +1,8 @@ +2011-07-05 Lars Magne Ingebrigtsen + + * gnus.el (gnus-refer-article-method): Remove mention of nnspool, which + no longer is much used. + 2011-07-05 Juanma Barranquero * message.el (message-return-action): Fix typo in docstring. === modified file 'lisp/gnus/gnus.el' --- lisp/gnus/gnus.el 2011-07-03 22:17:49 +0000 +++ lisp/gnus/gnus.el 2011-07-05 21:03:54 +0000 @@ -1423,10 +1423,6 @@ (defcustom gnus-refer-article-method 'current "Preferred method for fetching an article by Message-ID. -If you are reading news from the local spool (with nnspool), fetching -articles by Message-ID is painfully slow. By setting this method to an -nntp method, you might get acceptable results. - The value of this variable must be a valid select method as discussed in the documentation of `gnus-select-method'. ------------------------------------------------------------ revno: 104974 committer: Chong Yidong branch nick: trunk timestamp: Tue 2011-07-05 16:44:55 -0400 message: * lisp/button.el (button): Inherit from link face. Suggested by Dan Nicolaescu. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 18:58:33 +0000 +++ lisp/ChangeLog 2011-07-05 20:44:55 +0000 @@ -1,3 +1,8 @@ +2011-07-05 Chong Yidong + + * button.el (button): Inherit from link face. Suggested by Dan + Nicolaescu. + 2011-07-05 Stefan Monnier * progmodes/gdb-mi.el: Fit in 80 columns. === modified file 'lisp/button.el' --- lisp/button.el 2011-01-25 04:08:28 +0000 +++ lisp/button.el 2011-07-05 20:44:55 +0000 @@ -54,10 +54,7 @@ ;; Use color for the MS-DOS port because it doesn't support underline. ;; FIXME if MS-DOS correctly answers the (supports) question, it need ;; no longer be a special case. -(defface button '((((type pc) (class color)) - (:foreground "lightblue")) - (((supports :underline t)) :underline t) - (t (:foreground "lightblue"))) +(defface button '((t :inherit link)) "Default face used for buttons." :group 'basic-faces) ------------------------------------------------------------ revno: 104973 committer: Stefan Monnier branch nick: trunk timestamp: Tue 2011-07-05 14:58:33 -0400 message: * lisp/progmodes/gdb-mi.el: Fit in 80 columns. (gdb-setup-windows, gdb-restore-windows): Avoid other-window and switch-to-buffer. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 18:56:31 +0000 +++ lisp/ChangeLog 2011-07-05 18:58:33 +0000 @@ -1,5 +1,9 @@ 2011-07-05 Stefan Monnier + * progmodes/gdb-mi.el: Fit in 80 columns. + (gdb-setup-windows, gdb-restore-windows): Avoid other-window and + switch-to-buffer. + * progmodes/which-func.el (which-func-ff-hook): Don't output a message if imenu is simply not configured (bug#8941). @@ -16,7 +20,6 @@ (allout-widgets-mode): Include allout-widgets-after-undo-function on the new allout-post-undo-hook. - 2011-07-05 Stefan Monnier * emacs-lisp/lisp-mode.el (lisp-interaction-mode-abbrev-table): === modified file 'lisp/progmodes/gdb-mi.el' --- lisp/progmodes/gdb-mi.el 2011-07-04 17:50:55 +0000 +++ lisp/progmodes/gdb-mi.el 2011-07-05 18:58:33 +0000 @@ -104,7 +104,8 @@ (require 'bindat) (eval-when-compile (require 'cl)) -(declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) +(declare-function speedbar-change-initial-expansion-list + "speedbar" (new-default)) (declare-function speedbar-timer-fn "speedbar" ()) (declare-function speedbar-line-text "speedbar" (&optional p)) (declare-function speedbar-change-expand-button-char "speedbar" (char)) @@ -190,7 +191,8 @@ (defvar gdb-current-language nil) (defvar gdb-var-list nil "List of variables in watch window. -Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) +Each element has the form + (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame address for root variables.") (defvar gdb-main-file nil "Source file from which program execution begins.") @@ -329,7 +331,7 @@ "Maximum size of `gdb-debug-log'. If nil, size is unlimited." :group 'gdb :type '(choice (integer :tag "Number of elements") - (const :tag "Unlimited" nil)) + (const :tag "Unlimited" nil)) :version "22.1") (defcustom gdb-non-stop-setting t @@ -367,13 +369,18 @@ (set :tag "Selection of reasons..." (const :tag "A breakpoint was reached." "breakpoint-hit") (const :tag "A watchpoint was triggered." "watchpoint-trigger") - (const :tag "A read watchpoint was triggered." "read-watchpoint-trigger") - (const :tag "An access watchpoint was triggered." "access-watchpoint-trigger") + (const :tag "A read watchpoint was triggered." + "read-watchpoint-trigger") + (const :tag "An access watchpoint was triggered." + "access-watchpoint-trigger") (const :tag "Function finished execution." "function-finished") (const :tag "Location reached." "location-reached") - (const :tag "Watchpoint has gone out of scope" "watchpoint-scope") - (const :tag "End of stepping range reached." "end-stepping-range") - (const :tag "Signal received (like interruption)." "signal-received")) + (const :tag "Watchpoint has gone out of scope" + "watchpoint-scope") + (const :tag "End of stepping range reached." + "end-stepping-range") + (const :tag "Signal received (like interruption)." + "signal-received")) (const :tag "None" nil)) :group 'gdb-non-stop :version "23.2" @@ -488,17 +495,17 @@ :group 'gdb :version "22.1") - (defcustom gdb-create-source-file-list t - "Non-nil means create a list of files from which the executable was built. +(defcustom gdb-create-source-file-list t + "Non-nil means create a list of files from which the executable was built. Set this to nil if the GUD buffer displays \"initializing...\" in the mode line for a long time when starting, possibly because your executable was built from a large number of files. This allows quicker initialization but means that these files are not automatically enabled for debugging, e.g., you won't be able to click in the fringe to set a breakpoint until execution has already stopped there." - :type 'boolean - :group 'gdb - :version "23.1") + :type 'boolean + :group 'gdb + :version "23.1") (defcustom gdb-show-main nil "Non-nil means display source file containing the main routine at startup. @@ -644,12 +651,12 @@ (interactive (list (gud-query-cmdline 'gdb))) (when (and gud-comint-buffer - (buffer-name gud-comint-buffer) - (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) - (gdb-restore-windows) - (error - "Multiple debugging requires restarting in text command mode")) + (buffer-name gud-comint-buffer) + (get-buffer-process gud-comint-buffer) + (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) + (gdb-restore-windows) + (error + "Multiple debugging requires restarting in text command mode")) ;; (gud-common-init command-line nil 'gud-gdbmi-marker-filter) (set (make-local-variable 'gud-minor-mode) 'gdbmi) @@ -663,7 +670,7 @@ (hsize (getenv "HISTSIZE"))) (dolist (file (append '("~/.gdbinit") (unless (string-equal (expand-file-name ".") - (expand-file-name "~")) + (expand-file-name "~")) '(".gdbinit")))) (if (file-readable-p (setq file (expand-file-name file))) (with-temp-buffer @@ -763,7 +770,7 @@ 'gdb-mouse-set-clear-breakpoint) (define-key gud-minor-mode-map [left-fringe mouse-1] 'gdb-mouse-set-clear-breakpoint) - (define-key gud-minor-mode-map [left-margin C-mouse-1] + (define-key gud-minor-mode-map [left-margin C-mouse-1] 'gdb-mouse-toggle-breakpoint-margin) (define-key gud-minor-mode-map [left-fringe C-mouse-1] 'gdb-mouse-toggle-breakpoint-fringe) @@ -849,11 +856,11 @@ ;; find source file and compilation directory here (gdb-input - ; Needs GDB 6.2 onwards. + ; Needs GDB 6.2 onwards. (list "-file-list-exec-source-files" 'gdb-get-source-file-list)) (if gdb-create-source-file-list (gdb-input - ; Needs GDB 6.0 onwards. + ; Needs GDB 6.0 onwards. (list "-file-list-exec-source-file" 'gdb-get-source-file))) (gdb-input (list "-gdb-show prompt" 'gdb-get-prompt))) @@ -862,7 +869,8 @@ (goto-char (point-min)) (if (re-search-forward "No symbol" nil t) (progn - (message "This version of GDB doesn't support non-stop mode. Turning it off.") + (message + "This version of GDB doesn't support non-stop mode. Turning it off.") (setq gdb-non-stop nil) (setq gdb-version "pre-7.0")) (setq gdb-version "7.0+") @@ -885,8 +893,8 @@ (list t nil) nil "-c" (concat gdb-cpp-define-alist-program " " gdb-cpp-define-alist-flags)))))) - (define-list (split-string output "\n" t)) - (name)) + (define-list (split-string output "\n" t)) + (name)) (setq gdb-define-alist nil) (dolist (define define-list) (setq name (nth 1 (split-string define "[( ]"))) @@ -896,13 +904,13 @@ (defvar tooltip-use-echo-area) (defun gdb-tooltip-print (expr) - (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) - (goto-char (point-min)) - (if (re-search-forward ".*value=\\(\".*\"\\)" nil t) - (tooltip-show - (concat expr " = " (read (match-string 1))) - (or gud-tooltip-echo-area tooltip-use-echo-area - (not (display-graphic-p))))))) + (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) + (goto-char (point-min)) + (if (re-search-forward ".*value=\\(\".*\"\\)" nil t) + (tooltip-show + (concat expr " = " (read (match-string 1))) + (or gud-tooltip-echo-area tooltip-use-echo-area + (not (display-graphic-p))))))) ;; If expr is a macro for a function don't print because of possible dangerous ;; side-effects. Also printing a function within a tooltip generates an @@ -926,13 +934,13 @@ (defmacro gdb-if-arrow (arrow-position &rest body) `(if ,arrow-position - (let ((buffer (marker-buffer ,arrow-position)) (line)) - (if (equal buffer (window-buffer (posn-window end))) - (with-current-buffer buffer - (when (or (equal start end) - (equal (posn-point start) - (marker-position ,arrow-position))) - ,@body)))))) + (let ((buffer (marker-buffer ,arrow-position)) (line)) + (if (equal buffer (window-buffer (posn-window end))) + (with-current-buffer buffer + (when (or (equal start end) + (equal (posn-point start) + (marker-position ,arrow-position))) + ,@body)))))) (defun gdb-mouse-until (event) "Continue running until a source line past the current line. @@ -1063,7 +1071,7 @@ (bindat-get-field result 'value) nil (bindat-get-field result 'has_more) - gdb-frame-address))) + gdb-frame-address))) (push var gdb-var-list) (speedbar 1) (unless (string-equal @@ -1094,20 +1102,20 @@ (setcar (nthcdr 4 var) (read (match-string 1))))) (gdb-speedbar-update)) -; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards. + ; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards. (defun gdb-var-list-children (varnum) (gdb-input (list (concat "-var-update " varnum) 'ignore)) (gdb-input (list (concat "-var-list-children --all-values " - varnum) - `(lambda () (gdb-var-list-children-handler ,varnum))))) + varnum) + `(lambda () (gdb-var-list-children-handler ,varnum))))) (defun gdb-var-list-children-handler (varnum) (let* ((var-list nil) (output (bindat-get-field (gdb-json-partial-output "child"))) (children (bindat-get-field output 'children))) - (catch 'child-already-watched + (catch 'child-already-watched (dolist (var gdb-var-list) (if (string-equal varnum (car var)) (progn @@ -1150,11 +1158,11 @@ (interactive) (let ((text (speedbar-line-text))) (string-match "\\(\\S-+\\)" text) - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var))) - (if (string-match "\\." (car var)) - (message-box "Can only delete a root expression") - (gdb-var-delete-1 var varnum))))) + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var))) + (if (string-match "\\." (car var)) + (message-box "Can only delete a root expression") + (gdb-var-delete-1 var varnum))))) (defun gdb-var-delete-children (varnum) "Delete children of variable object at point from the speedbar." @@ -1177,7 +1185,7 @@ (if (re-search-forward gdb-error-regexp nil t) (message-box "Invalid number or expression (%s)" value))) -; Uses "-var-update --all-values". Needs GDB 6.4 onwards. + ; Uses "-var-update --all-values". Needs GDB 6.4 onwards. (defun gdb-var-update () (if (not (gdb-pending-p 'gdb-var-update)) (gdb-input @@ -1213,38 +1221,38 @@ (gdb-var-delete-1 var varnum))))) (let ((var-list nil) var1 (children (bindat-get-field change 'new_children))) - (if new-num - (progn - (setq var1 (pop temp-var-list)) - (while var1 - (if (string-equal varnum (car var1)) - (let ((new (string-to-number new-num)) - (previous (string-to-number (nth 2 var1)))) - (setcar (nthcdr 2 var1) new-num) - (push var1 var-list) - (cond ((> new previous) - ;; Add new children to list. - (dotimes (dummy previous) - (push (pop temp-var-list) var-list)) - (dolist (child children) - (let ((varchild - (list (bindat-get-field child 'name) - (bindat-get-field child 'exp) - (bindat-get-field child 'numchild) - (bindat-get-field child 'type) - (bindat-get-field child 'value) - 'changed - (bindat-get-field child 'has_more)))) - (push varchild var-list)))) - ;; Remove deleted children from list. - ((< new previous) - (dotimes (dummy new) - (push (pop temp-var-list) var-list)) - (dotimes (dummy (- previous new)) - (pop temp-var-list))))) - (push var1 var-list)) - (setq var1 (pop temp-var-list))) - (setq gdb-var-list (nreverse var-list))))))))) + (when new-num + (setq var1 (pop temp-var-list)) + (while var1 + (if (string-equal varnum (car var1)) + (let ((new (string-to-number new-num)) + (previous (string-to-number (nth 2 var1)))) + (setcar (nthcdr 2 var1) new-num) + (push var1 var-list) + (cond + ((> new previous) + ;; Add new children to list. + (dotimes (dummy previous) + (push (pop temp-var-list) var-list)) + (dolist (child children) + (let ((varchild + (list (bindat-get-field child 'name) + (bindat-get-field child 'exp) + (bindat-get-field child 'numchild) + (bindat-get-field child 'type) + (bindat-get-field child 'value) + 'changed + (bindat-get-field child 'has_more)))) + (push varchild var-list)))) + ;; Remove deleted children from list. + ((< new previous) + (dotimes (dummy new) + (push (pop temp-var-list) var-list)) + (dotimes (dummy (- previous new)) + (pop temp-var-list))))) + (push var1 var-list)) + (setq var1 (pop temp-var-list))) + (setq gdb-var-list (nreverse var-list)))))))) (setq gdb-pending-triggers (delq 'gdb-var-update gdb-pending-triggers)) (gdb-speedbar-update)) @@ -1372,7 +1380,8 @@ (when trigger (gdb-add-subscriber gdb-buf-publisher (cons (current-buffer) - (gdb-bind-function-to-buffer trigger (current-buffer)))) + (gdb-bind-function-to-buffer + trigger (current-buffer)))) (funcall trigger 'start)) (current-buffer)))))) @@ -1786,8 +1795,8 @@ ;; visited breakpoint is, use that window. (defun gdb-display-source-buffer (buffer) (let* ((last-window (if gud-last-last-frame - (get-buffer-window - (gud-find-file (car gud-last-last-frame))))) + (get-buffer-window + (gud-find-file (car gud-last-last-frame))))) (source-window (or last-window (if (and gdb-source-window (window-live-p gdb-source-window)) @@ -1860,7 +1869,7 @@ ;; Suppress "No registers." since GDB 6.8 and earlier duplicates MI ;; error message on internal stream. Don't print to GUD buffer. (unless (and (eq record-type 'gdb-internals) - (string-equal (read arg1) "No registers.\n")) + (string-equal (read arg1) "No registers.\n")) (funcall record-type arg1)))))) (setq gdb-output-sink 'user) @@ -1884,15 +1893,15 @@ (defun gdb-thread-exited (output-field) "Handle =thread-exited async record: unset `gdb-thread-number' if current thread exited and update threads list." - (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id))) - (if (string= gdb-thread-number thread-id) - (gdb-setq-thread-number nil)) - ;; When we continue current thread and it quickly exits, - ;; gdb-pending-triggers left after gdb-running disallow us to - ;; properly call -thread-info without --thread option. Thus we - ;; need to use gdb-wait-for-pending. - (gdb-wait-for-pending - (gdb-emit-signal gdb-buf-publisher 'update-threads)))) + (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id))) + (if (string= gdb-thread-number thread-id) + (gdb-setq-thread-number nil)) + ;; When we continue current thread and it quickly exits, + ;; gdb-pending-triggers left after gdb-running disallow us to + ;; properly call -thread-info without --thread option. Thus we + ;; need to use gdb-wait-for-pending. + (gdb-wait-for-pending + (gdb-emit-signal gdb-buf-publisher 'update-threads)))) (defun gdb-thread-selected (output-field) "Handler for =thread-selected MI output record. @@ -1912,7 +1921,8 @@ (gdb-update)))) (defun gdb-running (output-field) - (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'thread-id))) + (let* ((thread-id + (bindat-get-field (gdb-json-string output-field) 'thread-id))) ;; We reset gdb-frame-number to nil if current thread has gone ;; running. This can't be done in gdb-thread-list-handler-custom ;; because we need correct gdb-frame-number by the time @@ -1987,23 +1997,23 @@ ;; reasons (if (or (eq gdb-switch-reasons t) (member reason gdb-switch-reasons)) - (when (not (string-equal gdb-thread-number thread-id)) - (message (concat "Switched to thread " thread-id)) - (gdb-setq-thread-number thread-id)) + (when (not (string-equal gdb-thread-number thread-id)) + (message (concat "Switched to thread " thread-id)) + (gdb-setq-thread-number thread-id)) (message (format "Thread %s stopped" thread-id))))) - ;; Print "(gdb)" to GUD console - (when gdb-first-done-or-error - (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) + ;; Print "(gdb)" to GUD console + (when gdb-first-done-or-error + (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) - ;; In non-stop, we update information as soon as another thread gets - ;; stopped - (when (or gdb-first-done-or-error - gdb-non-stop) - ;; In all-stop this updates gud-running properly as well. - (gdb-update) - (setq gdb-first-done-or-error nil)) - (run-hook-with-args 'gdb-stopped-hooks result))) + ;; In non-stop, we update information as soon as another thread gets + ;; stopped + (when (or gdb-first-done-or-error + gdb-non-stop) + ;; In all-stop this updates gud-running properly as well. + (gdb-update) + (setq gdb-first-done-or-error nil)) + (run-hook-with-args 'gdb-stopped-hooks result))) ;; Remove the trimmings from log stream containing debugging messages ;; being produced by GDB's internals, use warning face and send to GUD @@ -2023,7 +2033,7 @@ ;; Remove the trimmings from the console stream and send to GUD buffer ;; (frontend MI commands should not print to this stream) (defun gdb-console (output-field) - (setq gdb-filter-output + (setq gdb-filter-output (gdb-concat-output gdb-filter-output (read output-field)))) @@ -2036,11 +2046,11 @@ (setq token-number nil) ;; MI error - send to minibuffer (when (eq type 'error) - ;; Skip "msg=" from `output-field' - (message (read (substring output-field 4))) - ;; Don't send to the console twice. (If it is a console error - ;; it is also in the console stream.) - (setq output-field nil))) + ;; Skip "msg=" from `output-field' + (message (read (substring output-field 4))) + ;; Don't send to the console twice. (If it is a console error + ;; it is also in the console stream.) + (setq output-field nil))) ;; Output from command from frontend. (setq gdb-output-sink 'emacs)) @@ -2218,11 +2228,11 @@ (append row-properties (list properties))) (setf (gdb-table-column-sizes table) (gdb-mapcar* (lambda (x s) - (let ((new-x - (max (abs x) (string-width (or s ""))))) - (if right-align new-x (- new-x)))) - (gdb-table-column-sizes table) - row)) + (let ((new-x + (max (abs x) (string-width (or s ""))))) + (if right-align new-x (- new-x)))) + (gdb-table-column-sizes table) + row)) ;; Avoid trailing whitespace at eol (if (not (gdb-table-right-align table)) (setcar (last (gdb-table-column-sizes table)) 0)))) @@ -2311,8 +2321,8 @@ '(set-window-point window p))))) (defmacro def-gdb-trigger-and-handler (trigger-name gdb-command - handler-name custom-defun - &optional signal-list) + handler-name custom-defun + &optional signal-list) "Define trigger and handler. TRIGGER-NAME trigger is defined to send GDB-COMMAND. See @@ -2356,29 +2366,29 @@ (pending (bindat-get-field breakpoint 'pending)) (func (bindat-get-field breakpoint 'func)) (type (bindat-get-field breakpoint 'type))) - (gdb-table-add-row table - (list - (bindat-get-field breakpoint 'number) - type - (bindat-get-field breakpoint 'disp) - (let ((flag (bindat-get-field breakpoint 'enabled))) - (if (string-equal flag "y") - (propertize "y" 'font-lock-face font-lock-warning-face) - (propertize "n" 'font-lock-face font-lock-comment-face))) - (bindat-get-field breakpoint 'addr) - (bindat-get-field breakpoint 'times) - (if (string-match ".*watchpoint" type) - (bindat-get-field breakpoint 'what) - (or pending at - (concat "in " - (propertize (or func "unknown") - 'font-lock-face font-lock-function-name-face) - (gdb-frame-location breakpoint))))) - ;; Add clickable properties only for breakpoints with file:line - ;; information - (append (list 'gdb-breakpoint breakpoint) - (when func '(help-echo "mouse-2, RET: visit breakpoint" - mouse-face highlight)))))) + (gdb-table-add-row table + (list + (bindat-get-field breakpoint 'number) + type + (bindat-get-field breakpoint 'disp) + (let ((flag (bindat-get-field breakpoint 'enabled))) + (if (string-equal flag "y") + (propertize "y" 'font-lock-face font-lock-warning-face) + (propertize "n" 'font-lock-face font-lock-comment-face))) + (bindat-get-field breakpoint 'addr) + (bindat-get-field breakpoint 'times) + (if (string-match ".*watchpoint" type) + (bindat-get-field breakpoint 'what) + (or pending at + (concat "in " + (propertize (or func "unknown") + 'font-lock-face font-lock-function-name-face) + (gdb-frame-location breakpoint))))) + ;; Add clickable properties only for breakpoints with file:line + ;; information + (append (list 'gdb-breakpoint breakpoint) + (when func '(help-echo "mouse-2, RET: visit breakpoint" + mouse-face highlight)))))) (insert (gdb-table-string table " ")) (gdb-place-breakpoints))) @@ -2392,7 +2402,7 @@ (gdb-remove-breakpoint-icons (point-min) (point-max))))) (dolist (breakpoint gdb-breakpoints-list) (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is - ; an associative list + ; an associative list (line (bindat-get-field breakpoint 'line))) (when line (let ((file (bindat-get-field breakpoint 'fullname)) @@ -2414,7 +2424,7 @@ (gdb-input (list "-file-list-exec-source-file" `(lambda () (gdb-get-location - ,bptno ,line ,flag)))))))))) + ,bptno ,line ,flag)))))))))) (defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"") @@ -2425,7 +2435,7 @@ (catch 'file-not-found (if (re-search-forward gdb-source-file-regexp nil t) (delete (cons bptno "File not found") gdb-location-alist) - (push (cons bptno (match-string 1)) gdb-location-alist) + (push (cons bptno (match-string 1)) gdb-location-alist) (gdb-resync) (unless (assoc bptno gdb-location-alist) (push (cons bptno "File not found") gdb-location-alist) @@ -2513,20 +2523,20 @@ (if (get-text-property 0 'gdb-enabled obj) "-break-disable " "-break-enable ") - (get-text-property 0 'gdb-bptno obj))))))))) + (get-text-property 0 'gdb-bptno obj))))))))) (defun gdb-breakpoints-buffer-name () (concat "*breakpoints of " (gdb-get-target-string) "*")) (def-gdb-display-buffer - gdb-display-breakpoints-buffer - 'gdb-breakpoints-buffer - "Display status of user-settable breakpoints.") + gdb-display-breakpoints-buffer + 'gdb-breakpoints-buffer + "Display status of user-settable breakpoints.") (def-gdb-frame-for-buffer - gdb-frame-breakpoints-buffer - 'gdb-breakpoints-buffer - "Display status of user-settable breakpoints in a new frame.") + gdb-frame-breakpoints-buffer + 'gdb-breakpoints-buffer + "Display status of user-settable breakpoints in a new frame.") (defvar gdb-breakpoints-mode-map (let ((map (make-sparse-keymap)) @@ -2543,9 +2553,9 @@ (define-key map "q" 'gdb-delete-frame-or-window) (define-key map "\r" 'gdb-goto-breakpoint) (define-key map "\t" (lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-threads-buffer) t))) + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-threads-buffer) t))) (define-key map [mouse-2] 'gdb-goto-breakpoint) (define-key map [follow-link] 'mouse-face) map)) @@ -2588,14 +2598,14 @@ (concat "*threads of " (gdb-get-target-string) "*")) (def-gdb-display-buffer - gdb-display-threads-buffer - 'gdb-threads-buffer - "Display GDB threads.") + gdb-display-threads-buffer + 'gdb-threads-buffer + "Display GDB threads.") (def-gdb-frame-for-buffer - gdb-frame-threads-buffer - 'gdb-threads-buffer - "Display GDB threads in a new frame.") + gdb-frame-threads-buffer + 'gdb-threads-buffer + "Display GDB threads in a new frame.") (def-gdb-trigger-and-handler gdb-invalidate-threads (gdb-current-context-command "-thread-info") @@ -2629,18 +2639,20 @@ (define-key map "i" 'gdb-interrupt-thread) (define-key map "c" 'gdb-continue-thread) (define-key map "s" 'gdb-step-thread) - (define-key map "\t" (lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-breakpoints-buffer) t))) + (define-key map "\t" + (lambda () + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-breakpoints-buffer) t))) (define-key map [mouse-2] 'gdb-select-thread) (define-key map [follow-link] 'mouse-face) map)) (defvar gdb-threads-header (list - (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive) + (gdb-propertize-header + "Breakpoints" gdb-breakpoints-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive) " " (gdb-propertize-header "Threads" gdb-threads-buffer nil nil mode-line))) @@ -2664,44 +2676,45 @@ (set-marker gdb-thread-position nil) (dolist (thread (reverse threads-list)) - (let ((running (string-equal (bindat-get-field thread 'state) "running"))) - (add-to-list 'gdb-threads-list - (cons (bindat-get-field thread 'id) - thread)) - (if running - (incf gdb-running-threads-count) - (incf gdb-stopped-threads-count)) + (let ((running (equal (bindat-get-field thread 'state) "running"))) + (add-to-list 'gdb-threads-list + (cons (bindat-get-field thread 'id) + thread)) + (if running + (incf gdb-running-threads-count) + (incf gdb-stopped-threads-count)) - (gdb-table-add-row table - (list - (bindat-get-field thread 'id) - (concat - (if gdb-thread-buffer-verbose-names - (concat (bindat-get-field thread 'target-id) " ") "") - (bindat-get-field thread 'state) - ;; Include frame information for stopped threads - (if (not running) - (concat - " in " (bindat-get-field thread 'frame 'func) - (if gdb-thread-buffer-arguments - (concat - " (" - (let ((args (bindat-get-field thread 'frame 'args))) - (mapconcat - (lambda (arg) - (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value)))) - args ",")) - ")") - "") - (if gdb-thread-buffer-locations - (gdb-frame-location (bindat-get-field thread 'frame)) "") - (if gdb-thread-buffer-addresses - (concat " at " (bindat-get-field thread 'frame 'addr)) "")) - ""))) - (list - 'gdb-thread thread - 'mouse-face 'highlight - 'help-echo "mouse-2, RET: select thread"))) + (gdb-table-add-row table + (list + (bindat-get-field thread 'id) + (concat + (if gdb-thread-buffer-verbose-names + (concat (bindat-get-field thread 'target-id) " ") "") + (bindat-get-field thread 'state) + ;; Include frame information for stopped threads + (if (not running) + (concat + " in " (bindat-get-field thread 'frame 'func) + (if gdb-thread-buffer-arguments + (concat + " (" + (let ((args (bindat-get-field thread 'frame 'args))) + (mapconcat + (lambda (arg) + (apply #'format "%s=%s" + (gdb-get-many-fields arg 'name 'value))) + args ",")) + ")") + "") + (if gdb-thread-buffer-locations + (gdb-frame-location (bindat-get-field thread 'frame)) "") + (if gdb-thread-buffer-addresses + (concat " at " (bindat-get-field thread 'frame 'addr)) "")) + ""))) + (list + 'gdb-thread thread + 'mouse-face 'highlight + 'help-echo "mouse-2, RET: select thread"))) (when (string-equal gdb-thread-number (bindat-get-field thread 'id)) (setq marked-line (length gdb-threads-list)))) @@ -2730,7 +2743,8 @@ ,custom-defun (error "Not recognized as thread line")))))) -(defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc) +(defmacro def-gdb-thread-buffer-simple-command (name buffer-command + &optional doc) "Define a NAME which will call BUFFER-COMMAND with id of thread on the current line." `(def-gdb-thread-buffer-command ,name @@ -2833,19 +2847,19 @@ (defcustom gdb-memory-format "x" "Display format of data items in memory window." :type '(choice (const :tag "Hexadecimal" "x") - (const :tag "Signed decimal" "d") - (const :tag "Unsigned decimal" "u") - (const :tag "Octal" "o") - (const :tag "Binary" "t")) + (const :tag "Signed decimal" "d") + (const :tag "Unsigned decimal" "u") + (const :tag "Octal" "o") + (const :tag "Binary" "t")) :group 'gud :version "22.1") (defcustom gdb-memory-unit 4 "Unit size of data items in memory window." :type '(choice (const :tag "Byte" 1) - (const :tag "Halfword" 2) - (const :tag "Word" 4) - (const :tag "Giant word" 8)) + (const :tag "Halfword" 2) + (const :tag "Word" 4) + (const :tag "Giant word" 8)) :group 'gud :version "23.2") @@ -2896,14 +2910,14 @@ (setq gdb-memory-next-page (bindat-get-field res 'next-page)) (setq gdb-memory-prev-page (bindat-get-field res 'prev-page)) (setq gdb-memory-last-address gdb-memory-address) - (dolist (row memory) - (insert (concat (bindat-get-field row 'addr) ":")) - (dolist (column (bindat-get-field row 'data)) - (insert (gdb-pad-string column - (+ 2 (gdb-memory-column-width - gdb-memory-unit - gdb-memory-format))))) - (newline))) + (dolist (row memory) + (insert (concat (bindat-get-field row 'addr) ":")) + (dolist (column (bindat-get-field row 'data)) + (insert (gdb-pad-string column + (+ 2 (gdb-memory-column-width + gdb-memory-unit + gdb-memory-format))))) + (newline))) ;; Show last page instead of empty buffer when out of bounds (progn (let ((gdb-memory-address gdb-memory-last-address)) @@ -2928,7 +2942,7 @@ (define-key map "g" 'gdb-memory-unit-giant) (define-key map "R" 'gdb-memory-set-rows) (define-key map "C" 'gdb-memory-set-columns) - map)) + map)) (defun gdb-memory-set-address-event (event) "Handle a click on address field in memory buffer header." @@ -3118,8 +3132,8 @@ (defvar gdb-memory-font-lock-keywords '(;; <__function.name+n> - ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face)) - ) + ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" + (1 font-lock-function-name-face))) "Font lock keywords used in `gdb-memory-mode'.") (defvar gdb-memory-header @@ -3127,52 +3141,52 @@ (concat "Start address[" (propertize "-" - 'face font-lock-warning-face - 'help-echo "mouse-1: decrement address" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-show-previous-page)) + 'face font-lock-warning-face + 'help-echo "mouse-1: decrement address" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 + #'gdb-memory-show-previous-page)) "|" (propertize "+" - 'face font-lock-warning-face - 'help-echo "mouse-1: increment address" + 'face font-lock-warning-face + 'help-echo "mouse-1: increment address" 'mouse-face 'mode-line-highlight 'local-map (gdb-make-header-line-mouse-map 'mouse-1 #'gdb-memory-show-next-page)) - "]: " - (propertize gdb-memory-address + "]: " + (propertize gdb-memory-address 'face font-lock-warning-face 'help-echo "mouse-1: set start address" 'mouse-face 'mode-line-highlight 'local-map (gdb-make-header-line-mouse-map 'mouse-1 #'gdb-memory-set-address-event)) - " Rows: " - (propertize (number-to-string gdb-memory-rows) + " Rows: " + (propertize (number-to-string gdb-memory-rows) 'face font-lock-warning-face 'help-echo "mouse-1: set number of columns" 'mouse-face 'mode-line-highlight 'local-map (gdb-make-header-line-mouse-map 'mouse-1 #'gdb-memory-set-rows)) - " Columns: " - (propertize (number-to-string gdb-memory-columns) + " Columns: " + (propertize (number-to-string gdb-memory-columns) 'face font-lock-warning-face 'help-echo "mouse-1: set number of columns" 'mouse-face 'mode-line-highlight 'local-map (gdb-make-header-line-mouse-map 'mouse-1 #'gdb-memory-set-columns)) - " Display Format: " - (propertize gdb-memory-format + " Display Format: " + (propertize gdb-memory-format 'face font-lock-warning-face 'help-echo "mouse-3: select display format" 'mouse-face 'mode-line-highlight 'local-map gdb-memory-format-map) - " Unit Size: " - (propertize (number-to-string gdb-memory-unit) + " Unit Size: " + (propertize (number-to-string gdb-memory-unit) 'face font-lock-warning-face 'help-echo "mouse-3: select unit size" 'mouse-face 'mode-line-highlight @@ -3213,18 +3227,18 @@ (concat "disassembly of " (gdb-get-target-string)))) (def-gdb-display-buffer - gdb-display-disassembly-buffer - 'gdb-disassembly-buffer - "Display disassembly for current stack frame.") + gdb-display-disassembly-buffer + 'gdb-disassembly-buffer + "Display disassembly for current stack frame.") (def-gdb-preempt-display-buffer gdb-preemptively-display-disassembly-buffer 'gdb-disassembly-buffer) (def-gdb-frame-for-buffer - gdb-frame-disassembly-buffer - 'gdb-disassembly-buffer - "Display disassembly in a new frame.") + gdb-frame-disassembly-buffer + 'gdb-disassembly-buffer + "Display disassembly in a new frame.") (def-gdb-auto-update-trigger gdb-invalidate-disassembly (let* ((frame (gdb-current-buffer-frame)) @@ -3269,7 +3283,7 @@ (let ((map (make-sparse-keymap))) (suppress-keymap map) (define-key map "q" 'kill-this-buffer) - map)) + map)) (define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly" "Major mode for GDB disassembly information." @@ -3286,12 +3300,13 @@ (address (bindat-get-field (gdb-current-buffer-frame) 'addr)) (table (make-gdb-table)) (marked-line nil)) - (dolist (instr instructions) + (dolist (instr instructions) (gdb-table-add-row table - (list - (bindat-get-field instr 'address) - (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset))) - (bindat-get-field instr 'inst))) + (list + (bindat-get-field instr 'address) + (apply #'format "<%s+%s>:" + (gdb-get-many-fields instr 'func-name 'offset)) + (bindat-get-field instr 'inst))) (when (string-equal (bindat-get-field instr 'address) address) (progn @@ -3300,17 +3315,18 @@ (if (string-equal gdb-frame-number "0") nil '((overlay-arrow . hollow-right-triangle))))))) - (insert (gdb-table-string table " ")) - (gdb-disassembly-place-breakpoints) - ;; Mark current position with overlay arrow and scroll window to - ;; that point - (when marked-line - (let ((window (get-buffer-window (current-buffer) 0))) - (set-window-point window (gdb-mark-line marked-line gdb-disassembly-position)))) - (setq mode-name - (gdb-current-context-mode-name - (concat "Disassembly: " - (bindat-get-field (gdb-current-buffer-frame) 'func)))))) + (insert (gdb-table-string table " ")) + (gdb-disassembly-place-breakpoints) + ;; Mark current position with overlay arrow and scroll window to + ;; that point + (when marked-line + (let ((window (get-buffer-window (current-buffer) 0))) + (set-window-point window (gdb-mark-line marked-line + gdb-disassembly-position)))) + (setq mode-name + (gdb-current-context-mode-name + (concat "Disassembly: " + (bindat-get-field (gdb-current-buffer-frame) 'func)))))) (defun gdb-disassembly-place-breakpoints () (gdb-remove-breakpoint-icons (point-min) (point-max)) @@ -3331,7 +3347,8 @@ nil nil mode-line) " " (gdb-propertize-header "Threads" gdb-threads-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) + "mouse-1: select" mode-line-highlight + mode-line-inactive))) ;;; Breakpoints view (define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints" @@ -3347,7 +3364,7 @@ (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) (if breakpoint (gud-basic-call - (concat (if (string-equal "y" (bindat-get-field breakpoint 'enabled)) + (concat (if (equal "y" (bindat-get-field breakpoint 'enabled)) "-break-disable " "-break-enable ") (bindat-get-field breakpoint 'number))) @@ -3357,11 +3374,12 @@ "Delete the breakpoint at current line of breakpoints buffer." (interactive) (save-excursion - (beginning-of-line) - (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) - (if breakpoint - (gud-basic-call (concat "-break-delete " (bindat-get-field breakpoint 'number))) - (error "Not recognized as break/watchpoint line"))))) + (beginning-of-line) + (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) + (if breakpoint + (gud-basic-call (concat "-break-delete " + (bindat-get-field breakpoint 'number))) + (error "Not recognized as break/watchpoint line"))))) (defun gdb-goto-breakpoint (&optional event) "Go to the location of breakpoint at current line of @@ -3372,24 +3390,24 @@ (let ((window (get-buffer-window gud-comint-buffer))) (if window (save-selected-window (select-window window)))) (save-excursion - (beginning-of-line) - (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) - (if breakpoint - (let ((bptno (bindat-get-field breakpoint 'number)) - (file (bindat-get-field breakpoint 'fullname)) - (line (bindat-get-field breakpoint 'line))) - (save-selected-window - (let* ((buffer (find-file-noselect - (if (file-exists-p file) file - (cdr (assoc bptno gdb-location-alist))))) - (window (or (gdb-display-source-buffer buffer) - (display-buffer buffer)))) - (setq gdb-source-window window) - (with-current-buffer buffer - (goto-char (point-min)) - (forward-line (1- (string-to-number line))) - (set-window-point window (point)))))) - (error "Not recognized as break/watchpoint line"))))) + (beginning-of-line) + (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) + (if breakpoint + (let ((bptno (bindat-get-field breakpoint 'number)) + (file (bindat-get-field breakpoint 'fullname)) + (line (bindat-get-field breakpoint 'line))) + (save-selected-window + (let* ((buffer (find-file-noselect + (if (file-exists-p file) file + (cdr (assoc bptno gdb-location-alist))))) + (window (or (gdb-display-source-buffer buffer) + (display-buffer buffer)))) + (setq gdb-source-window window) + (with-current-buffer buffer + (goto-char (point-min)) + (forward-line (1- (string-to-number line))) + (set-window-point window (point)))))) + (error "Not recognized as break/watchpoint line"))))) ;; Frames buffer. This displays a perpetually correct bactrack trace. @@ -3421,21 +3439,21 @@ (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack)) (table (make-gdb-table))) (set-marker gdb-stack-position nil) - (dolist (frame stack) - (gdb-table-add-row table - (list - (bindat-get-field frame 'level) - "in" - (concat - (bindat-get-field frame 'func) - (if gdb-stack-buffer-locations - (gdb-frame-location frame) "") - (if gdb-stack-buffer-addresses - (concat " at " (bindat-get-field frame 'addr)) ""))) - `(mouse-face highlight - help-echo "mouse-2, RET: Select frame" - gdb-frame ,frame))) - (insert (gdb-table-string table " "))) + (dolist (frame stack) + (gdb-table-add-row table + (list + (bindat-get-field frame 'level) + "in" + (concat + (bindat-get-field frame 'func) + (if gdb-stack-buffer-locations + (gdb-frame-location frame) "") + (if gdb-stack-buffer-addresses + (concat " at " (bindat-get-field frame 'addr)) ""))) + `(mouse-face highlight + help-echo "mouse-2, RET: Select frame" + gdb-frame ,frame))) + (insert (gdb-table-string table " "))) (when (and gdb-frame-number (gdb-buffer-shows-main-thread-p)) (gdb-mark-line (1+ (string-to-number gdb-frame-number)) @@ -3448,18 +3466,18 @@ (concat "stack frames of " (gdb-get-target-string)))) (def-gdb-display-buffer - gdb-display-stack-buffer - 'gdb-stack-buffer - "Display backtrace of current stack.") + gdb-display-stack-buffer + 'gdb-stack-buffer + "Display backtrace of current stack.") (def-gdb-preempt-display-buffer gdb-preemptively-display-stack-buffer 'gdb-stack-buffer nil t) (def-gdb-frame-for-buffer - gdb-frame-stack-buffer - 'gdb-stack-buffer - "Display backtrace of current stack in a new frame.") + gdb-frame-stack-buffer + 'gdb-stack-buffer + "Display backtrace of current stack in a new frame.") (defvar gdb-frames-mode-map (let ((map (make-sparse-keymap))) @@ -3492,7 +3510,8 @@ (if (gdb-buffer-shows-main-thread-p) (let ((new-level (bindat-get-field frame 'level))) (setq gdb-frame-number new-level) - (gdb-input (list (concat "-stack-select-frame " new-level) 'ignore)) + (gdb-input (list (concat "-stack-select-frame " new-level) + 'ignore)) (gdb-update)) (error "Could not select frame for non-current thread")) (error "Not recognized as frame line")))) @@ -3502,7 +3521,8 @@ ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. (def-gdb-trigger-and-handler gdb-invalidate-locals - (concat (gdb-current-context-command "-stack-list-locals") " --simple-values") + (concat (gdb-current-context-command "-stack-list-locals") + " --simple-values") gdb-locals-handler gdb-locals-handler-custom '(start update)) @@ -3518,7 +3538,7 @@ (define-key map "\r" 'gud-watch) (define-key map [mouse-2] 'gud-watch) map) - "Keymap to create watch expression of a complex data type local variable.") + "Keymap to create watch expression of a complex data type local variable.") (defvar gdb-edit-locals-map-1 (let ((map (make-sparse-keymap))) @@ -3526,7 +3546,7 @@ (define-key map "\r" 'gdb-edit-locals-value) (define-key map [mouse-2] 'gdb-edit-locals-value) map) - "Keymap to edit value of a simple data type local variable.") + "Keymap to edit value of a simple data type local variable.") (defun gdb-edit-locals-value (&optional event) "Assign a value to a variable displayed in the locals buffer." @@ -3552,14 +3572,14 @@ (if (or (not value) (string-match "\\0x" value)) (add-text-properties 0 (length name) - `(mouse-face highlight - help-echo "mouse-2: create watch expression" - local-map ,gdb-locals-watch-map) - name) + `(mouse-face highlight + help-echo "mouse-2: create watch expression" + local-map ,gdb-locals-watch-map) + name) (add-text-properties 0 (length value) `(mouse-face highlight - help-echo "mouse-2: edit value" - local-map ,gdb-edit-locals-map-1) + help-echo "mouse-2: edit value" + local-map ,gdb-edit-locals-map-1) value)) (gdb-table-add-row table @@ -3571,7 +3591,8 @@ (insert (gdb-table-string table " ")) (setq mode-name (gdb-current-context-mode-name - (concat "Locals: " (bindat-get-field (gdb-current-buffer-frame) 'func)))))) + (concat "Locals: " + (bindat-get-field (gdb-current-buffer-frame) 'func)))))) (defvar gdb-locals-header (list @@ -3579,19 +3600,20 @@ nil nil mode-line) " " (gdb-propertize-header "Registers" gdb-registers-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) + "mouse-1: select" mode-line-highlight + mode-line-inactive))) (defvar gdb-locals-mode-map (let ((map (make-sparse-keymap))) (suppress-keymap map) (define-key map "q" 'kill-this-buffer) (define-key map "\t" (lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create - 'gdb-registers-buffer - gdb-thread-number) t))) - map)) + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create + 'gdb-registers-buffer + gdb-thread-number) t))) + map)) (define-derived-mode gdb-locals-mode gdb-parent-mode "Locals" "Major mode for gdb locals." @@ -3603,18 +3625,18 @@ (concat "locals of " (gdb-get-target-string)))) (def-gdb-display-buffer - gdb-display-locals-buffer - 'gdb-locals-buffer - "Display local variables of current stack and their values.") + gdb-display-locals-buffer + 'gdb-locals-buffer + "Display local variables of current stack and their values.") (def-gdb-preempt-display-buffer - gdb-preemptively-display-locals-buffer - 'gdb-locals-buffer nil t) + gdb-preemptively-display-locals-buffer + 'gdb-locals-buffer nil t) (def-gdb-frame-for-buffer - gdb-frame-locals-buffer - 'gdb-locals-buffer - "Display local variables of current stack and their values in a new frame.") + gdb-frame-locals-buffer + 'gdb-locals-buffer + "Display local variables of current stack and their values in a new frame.") ;; Registers buffer. @@ -3634,7 +3656,8 @@ (defun gdb-registers-handler-custom () (when gdb-register-names - (let ((register-values (bindat-get-field (gdb-json-partial-output) 'register-values)) + (let ((register-values + (bindat-get-field (gdb-json-partial-output) 'register-values)) (table (make-gdb-table))) (dolist (register register-values) (let* ((register-number (bindat-get-field register 'number)) @@ -3644,7 +3667,8 @@ (gdb-table-add-row table (list - (propertize register-name 'font-lock-face font-lock-variable-name-face) + (propertize register-name + 'font-lock-face font-lock-variable-name-face) (if (member register-number gdb-changed-registers) (propertize value 'font-lock-face font-lock-warning-face) value)) @@ -3674,17 +3698,18 @@ (define-key map [mouse-2] 'gdb-edit-register-value) (define-key map "q" 'kill-this-buffer) (define-key map "\t" (lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create - 'gdb-locals-buffer - gdb-thread-number) t))) + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create + 'gdb-locals-buffer + gdb-thread-number) t))) map)) (defvar gdb-registers-header (list (gdb-propertize-header "Locals" gdb-locals-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive) + "mouse-1: select" mode-line-highlight + mode-line-inactive) " " (gdb-propertize-header "Registers" gdb-registers-buffer nil nil mode-line))) @@ -3699,17 +3724,17 @@ (concat "registers of " (gdb-get-target-string)))) (def-gdb-display-buffer - gdb-display-registers-buffer - 'gdb-registers-buffer - "Display integer register contents.") + gdb-display-registers-buffer + 'gdb-registers-buffer + "Display integer register contents.") (def-gdb-preempt-display-buffer gdb-preemptively-display-registers-buffer - 'gdb-registers-buffer nil t) + 'gdb-registers-buffer nil t) (def-gdb-frame-for-buffer - gdb-frame-registers-buffer - 'gdb-registers-buffer + gdb-frame-registers-buffer + 'gdb-registers-buffer "Display integer register contents in a new frame.") ;; Needs GDB 6.4 onwards (used to fail with no stack). @@ -3726,14 +3751,16 @@ (defun gdb-changed-registers-handler () (gdb-delete-pending 'gdb-get-changed-registers) (setq gdb-changed-registers nil) - (dolist (register-number (bindat-get-field (gdb-json-partial-output) 'changed-registers)) + (dolist (register-number + (bindat-get-field (gdb-json-partial-output) 'changed-registers)) (push register-number gdb-changed-registers))) (defun gdb-register-names-handler () ;; Don't use gdb-pending-triggers because this handler is called ;; only once (in gdb-init-1) (setq gdb-register-names nil) - (dolist (register-name (bindat-get-field (gdb-json-partial-output) 'register-names)) + (dolist (register-name + (bindat-get-field (gdb-json-partial-output) 'register-names)) (push register-name gdb-register-names)) (setq gdb-register-names (reverse gdb-register-names))) @@ -3758,7 +3785,8 @@ (if (not (gdb-pending-p 'gdb-get-main-selected-frame)) (progn (gdb-input - (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler)) + (list (gdb-current-context-command "-stack-info-frame") + 'gdb-frame-handler)) (gdb-add-pending 'gdb-get-main-selected-frame)))) (defun gdb-frame-handler () @@ -3809,10 +3837,10 @@ already, in which case that window is splitted first." (let ((answer (get-buffer-window buf (or frame 0)))) (if answer - (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. + (display-buffer buf nil (or frame 0)) ;Deiconify frame if necessary. (let ((window (get-lru-window))) (if (eq (buffer-local-value 'gud-minor-mode (window-buffer window)) - 'gdbmi) + 'gdbmi) (let ((largest (get-largest-window))) (setq answer (split-window largest)) (set-window-buffer answer buf) @@ -3875,7 +3903,8 @@ (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) - (define-key menu [disassembly] '("Disassembly" . gdb-frame-disassembly-buffer)) + (define-key menu [disassembly] + '("Disassembly" . gdb-frame-disassembly-buffer)) (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) (define-key menu [inferior] '("IO" . gdb-frame-io-buffer)) @@ -3886,40 +3915,41 @@ (let ((menu (make-sparse-keymap "GDB-MI"))) (define-key menu [gdb-customize] - '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) - :help "Customize Gdb Graphical Mode options.")) + '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) + :help "Customize Gdb Graphical Mode options.")) (define-key menu [gdb-many-windows] - '(menu-item "Display Other Windows" gdb-many-windows - :help "Toggle display of locals, stack and breakpoint information" - :button (:toggle . gdb-many-windows))) + '(menu-item "Display Other Windows" gdb-many-windows + :help "Toggle display of locals, stack and breakpoint information" + :button (:toggle . gdb-many-windows))) (define-key menu [gdb-restore-windows] - '(menu-item "Restore Window Layout" gdb-restore-windows - :help "Restore standard layout for debug session.")) + '(menu-item "Restore Window Layout" gdb-restore-windows + :help "Restore standard layout for debug session.")) (define-key menu [sep1] '(menu-item "--")) (define-key menu [all-threads] '(menu-item "GUD controls all threads" - (lambda () - (interactive) - (setq gdb-gud-control-all-threads t)) - :help "GUD start/stop commands apply to all threads" - :button (:radio . gdb-gud-control-all-threads))) + (lambda () + (interactive) + (setq gdb-gud-control-all-threads t)) + :help "GUD start/stop commands apply to all threads" + :button (:radio . gdb-gud-control-all-threads))) (define-key menu [current-thread] '(menu-item "GUD controls current thread" - (lambda () - (interactive) - (setq gdb-gud-control-all-threads nil)) - :help "GUD start/stop commands apply to current thread only" - :button (:radio . (not gdb-gud-control-all-threads)))) + (lambda () + (interactive) + (setq gdb-gud-control-all-threads nil)) + :help "GUD start/stop commands apply to current thread only" + :button (:radio . (not gdb-gud-control-all-threads)))) (define-key menu [sep2] '(menu-item "--")) (define-key menu [gdb-customize-reasons] '(menu-item "Customize switching..." - (lambda () - (interactive) - (customize-option 'gdb-switch-reasons)))) + (lambda () + (interactive) + (customize-option 'gdb-switch-reasons)))) (define-key menu [gdb-switch-when-another-stopped] - (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped gdb-switch-when-another-stopped + (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped + gdb-switch-when-another-stopped "Automatically switch to stopped thread" "GDB thread switching %s" "Switch to stopped thread")) @@ -3933,18 +3963,18 @@ ;; show up right before Run button. (define-key-after gud-tool-bar-map [all-threads] '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads - :image (find-image '((:type xpm :file "gud/thread.xpm"))) - :visible (and (eq gud-minor-mode 'gdbmi) - gdb-non-stop - (not gdb-gud-control-all-threads))) + :image (find-image '((:type xpm :file "gud/thread.xpm"))) + :visible (and (eq gud-minor-mode 'gdbmi) + gdb-non-stop + (not gdb-gud-control-all-threads))) 'run) (define-key-after gud-tool-bar-map [current-thread] '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread - :image (find-image '((:type xpm :file "gud/all.xpm"))) - :visible (and (eq gud-minor-mode 'gdbmi) - gdb-non-stop - gdb-gud-control-all-threads)) + :image (find-image '((:type xpm :file "gud/all.xpm"))) + :visible (and (eq gud-minor-mode 'gdbmi) + gdb-non-stop + gdb-gud-control-all-threads)) 'all-threads) (defun gdb-frame-gdb-buffer () @@ -3963,15 +3993,16 @@ (let ((same-window-regexps nil)) (select-window (display-buffer gud-comint-buffer nil 0)))) -(defun gdb-set-window-buffer (name &optional ignore-dedicated) +(defun gdb-set-window-buffer (name &optional ignore-dedicated window) "Set buffer of selected window to NAME and dedicate window. When IGNORE-DEDICATED is non-nil, buffer is set even if selected window is dedicated." + (unless window (setq window (selected-window))) (when ignore-dedicated - (set-window-dedicated-p (selected-window) nil)) - (set-window-buffer (selected-window) (get-buffer name)) - (set-window-dedicated-p (selected-window) t)) + (set-window-dedicated-p window nil)) + (set-window-buffer window (get-buffer name)) + (set-window-dedicated-p window t)) (defun gdb-setup-windows () "Layout the window pattern for `gdb-many-windows'." @@ -3980,35 +4011,35 @@ (delete-other-windows) (gdb-display-breakpoints-buffer) (delete-other-windows) - ; Don't dedicate. + ;; Don't dedicate. (pop-to-buffer gud-comint-buffer) - (split-window nil ( / ( * (window-height) 3) 4)) - (split-window nil ( / (window-height) 3)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer (gdb-locals-buffer-name)) - (other-window 1) - (switch-to-buffer - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (if gdb-main-file - (gud-find-file gdb-main-file) - ;; Put buffer list in window if we - ;; can't find a source file. - (list-buffers-noselect)))) - (setq gdb-source-window (selected-window)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-inferior-io)) - (other-window 1) - (gdb-set-window-buffer (gdb-stack-buffer-name)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer (if gdb-show-threads-by-default - (gdb-threads-buffer-name) - (gdb-breakpoints-buffer-name))) - (other-window 1)) + (let ((win0 (selected-window)) + (win1 (split-window nil ( / ( * (window-height) 3) 4))) + (win2 (split-window nil ( / (window-height) 3))) + (win3 (split-window-horizontally))) + (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3) + (select-window win2) + (set-window-buffer + win2 + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (if gdb-main-file + (gud-find-file gdb-main-file) + ;; Put buffer list in window if we + ;; can't find a source file. + (list-buffers-noselect)))) + (setq gdb-source-window (selected-window)) + (let ((win4 (split-window-horizontally))) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-inferior-io) nil win4)) + (select-window win1) + (gdb-set-window-buffer (gdb-stack-buffer-name)) + (let ((win5 (split-window-horizontally))) + (gdb-set-window-buffer (if gdb-show-threads-by-default + (gdb-threads-buffer-name) + (gdb-breakpoints-buffer-name)) + nil win5)) + (select-window win0))) (defcustom gdb-many-windows nil "If nil just pop up the GUD buffer unless `gdb-show-main' is t. @@ -4025,34 +4056,33 @@ With arg, display additional buffers iff arg is positive." (interactive "P") (setq gdb-many-windows - (if (null arg) - (not gdb-many-windows) - (> (prefix-numeric-value arg) 0))) + (if (null arg) + (not gdb-many-windows) + (> (prefix-numeric-value arg) 0))) (message (format "Display of other windows %sabled" - (if gdb-many-windows "en" "dis"))) + (if gdb-many-windows "en" "dis"))) (if (and gud-comint-buffer - (buffer-name gud-comint-buffer)) + (buffer-name gud-comint-buffer)) (condition-case nil - (gdb-restore-windows) - (error nil)))) + (gdb-restore-windows) + (error nil)))) (defun gdb-restore-windows () "Restore the basic arrangement of windows used by gdb. This arrangement depends on the value of `gdb-many-windows'." (interactive) - (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. - (delete-other-windows) + (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. + (delete-other-windows) (if gdb-many-windows (gdb-setup-windows) (when (or gud-last-last-frame gdb-show-main) - (split-window) - (other-window 1) - (switch-to-buffer - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (gud-find-file gdb-main-file))) - (setq gdb-source-window (selected-window)) - (other-window 1)))) + (let ((win (split-window))) + (set-window-buffer + win + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (gud-find-file gdb-main-file))) + (setq gdb-source-window win))))) (defun gdb-reset () "Exit a debugging session cleanly. @@ -4060,23 +4090,23 @@ (dolist (buffer (buffer-list)) (unless (eq buffer gud-comint-buffer) (with-current-buffer buffer - (if (eq gud-minor-mode 'gdbmi) - (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) - (kill-buffer nil) - (gdb-remove-breakpoint-icons (point-min) (point-max) t) - (setq gud-minor-mode nil) - (kill-local-variable 'tool-bar-map) - (kill-local-variable 'gdb-define-alist)))))) + (if (eq gud-minor-mode 'gdbmi) + (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) + (kill-buffer nil) + (gdb-remove-breakpoint-icons (point-min) (point-max) t) + (setq gud-minor-mode nil) + (kill-local-variable 'tool-bar-map) + (kill-local-variable 'gdb-define-alist)))))) (setq gdb-disassembly-position nil) (setq overlay-arrow-variable-list - (delq 'gdb-disassembly-position overlay-arrow-variable-list)) + (delq 'gdb-disassembly-position overlay-arrow-variable-list)) (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) (setq gdb-stack-position nil) (setq overlay-arrow-variable-list - (delq 'gdb-stack-position overlay-arrow-variable-list)) + (delq 'gdb-stack-position overlay-arrow-variable-list)) (setq gdb-thread-position nil) (setq overlay-arrow-variable-list - (delq 'gdb-thread-position overlay-arrow-variable-list)) + (delq 'gdb-thread-position overlay-arrow-variable-list)) (if (boundp 'speedbar-frame) (speedbar-timer-fn)) (setq gud-running nil) (setq gdb-active-process nil) @@ -4088,12 +4118,12 @@ (goto-char (point-min)) (if (re-search-forward gdb-source-file-regexp nil t) (setq gdb-main-file (match-string 1))) - (if gdb-many-windows + (if gdb-many-windows (gdb-setup-windows) - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - (if gdb-show-main - (let ((pop-up-windows t)) - (display-buffer (gud-find-file gdb-main-file)))))) + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (if gdb-show-main + (let ((pop-up-windows t)) + (display-buffer (gud-find-file gdb-main-file)))))) ;;from put-image (defun gdb-put-string (putstring pos &optional dprop &rest sprops) @@ -4102,14 +4132,14 @@ `before-string' string that has a `display' property whose value is PUTSTRING." (let ((string (make-string 1 ?x)) - (buffer (current-buffer))) + (buffer (current-buffer))) (setq putstring (copy-sequence putstring)) (let ((overlay (make-overlay pos pos buffer)) - (prop (or dprop - (list (list 'margin 'left-margin) putstring)))) + (prop (or dprop + (list (list 'margin 'left-margin) putstring)))) (put-text-property 0 1 'display prop string) (if sprops - (add-text-properties 0 1 sprops string)) + (add-text-properties 0 1 sprops string)) (overlay-put overlay 'put-break t) (overlay-put overlay 'before-string string)))) @@ -4122,7 +4152,7 @@ (setq buffer (current-buffer))) (dolist (overlay (overlays-in start end)) (when (overlay-get overlay 'put-break) - (delete-overlay overlay)))) + (delete-overlay overlay)))) (defun gdb-put-breakpoint-icon (enabled bptno &optional line) (let* ((posns (gdb-line-posns (or line (line-number-at-pos)))) @@ -4134,62 +4164,63 @@ 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") putstring) (if enabled - (add-text-properties - 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) + (add-text-properties + 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) (add-text-properties 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) (gdb-remove-breakpoint-icons start end) (if (display-images-p) - (if (>= (or left-fringe-width - (if source-window (car (window-fringes source-window))) - gdb-buffer-fringe-width) 8) - (gdb-put-string - nil (1+ start) - `(left-fringe breakpoint - ,(if enabled - 'breakpoint-enabled - 'breakpoint-disabled)) - 'gdb-bptno bptno - 'gdb-enabled enabled) - (when (< left-margin-width 2) - (save-current-buffer - (setq left-margin-width 2) - (if source-window - (set-window-margins - source-window - left-margin-width right-margin-width)))) - (put-image - (if enabled - (or breakpoint-enabled-icon - (setq breakpoint-enabled-icon - (find-image `((:type xpm :data - ,breakpoint-xpm-data - :ascent 100 :pointer hand) - (:type pbm :data - ,breakpoint-enabled-pbm-data - :ascent 100 :pointer hand))))) - (or breakpoint-disabled-icon - (setq breakpoint-disabled-icon - (find-image `((:type xpm :data - ,breakpoint-xpm-data - :conversion disabled - :ascent 100 :pointer hand) - (:type pbm :data - ,breakpoint-disabled-pbm-data - :ascent 100 :pointer hand)))))) - (+ start 1) - putstring - 'left-margin)) + (if (>= (or left-fringe-width + (if source-window (car (window-fringes source-window))) + gdb-buffer-fringe-width) 8) + (gdb-put-string + nil (1+ start) + `(left-fringe breakpoint + ,(if enabled + 'breakpoint-enabled + 'breakpoint-disabled)) + 'gdb-bptno bptno + 'gdb-enabled enabled) + (when (< left-margin-width 2) + (save-current-buffer + (setq left-margin-width 2) + (if source-window + (set-window-margins + source-window + left-margin-width right-margin-width)))) + (put-image + (if enabled + (or breakpoint-enabled-icon + (setq breakpoint-enabled-icon + (find-image `((:type xpm :data + ,breakpoint-xpm-data + :ascent 100 :pointer hand) + (:type pbm :data + ,breakpoint-enabled-pbm-data + :ascent 100 :pointer hand))))) + (or breakpoint-disabled-icon + (setq breakpoint-disabled-icon + (find-image `((:type xpm :data + ,breakpoint-xpm-data + :conversion disabled + :ascent 100 :pointer hand) + (:type pbm :data + ,breakpoint-disabled-pbm-data + :ascent 100 :pointer hand)))))) + (+ start 1) + putstring + 'left-margin)) (when (< left-margin-width 2) - (save-current-buffer - (setq left-margin-width 2) - (let ((window (get-buffer-window (current-buffer) 0))) - (if window - (set-window-margins - window left-margin-width right-margin-width))))) + (save-current-buffer + (setq left-margin-width 2) + (let ((window (get-buffer-window (current-buffer) 0))) + (if window + (set-window-margins + window left-margin-width right-margin-width))))) (gdb-put-string (propertize putstring - 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) + 'face (if enabled + 'breakpoint-enabled 'breakpoint-disabled)) (1+ start))))) (defun gdb-remove-breakpoint-icons (start end &optional remove-margin) @@ -4200,8 +4231,8 @@ (setq left-margin-width 0) (let ((window (get-buffer-window (current-buffer) 0))) (if window - (set-window-margins - window left-margin-width right-margin-width))))) + (set-window-margins + window left-margin-width right-margin-width))))) (provide 'gdb-mi) ------------------------------------------------------------ revno: 104972 fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8941 committer: Stefan Monnier branch nick: trunk timestamp: Tue 2011-07-05 14:56:31 -0400 message: * lisp/progmodes/which-func.el (which-func-ff-hook): Don't output a message if imenu is simply not configured. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 18:54:08 +0000 +++ lisp/ChangeLog 2011-07-05 18:56:31 +0000 @@ -1,13 +1,17 @@ +2011-07-05 Stefan Monnier + + * progmodes/which-func.el (which-func-ff-hook): Don't output a message + if imenu is simply not configured (bug#8941). + 2011-07-05 Ken Manheimer * allout.el (allout-post-undo-hook): New allout outline-change event hook to signal undo activity. (allout-post-command-business): Run allout-post-undo-hook if an undo just occurred. - (allout-after-copy-or-kill-hook), (allout-mode): Minor docstring - changes. - * allout-widgets.el (allout-widgets-after-undo-function): Ensure - the integrity of the current item's decoration after it has been + (allout-after-copy-or-kill-hook, allout-mode): Minor docstring changes. + * allout-widgets.el (allout-widgets-after-undo-function): + Ensure the integrity of the current item's decoration after it has been in the vicinity of an undo. (allout-widgets-mode): Include allout-widgets-after-undo-function on the new allout-post-undo-hook. === modified file 'lisp/progmodes/which-func.el' --- lisp/progmodes/which-func.el 2011-05-12 07:07:06 +0000 +++ lisp/progmodes/which-func.el 2011-07-05 18:56:31 +0000 @@ -206,7 +206,8 @@ (setq imenu--index-alist (save-excursion (funcall imenu-create-index-function)))) (error - (message "which-func-ff-hook error: %S" err) + (unless (equal err '(error "This buffer cannot use `imenu-default-create-index-function'")) + (message "which-func-ff-hook error: %S" err)) (setq which-func-mode nil)))) (defun which-func-update () ------------------------------------------------------------ revno: 104971 committer: Ken Manheimer branch nick: trunk timestamp: Tue 2011-07-05 14:54:08 -0400 message: * allout.el (allout-post-undo-hook): New allout outline-change event hook to signal undo activity. (allout-post-command-business): Run allout-post-undo-hook if an undo just occurred. (allout-after-copy-or-kill-hook), (allout-mode): Minor docstring changes. * allout-widgets.el (allout-widgets-after-undo-function): Ensure the integrity of the current item's decoration after it has been in the vicinity of an undo. (allout-widgets-mode): Include allout-widgets-after-undo-function on the new allout-post-undo-hook. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 18:26:33 +0000 +++ lisp/ChangeLog 2011-07-05 18:54:08 +0000 @@ -1,3 +1,18 @@ +2011-07-05 Ken Manheimer + + * allout.el (allout-post-undo-hook): New allout outline-change + event hook to signal undo activity. + (allout-post-command-business): Run allout-post-undo-hook if an + undo just occurred. + (allout-after-copy-or-kill-hook), (allout-mode): Minor docstring + changes. + * allout-widgets.el (allout-widgets-after-undo-function): Ensure + the integrity of the current item's decoration after it has been + in the vicinity of an undo. + (allout-widgets-mode): Include allout-widgets-after-undo-function + on the new allout-post-undo-hook. + + 2011-07-05 Stefan Monnier * emacs-lisp/lisp-mode.el (lisp-interaction-mode-abbrev-table): === modified file 'lisp/allout-widgets.el' --- lisp/allout-widgets.el 2011-07-01 00:11:50 +0000 +++ lisp/allout-widgets.el 2011-07-05 18:54:08 +0000 @@ -561,6 +561,8 @@ 'allout-widgets-shifts-recorder nil 'local) (add-hook 'allout-after-copy-or-kill-hook 'allout-widgets-after-copy-or-kill-function nil 'local) + (add-hook 'allout-post-undo-hook + 'allout-widgets-after-undo-function nil 'local) (add-hook 'before-change-functions 'allout-widgets-before-change-handler nil 'local) @@ -1130,6 +1132,14 @@ Intended for use on allout-after-copy-or-kill-hook." (if (car kill-ring) (setcar kill-ring (allout-widgets-undecorate-text (car kill-ring))))) +;;;_ > allout-widgets-after-undo-function () +(defun allout-widgets-after-undo-function () + "Do allout-widgets processing of text after an undo. + +Intended for use on allout-post-undo-hook." + (save-excursion + (if (allout-goto-prefix) + (allout-redecorate-item (allout-get-or-create-item-widget))))) ;;;_ > allout-widgets-exposure-undo-recorder (widget from-state) (defun allout-widgets-exposure-undo-recorder (widget) === modified file 'lisp/allout.el' --- lisp/allout.el 2011-07-04 22:16:10 +0000 +++ lisp/allout.el 2011-07-05 18:54:08 +0000 @@ -1461,7 +1461,15 @@ (defvar allout-after-copy-or-kill-hook nil "*Hook that's run after copying outline text. -Functions on the hook should not take any arguments.") +Functions on the hook should not require any arguments.") +;;;_ = allout-post-undo-hook +(defvar allout-post-undo-hook nil + "*Hook that's run after undo activity. + +The item that's current when the hook is run *may* be the one +that was affected by the undo. + +Functions on the hook should not require any arguments.") ;;;_ = allout-outside-normal-auto-fill-function (defvar allout-outside-normal-auto-fill-function nil "Value of normal-auto-fill-function outside of allout mode. @@ -1874,6 +1882,7 @@ `allout-structure-deleted-hook' `allout-structure-shifted-hook' `allout-after-copy-or-kill-hook' +`allout-post-undo-hook' Terminology @@ -3313,6 +3322,7 @@ (when allout-just-did-undo (setq allout-just-did-undo nil) + (run-hooks 'allout-post-undo-hook) (cond ((and (= buffer-saved-size -1) allout-auto-save-temporarily-disabled) ;; user possibly undid a decryption, deinhibit auto-save: ------------------------------------------------------------ revno: 104970 fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8998 committer: Stefan Monnier branch nick: trunk timestamp: Tue 2011-07-05 14:26:33 -0400 message: * lisp/emacs-lisp/lisp-mode.el (lisp-interaction-mode-abbrev-table): Let define-derived-mode define it. * lisp/emacs-lisp/derived.el (define-derived-mode): Try to avoid creating cycles of abbrev-table inheritance. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 17:44:15 +0000 +++ lisp/ChangeLog 2011-07-05 18:26:33 +0000 @@ -1,3 +1,10 @@ +2011-07-05 Stefan Monnier + + * emacs-lisp/lisp-mode.el (lisp-interaction-mode-abbrev-table): + Let define-derived-mode define it. + * emacs-lisp/derived.el (define-derived-mode): Try to avoid creating + cycles of abbrev-table inheritance (bug#8998). + 2011-07-05 Roland Winkler * textmodes/bibtex.el: Add support for biblatex. @@ -10,15 +17,15 @@ (bibtex-entry-alist, bibtex-field-alist): New widgets. (bibtex-set-dialect): New command. (bibtex-entry-type, bibtex-entry-head) - (bibtex-entry-maybe-empty-head, bibtex-any-valid-entry-type): Bind - via bibtex-set-dialect. + (bibtex-entry-maybe-empty-head, bibtex-any-valid-entry-type): + Bind via bibtex-set-dialect. (bibtex-Article, bibtex-Book, bibtex-Booklet, bibtex-InBook) (bibtex-InCollection, bibtex-InProceedings, bibtex-Manual) (bibtex-MastersThesis, bibtex-Misc, bibtex-PhdThesis) (bibtex-Proceedings, bibtex-TechReport, bibtex-Unpublished): Define via bibtex-set-dialect. - (bibtex-name-in-field, bibtex-remove-OPT-or-ALT): Obey - bibtex-no-opt-remove-re. + (bibtex-name-in-field, bibtex-remove-OPT-or-ALT): + Obey bibtex-no-opt-remove-re. (bibtex-vec-push, bibtex-vec-incr): New functions. (bibtex-format-entry, bibtex-field-list) (bibtex-print-help-message, bibtex-validate) === modified file 'lisp/emacs-lisp/derived.el' --- lisp/emacs-lisp/derived.el 2011-07-01 16:41:02 +0000 +++ lisp/emacs-lisp/derived.el 2011-07-05 18:26:33 +0000 @@ -255,7 +255,10 @@ (not (eq parent (standard-syntax-table)))) (set-char-table-parent ,syntax (syntax-table))))) ,(when declare-abbrev - `(unless (abbrev-table-get ,abbrev :parents) + `(unless (or (abbrev-table-get ,abbrev :parents) + ;; This can happen if the major mode defines + ;; the abbrev-table to be its parent's. + (eq ,abbrev local-abbrev-table)) (abbrev-table-put ,abbrev :parents (list local-abbrev-table)))))) (use-local-map ,map) === modified file 'lisp/emacs-lisp/lisp-mode.el' --- lisp/emacs-lisp/lisp-mode.el 2011-06-28 12:09:43 +0000 +++ lisp/emacs-lisp/lisp-mode.el 2011-07-05 18:26:33 +0000 @@ -525,7 +525,6 @@ "Keymap for Lisp Interaction mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(defvar lisp-interaction-mode-abbrev-table lisp-mode-abbrev-table) (define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction" "Major mode for typing and evaluating Lisp forms. Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression ------------------------------------------------------------ revno: 104969 committer: Roland Winkler branch nick: trunk timestamp: Tue 2011-07-05 12:44:15 -0500 message: lisp/textmodes/bibtex.el: add support for biblatex diff: === modified file 'etc/NEWS' --- etc/NEWS 2011-07-05 11:38:44 +0000 +++ etc/NEWS 2011-07-05 17:44:15 +0000 @@ -475,6 +475,11 @@ ** BibTeX mode +*** BibTeX mode now supports biblatex. +Use the variable bibtex-dialect to select support for different BibTeX dialects. +bibtex-entry-field-alist is now an obsolete alias for +bibtex-BibTeX-entry-alist. + *** New command `bibtex-search-entries' bound to C-c C-a. *** New `bibtex-entry-format' option `sort-fields', disabled by default. === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 15:31:22 +0000 +++ lisp/ChangeLog 2011-07-05 17:44:15 +0000 @@ -1,3 +1,29 @@ +2011-07-05 Roland Winkler + + * textmodes/bibtex.el: Add support for biblatex. + (bibtex-BibTeX-entry-alist, bibtex-biblatex-entry-alist) + (bibtex-BibTeX-field-alist, bibtex-biblatex-field-alist) + (bibtex-dialect-list, bibtex-dialect, bibtex-no-opt-remove-re) + (bibtex-entry-alist, bibtex-field-alist): New variables. + (bibtex-entry-field-alist): Obsolete alias for + bibtex-BibTeX-entry-alist. + (bibtex-entry-alist, bibtex-field-alist): New widgets. + (bibtex-set-dialect): New command. + (bibtex-entry-type, bibtex-entry-head) + (bibtex-entry-maybe-empty-head, bibtex-any-valid-entry-type): Bind + via bibtex-set-dialect. + (bibtex-Article, bibtex-Book, bibtex-Booklet, bibtex-InBook) + (bibtex-InCollection, bibtex-InProceedings, bibtex-Manual) + (bibtex-MastersThesis, bibtex-Misc, bibtex-PhdThesis) + (bibtex-Proceedings, bibtex-TechReport, bibtex-Unpublished): + Define via bibtex-set-dialect. + (bibtex-name-in-field, bibtex-remove-OPT-or-ALT): Obey + bibtex-no-opt-remove-re. + (bibtex-vec-push, bibtex-vec-incr): New functions. + (bibtex-format-entry, bibtex-field-list) + (bibtex-print-help-message, bibtex-validate) + (bibtex-search-entries): Use new format of bibtex-entry-alist. + 2011-07-05 Stefan Monnier * progmodes/compile.el (compilation-goto-locus): === modified file 'lisp/textmodes/bibtex.el' --- lisp/textmodes/bibtex.el 2011-06-22 20:59:48 +0000 +++ lisp/textmodes/bibtex.el 2011-07-05 17:44:15 +0000 @@ -90,8 +90,8 @@ (defcustom bibtex-user-optional-fields '(("annote" "Personal annotation (ignored)")) "List of optional fields the user wants to have always present. -Entries should be of the same form as the OPTIONAL and -CROSSREF-OPTIONAL lists in `bibtex-entry-field-alist' (which see)." +Entries should be of the same form as the OPTIONAL list +in `bibtex-BibTeX-entry-alist' (which see)." :group 'bibtex :type '(repeat (group (string :tag "Field") (string :tag "Comment") @@ -127,7 +127,7 @@ strings Replace parts of field entries by string constants according to `bibtex-field-strings-alist'. sort-fields Sort fields to match the field order in - `bibtex-entry-field-alist'. + `bibtex-BibTeX-entry-alist'. The value t means do all of the above formatting actions. The value nil means do no formatting at all." @@ -264,265 +264,584 @@ :group 'bibtex :type 'boolean) -(defcustom bibtex-entry-field-alist - '(("Article" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the article (BibTeX converts it to lowercase)") - ("journal" "Name of the journal (use string, remove braces)") - ("year" "Year of publication")) - (("volume" "Volume of the journal") - ("number" "Number of the journal (only allowed if entry contains volume)") - ("pages" "Pages in the journal") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem"))) - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the article (BibTeX converts it to lowercase)")) - (("pages" "Pages in the journal") - ("journal" "Name of the journal (use string, remove braces)") - ("year" "Year of publication") - ("volume" "Volume of the journal") - ("number" "Number of the journal") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("Book" - ((("author" "Author1 [and Author2 ...] [and others]" nil t) - ("editor" "Editor1 [and Editor2 ...] [and others]" nil t) - ("title" "Title of the book") - ("publisher" "Publishing company") - ("year" "Year of publication")) - (("volume" "Volume of the book in the series") - ("number" "Number of the book in a small series (overwritten by volume)") - ("series" "Series in which the book appeared") - ("address" "Address of the publisher") - ("edition" "Edition of the book as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem"))) - ((("author" "Author1 [and Author2 ...] [and others]" nil t) - ("editor" "Editor1 [and Editor2 ...] [and others]" nil t) - ("title" "Title of the book")) - (("publisher" "Publishing company") - ("year" "Year of publication") - ("volume" "Volume of the book in the series") - ("number" "Number of the book in a small series (overwritten by volume)") - ("series" "Series in which the book appeared") - ("address" "Address of the publisher") - ("edition" "Edition of the book as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("Booklet" - ((("title" "Title of the booklet (BibTeX converts it to lowercase)")) - (("author" "Author1 [and Author2 ...] [and others]") - ("howpublished" "The way in which the booklet was published") - ("address" "Address of the publisher") - ("month" "Month of the publication as a string (remove braces)") - ("year" "Year of publication") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("InBook" - ((("author" "Author1 [and Author2 ...] [and others]" nil t) - ("editor" "Editor1 [and Editor2 ...] [and others]" nil t) - ("title" "Title of the book") - ("chapter" "Chapter in the book") - ("publisher" "Publishing company") - ("year" "Year of publication")) - (("volume" "Volume of the book in the series") - ("number" "Number of the book in a small series (overwritten by volume)") - ("series" "Series in which the book appeared") - ("type" "Word to use instead of \"chapter\"") - ("address" "Address of the publisher") - ("edition" "Edition of the book as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("pages" "Pages in the book") - ("note" "Remarks to be put at the end of the \\bibitem"))) - ((("author" "Author1 [and Author2 ...] [and others]" nil t) - ("editor" "Editor1 [and Editor2 ...] [and others]" nil t) - ("title" "Title of the book") - ("chapter" "Chapter in the book")) - (("pages" "Pages in the book") - ("publisher" "Publishing company") - ("year" "Year of publication") - ("volume" "Volume of the book in the series") - ("number" "Number of the book in a small series (overwritten by volume)") - ("series" "Series in which the book appeared") - ("type" "Word to use instead of \"chapter\"") - ("address" "Address of the publisher") - ("edition" "Edition of the book as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("InCollection" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the article in book (BibTeX converts it to lowercase)") - ("booktitle" "Name of the book") - ("publisher" "Publishing company") - ("year" "Year of publication")) - (("editor" "Editor1 [and Editor2 ...] [and others]") - ("volume" "Volume of the book in the series") - ("number" "Number of the book in a small series (overwritten by volume)") - ("series" "Series in which the book appeared") - ("type" "Word to use instead of \"chapter\"") - ("chapter" "Chapter in the book") - ("pages" "Pages in the book") - ("address" "Address of the publisher") - ("edition" "Edition of the book as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem"))) - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the article in book (BibTeX converts it to lowercase)") - ("booktitle" "Name of the book")) - (("pages" "Pages in the book") - ("publisher" "Publishing company") - ("year" "Year of publication") - ("editor" "Editor1 [and Editor2 ...] [and others]") - ("volume" "Volume of the book in the series") - ("number" "Number of the book in a small series (overwritten by volume)") - ("series" "Series in which the book appeared") - ("type" "Word to use instead of \"chapter\"") - ("chapter" "Chapter in the book") - ("address" "Address of the publisher") - ("edition" "Edition of the book as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("InProceedings" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)") - ("booktitle" "Name of the conference proceedings") - ("year" "Year of publication")) - (("editor" "Editor1 [and Editor2 ...] [and others]") - ("volume" "Volume of the conference proceedings in the series") - ("number" "Number of the conference proceedings in a small series (overwritten by volume)") - ("series" "Series in which the conference proceedings appeared") - ("pages" "Pages in the conference proceedings") - ("address" "Location of the Proceedings") - ("month" "Month of the publication as a string (remove braces)") - ("organization" "Sponsoring organization of the conference") - ("publisher" "Publishing company, its location") - ("note" "Remarks to be put at the end of the \\bibitem"))) - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)")) - (("booktitle" "Name of the conference proceedings") - ("pages" "Pages in the conference proceedings") - ("year" "Year of publication") - ("editor" "Editor1 [and Editor2 ...] [and others]") - ("volume" "Volume of the conference proceedings in the series") - ("number" "Number of the conference proceedings in a small series (overwritten by volume)") - ("series" "Series in which the conference proceedings appeared") - ("address" "Location of the Proceedings") - ("month" "Month of the publication as a string (remove braces)") - ("organization" "Sponsoring organization of the conference") - ("publisher" "Publishing company, its location") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("Manual" - ((("title" "Title of the manual")) - (("author" "Author1 [and Author2 ...] [and others]") - ("organization" "Publishing organization of the manual") - ("address" "Address of the organization") - ("edition" "Edition of the manual as a capitalized English word") - ("month" "Month of the publication as a string (remove braces)") - ("year" "Year of publication") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("MastersThesis" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the master\'s thesis (BibTeX converts it to lowercase)") - ("school" "School where the master\'s thesis was written") - ("year" "Year of publication")) - (("type" "Type of the master\'s thesis (if other than \"Master\'s thesis\")") - ("address" "Address of the school (if not part of field \"school\") or country") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("Misc" - (() - (("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the work (BibTeX converts it to lowercase)") - ("howpublished" "The way in which the work was published") - ("month" "Month of the publication as a string (remove braces)") - ("year" "Year of publication") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("PhdThesis" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the PhD. thesis") - ("school" "School where the PhD. thesis was written") - ("year" "Year of publication")) - (("type" "Type of the PhD. thesis") - ("address" "Address of the school (if not part of field \"school\") or country") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("Proceedings" - ((("title" "Title of the conference proceedings") - ("year" "Year of publication")) - (("booktitle" "Title of the proceedings for cross references") - ("editor" "Editor1 [and Editor2 ...] [and others]") - ("volume" "Volume of the conference proceedings in the series") - ("number" "Number of the conference proceedings in a small series (overwritten by volume)") - ("series" "Series in which the conference proceedings appeared") - ("address" "Location of the Proceedings") - ("month" "Month of the publication as a string (remove braces)") - ("organization" "Sponsoring organization of the conference") - ("publisher" "Publishing company, its location") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("TechReport" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the technical report (BibTeX converts it to lowercase)") - ("institution" "Sponsoring institution of the report") - ("year" "Year of publication")) - (("type" "Type of the report (if other than \"technical report\")") - ("number" "Number of the technical report") - ("address" "Address of the institution (if not part of field \"institution\") or country") - ("month" "Month of the publication as a string (remove braces)") - ("note" "Remarks to be put at the end of the \\bibitem")))) - ("Unpublished" - ((("author" "Author1 [and Author2 ...] [and others]") - ("title" "Title of the unpublished work (BibTeX converts it to lowercase)") - ("note" "Remarks to be put at the end of the \\bibitem")) - (("month" "Month of the publication as a string (remove braces)") - ("year" "Year of publication"))))) - - "List of BibTeX entry types and their associated fields. -List elements are triples -\(ENTRY-TYPE (REQUIRED OPTIONAL) (CROSSREF-REQUIRED CROSSREF-OPTIONAL)). -ENTRY-TYPE is the type of a BibTeX entry. The remaining pairs contain -the required and optional fields of the BibTeX entry. -The second pair is used if a crossref field is present -and the first pair is used if a crossref field is absent. -If the second pair is nil, the first pair is always used. -REQUIRED, OPTIONAL, CROSSREF-REQUIRED and CROSSREF-OPTIONAL are lists. +(define-widget 'bibtex-entry-alist 'lazy + "Format of `bibtex-BibTeX-entry-alist' and friends." + :type '(repeat (group (string :tag "Entry type") + (string :tag "Documentation") + (repeat :tag "Required fields" + (group (string :tag "Field") + (option (choice :tag "Comment" :value nil + (const nil) string)) + (option (choice :tag "Init" :value nil + (const nil) string function)) + (option (choice :tag "Alternative" :value nil + (const nil) integer)))) + (repeat :tag "Crossref fields" + (group (string :tag "Field") + (option (choice :tag "Comment" :value nil + (const nil) string)) + (option (choice :tag "Init" :value nil + (const nil) string function)) + (option (choice :tag "Alternative" :value nil + (const nil) integer)))) + (repeat :tag "Optional fields" + (group (string :tag "Field") + (option (choice :tag "Comment" :value nil + (const nil) string)) + (option (choice :tag "Init" :value nil + (const nil) string function))))))) + +(define-obsolete-variable-alias 'bibtex-entry-field-alist + 'bibtex-BibTeX-entry-alist "24.1") +(defcustom bibtex-BibTeX-entry-alist + '(("Article" "Article in Journal" + (("author") + ("title" "Title of the article (BibTeX converts it to lowercase)")) + (("journal") ("year")) + (("volume" "Volume of the journal") + ("number" "Number of the journal (only allowed if entry contains volume)") + ("pages" "Pages in the journal") + ("month") ("note"))) + ("InProceedings" "Article in Conference Proceedings" + (("author") + ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)")) + (("booktitle" "Name of the conference proceedings") + ("year")) + (("editor") + ("volume" "Volume of the conference proceedings in the series") + ("number" "Number of the conference proceedings in a small series (overwritten by volume)") + ("series" "Series in which the conference proceedings appeared") + ("pages" "Pages in the conference proceedings") + ("month") ("address") + ("organization" "Sponsoring organization of the conference") + ("publisher" "Publishing company, its location") + ("note"))) + ("InCollection" "Article in a Collection" + (("author") + ("title" "Title of the article in book (BibTeX converts it to lowercase)") + ("booktitle" "Name of the book")) + (("publisher") ("year")) + (("editor") + ("volume" "Volume of the book in the series") + ("number" "Number of the book in a small series (overwritten by volume)") + ("series" "Series in which the book appeared") + ("type" "Word to use instead of \"chapter\"") + ("chapter" "Chapter in the book") + ("pages" "Pages in the book") + ("edition" "Edition of the book as a capitalized English word") + ("month") ("address") ("note"))) + ("InBook" "Chapter or Pages in a Book" + (("author" nil nil 0) + ("editor" nil nil 0) + ("title" "Title of the book") + ("chapter" "Chapter in the book")) + (("publisher") ("year")) + (("volume" "Volume of the book in the series") + ("number" "Number of the book in a small series (overwritten by volume)") + ("series" "Series in which the book appeared") + ("type" "Word to use instead of \"chapter\"") + ("address") + ("edition" "Edition of the book as a capitalized English word") + ("month") + ("pages" "Pages in the book") + ("note"))) + ("Proceedings" "Conference Proceedings" + (("title" "Title of the conference proceedings") + ("year")) + nil + (("booktitle" "Title of the proceedings for cross references") + ("editor") + ("volume" "Volume of the conference proceedings in the series") + ("number" "Number of the conference proceedings in a small series (overwritten by volume)") + ("series" "Series in which the conference proceedings appeared") + ("address") + ("month") + ("organization" "Sponsoring organization of the conference") + ("publisher" "Publishing company, its location") + ("note"))) + ("Book" "Book" + (("author" nil nil 0) + ("editor" nil nil 0) + ("title" "Title of the book")) + (("publisher") ("year")) + (("volume" "Volume of the book in the series") + ("number" "Number of the book in a small series (overwritten by volume)") + ("series" "Series in which the book appeared") + ("address") + ("edition" "Edition of the book as a capitalized English word") + ("month") ("note"))) + ("Booklet" "Booklet (Bound, but no Publisher)" + (("title" "Title of the booklet (BibTeX converts it to lowercase)")) + nil + (("author") + ("howpublished" "The way in which the booklet was published") + ("address") ("month") ("year") ("note"))) + ("PhdThesis" "PhD. Thesis" + (("author") + ("title" "Title of the PhD. thesis") + ("school" "School where the PhD. thesis was written") + ("year")) + nil + (("type" "Type of the PhD. thesis") + ("address" "Address of the school (if not part of field \"school\") or country") + ("month") ("note"))) + ("MastersThesis" "Master's Thesis" + (("author") + ("title" "Title of the master's thesis (BibTeX converts it to lowercase)") + ("school" "School where the master's thesis was written") + ("year")) + nil + (("type" "Type of the master's thesis (if other than \"Master's thesis\")") + ("address" "Address of the school (if not part of field \"school\") or country") + ("month") ("note"))) + ("TechReport" "Technical Report" + (("author") + ("title" "Title of the technical report (BibTeX converts it to lowercase)") + ("institution" "Sponsoring institution of the report") + ("year")) + nil + (("type" "Type of the report (if other than \"technical report\")") + ("number" "Number of the technical report") + ("address") ("month") ("note"))) + ("Manual" "Technical Manual" + (("title" "Title of the manual")) + nil + (("author") + ("organization" "Publishing organization of the manual") + ("address") + ("edition" "Edition of the manual as a capitalized English word") + ("month") ("year") ("note"))) + ("Unpublished" "Unpublished" + (("author") + ("title" "Title of the unpublished work (BibTeX converts it to lowercase)") + ("note")) + nil + (("month") ("year"))) + ("Misc" "Miscellaneous" nil nil + (("author") + ("title" "Title of the work (BibTeX converts it to lowercase)") + ("howpublished" "The way in which the work was published") + ("month") ("year") ("note")))) + "Alist of BibTeX entry types and their associated fields. +Elements are lists (ENTRY-TYPE DOC REQUIRED CROSSREF OPTIONAL). +ENTRY-TYPE is the type of a BibTeX entry. +DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used. +REQUIRED is a list of required fields. +CROSSREF is a list of fields that are optional if a crossref field +is present; but these fields are required otherwise. +OPTIONAL is a list of optional fields. + Each element of these lists is a list of the form -\(FIELD-NAME COMMENT-STRING INIT ALTERNATIVE-FLAG). -COMMENT-STRING, INIT, and ALTERNATIVE-FLAG are optional. -FIELD-NAME is the name of the field, COMMENT-STRING is the comment that -appears in the echo area, INIT is either the initial content of the -field or a function, which is called to determine the initial content -of the field, and ALTERNATIVE-FLAG (either nil or t) marks if the -field is an alternative. ALTERNATIVE-FLAG may be t only in the -REQUIRED or CROSSREF-REQUIRED lists." - :group 'bibtex - :type '(repeat (group (string :tag "Entry type") - (group (repeat :tag "Required fields" - (group (string :tag "Field") - (string :tag "Comment") - (option (choice :tag "Init" :value nil - (const nil) string function)) - (option (choice :tag "Alternative" - (const :tag "No" nil) - (const :tag "Yes" t))))) - (repeat :tag "Optional fields" - (group (string :tag "Field") - (string :tag "Comment") - (option (choice :tag "Init" :value nil - (const nil) string function))))) - (option :extra-offset -4 - (group (repeat :tag "Crossref: required fields" - (group (string :tag "Field") - (string :tag "Comment") - (option (choice :tag "Init" :value nil - (const nil) string function)) - (option (choice :tag "Alternative" - (const :tag "No" nil) - (const :tag "Yes" t))))) - (repeat :tag "Crossref: optional fields" - (group (string :tag "Field") - (string :tag "Comment") - (option (choice :tag "Init" :value nil - (const nil) string function))))))))) -(put 'bibtex-entry-field-alist 'risky-local-variable t) + \(FIELD COMMENT INIT ALTERNATIVE). +COMMENT, INIT, and ALTERNATIVE are optional. + +FIELD is the name of the field. +COMMENT is the comment string that appears in the echo area. +If COMMENT is nil use `bibtex-BibTeX-field-alist' if possible. +INIT is either the initial content of the field or a function, +which is called to determine the initial content of the field. +ALTERNATIVE if non-nil is an integer that numbers sets of +alternatives, starting from zero." + :group 'BibTeX + :type 'bibtex-entry-alist) +(put 'bibtex-BibTeX-entry-alist 'risky-local-variable t) + +(defcustom bibtex-biblatex-entry-alist + ;; Compare in biblatex documentation: + ;; Sec. 2.1.1 Regular types (required and optional fields) + ;; Appendix A Default Crossref setup + '(("Article" "Article in Journal" + (("author") ("title") ("journaltitle") + ("year" nil nil 0) ("date" nil nil 0)) + nil + (("translator") ("annotator") ("commentator") ("subtitle") ("titleaddon") + ("editor") ("editora") ("editorb") ("editorc") + ("journalsubtitle") ("issuetitle") ("issuesubtitle") + ("language") ("origlanguage") ("series") ("volume") ("number") ("eid") + ("issue") ("month") ("pages") ("version") ("note") ("issn") + ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass") + ("eprinttype") ("url") ("urldate"))) + ("Book" "Single-Volume Book" + (("author") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editor") ("editora") ("editorb") ("editorc") + ("translator") ("annotator") ("commentator") + ("introduction") ("foreword") ("afterword") ("titleaddon") + ("maintitle") ("mainsubtitle") ("maintitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes") + ("series") ("number") ("note") ("publisher") ("location") ("isbn") + ("chapter") ("pages") ("pagetotal") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("MVBook" "Multi-Volume Book" + (("author") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editor") ("editora") ("editorb") ("editorc") + ("translator") ("annotator") ("commentator") + ("introduction") ("foreword") ("afterword") ("subtitle") + ("titleaddon") ("language") ("origlanguage") ("edition") ("volumes") + ("series") ("number") ("note") ("publisher") + ("location") ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("InBook" "Chapter or Pages in a Book" + (("title") ("year" nil nil 0) ("date" nil nil 0)) + (("author") ("booktitle")) + (("bookauthor") ("editor") ("editora") ("editorb") ("editorc") + ("translator") ("annotator") ("commentator") ("introduction") ("foreword") + ("afterword") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes") + ("series") ("number") ("note") ("publisher") ("location") ("isbn") + ("chapter") ("pages") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("BookInBook" "Book in Collection" ; same as @inbook + (("title") ("year" nil nil 0) ("date" nil nil 0)) + (("author") ("booktitle")) + (("bookauthor") ("editor") ("editora") ("editorb") ("editorc") + ("translator") ("annotator") ("commentator") ("introduction") ("foreword") + ("afterword") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes") + ("series") ("number") ("note") ("publisher") ("location") ("isbn") + ("chapter") ("pages") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("SuppBook" "Supplemental Material in a Book" ; same as @inbook + (("title") ("year" nil nil 0) ("date" nil nil 0)) + (("author") ("booktitle")) + (("bookauthor") ("editor") ("editora") ("editorb") ("editorc") + ("translator") ("annotator") ("commentator") ("introduction") ("foreword") + ("afterword") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes") + ("series") ("number") ("note") ("publisher") ("location") ("isbn") + ("chapter") ("pages") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Booklet" "Booklet (Bound, but no Publisher)" + (("author" nil nil 0) ("editor" nil nil 0) ("title") + ("year" nil nil 1) ("date" nil nil 1)) + nil + (("subtitle") ("titleaddon") ("language") ("howpublished") ("type") + ("note") ("location") ("chapter") ("pages") ("pagetotal") ("addendum") + ("pubstate") ("doi") ("eprint") ("eprintclass") ("eprinttype") + ("url") ("urldate"))) + ("Collection" "Single-Volume Collection" + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("language") ("origlanguage") ("volume") + ("part") ("edition") ("volumes") ("series") ("number") ("note") + ("publisher") ("location") ("isbn") ("chapter") ("pages") ("pagetotal") + ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass") + ("eprinttype") ("url") ("urldate"))) + ("MVCollection" "Multi-Volume Collection" + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("language") ("origlanguage") ("edition") + ("volumes") ("series") ("number") ("note") ("publisher") + ("location") ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("InCollection" "Article in a Collection" + (("author") ("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + (("booktitle")) + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") + ("volumes") ("series") ("number") ("note") ("publisher") ("location") + ("isbn") ("chapter") ("pages") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("SuppCollection" "Supplemental Material in a Collection" ; same as @incollection + (("author") ("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + (("booktitle")) + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") + ("volumes") ("series") ("number") ("note") ("publisher") ("location") + ("isbn") ("chapter") ("pages") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Manual" "Technical Manual" + (("author" nil nil 0) ("editor" nil nil 0) ("title") + ("year" nil nil 1) ("date" nil nil 1)) + nil + (("subtitle") ("titleaddon") ("language") ("edition") + ("type") ("series") ("number") ("version") ("note") + ("organization") ("publisher") ("location") ("isbn") ("chapter") + ("pages") ("pagetotal") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Misc" "Miscellaneous" + (("author" nil nil 0) ("editor" nil nil 0) ("title") + ("year" nil nil 1) ("date" nil nil 1)) + nil + (("subtitle") ("titleaddon") ("language") ("howpublished") ("type") + ("version") ("note") ("organization") ("location") + ("date") ("month") ("year") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Online" "Online Resource" + (("author" nil nil 0) ("editor" nil nil 0) ("title") + ("year" nil nil 1) ("date" nil nil 1) ("url")) + nil + (("subtitle") ("titleaddon") ("language") ("version") ("note") + ("organization") ("date") ("month") ("year") ("addendum") + ("pubstate") ("urldate"))) + ("Patent" "Patent" + (("author") ("title") ("number") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("holder") ("subtitle") ("titleaddon") ("type") ("version") ("location") + ("note") ("date") ("month") ("year") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Periodical" "Complete Issue of a Periodical" + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editora") ("editorb") ("editorc") ("subtitle") ("issuetitle") + ("issuesubtitle") ("language") ("series") ("volume") ("number") ("issue") + ("date") ("month") ("year") ("note") ("issn") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("SuppPeriodical" "Supplemental Material in a Periodical" ; same as @article + (("author") ("title") ("journaltitle") + ("year" nil nil 0) ("date" nil nil 0)) + nil + (("translator") ("annotator") ("commentator") ("subtitle") ("titleaddon") + ("editor") ("editora") ("editorb") ("editorc") + ("journalsubtitle") ("issuetitle") ("issuesubtitle") + ("language") ("origlanguage") ("series") ("volume") ("number") ("eid") + ("issue") ("month") ("pages") ("version") ("note") ("issn") + ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass") + ("eprinttype") ("url") ("urldate"))) + ("Proceedings" "Single-Volume Conference Proceedings" + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("eventtitle") ("eventdate") ("venue") ("language") + ("volume") ("part") ("volumes") ("series") ("number") ("note") + ("organization") ("publisher") ("location") ("month") + ("isbn") ("chapter") ("pages") ("pagetotal") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("MVProceedings" "Multi-Volume Conference Proceedings" + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("subtitle") ("titleaddon") ("eventtitle") ("eventdate") ("venue") + ("language") ("volumes") ("series") ("number") ("note") + ("organization") ("publisher") ("location") ("month") + ("isbn") ("pagetotal") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("InProceedings" "Article in Conference Proceedings" + (("author") ("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + (("booktitle")) + (("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("eventtitle") ("eventdate") ("venue") ("language") + ("volume") ("part") ("volumes") ("series") ("number") ("note") + ("organization") ("publisher") ("location") ("month") ("isbn") + ("chapter") ("pages") ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Reference" "Single-Volume Work of Reference" ; same as @collection + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("language") ("origlanguage") ("volume") + ("part") ("edition") ("volumes") ("series") ("number") ("note") + ("publisher") ("location") ("isbn") ("chapter") ("pages") ("pagetotal") + ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass") + ("eprinttype") ("url") ("urldate"))) + ("MVReference" "Multi-Volume Work of Reference" ; same as @mvcollection + (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("language") ("origlanguage") ("edition") + ("volumes") ("series") ("number") ("note") ("publisher") + ("location") ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("InReference" "Article in a Work of Reference" ; same as @incollection + (("author") ("editor") ("title") ("year" nil nil 0) ("date" nil nil 0)) + (("booktitle")) + (("editora") ("editorb") ("editorc") ("translator") ("annotator") + ("commentator") ("introduction") ("foreword") ("afterword") + ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle") + ("maintitleaddon") ("booksubtitle") ("booktitleaddon") + ("language") ("origlanguage") ("volume") ("part") ("edition") + ("volumes") ("series") ("number") ("note") ("publisher") ("location") + ("isbn") ("chapter") ("pages") ("addendum") ("pubstate") ("doi") + ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Report" "Technical or Research Report" + (("author") ("title") ("type") ("institution") + ("year" nil nil 0) ("date" nil nil 0)) + nil + (("subtitle") ("titleaddon") ("language") ("number") ("version") ("note") + ("location") ("month") ("isrn") ("chapter") ("pages") ("pagetotal") + ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Thesis" "PhD. or Master's Thesis" + (("author") ("title") ("type") ("institution") + ("year" nil nil 0) ("date" nil nil 0)) + nil + (("subtitle") ("titleaddon") ("language") ("note") ("location") + ("month") ("isbn") ("chapter") ("pages") ("pagetotal") + ("addendum") ("pubstate") + ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate"))) + ("Unpublished" "Unpublished" + (("author") ("title") ("year" nil nil 0) ("date" nil nil 0)) + nil + (("subtitle") ("titleaddon") ("language") ("howpublished") + ("note") ("location") ("isbn") ("date") ("month") ("year") + ("addendum") ("pubstate") ("url") ("urldate")))) + "Alist of biblatex entry types and their associated fields. +It has the same format as `bibtex-BibTeX-entry-alist'." + :group 'bibtex + :type 'bibtex-entry-alist) +(put 'bibtex-biblatex-entry-alist 'risky-local-variable t) + +(define-widget 'bibtex-field-alist 'lazy + "Format of `bibtex-BibTeX-entry-alist' and friends." + :type '(repeat (group (string :tag "Field type") + (string :tag "Comment")))) + +(defcustom bibtex-BibTeX-field-alist + '(("author" "Author1 [and Author2 ...] [and others]") + ("editor" "Editor1 [and Editor2 ...] [and others]") + ("journal" "Name of the journal (use string, remove braces)") + ("year" "Year of publication") + ("month" "Month of the publication as a string (remove braces)") + ("note" "Remarks to be put at the end of the \\bibitem") + ("publisher" "Publishing company") + ("address" "Address of the publisher")) + "Alist of BibTeX fields. +Each element is a list (FIELD COMMENT). COMMENT is used as a default +if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD." + :group 'bibtex + :type 'bibtex-field-alist) + +(defcustom bibtex-biblatex-field-alist + ;; See 2.2.2 Data Fields + '(("abstract" "Abstract of the work") + ("addendum" "Miscellaneous bibliographic data") + ("afterword" "Author(s) of an afterword to the work") + ("annotation" "Annotation") + ("annotator" "Author(s) of annotations to the work") + ("author" "Author(s) of the title") + ("bookauthor" "Author(s) of the booktitle.") + ("bookpagination" "Pagination scheme of the enclosing work") + ("booksubtitle" "Subtitle related to the booktitle") + ("booktitle" "Title of the book") + ("booktitleaddon" "Annex to the booktitle") + ("chapter" "Chapter, section, or any other unit of a work") + ("commentator" "Author(s) of a commentary to the work") + ("date" "Publication date") + ("doi" "Digital Object Identifier") + ("edition" "Edition of a printed publication") + ("editor" "Editor(s) of the title, booktitle, or maintitle") + ("editora" "Secondary editor") + ("editorb" "Secondary editor") + ("editorc" "Secondary editor") + ("editortype" "Type of editorial role performed by the editor") + ("editoratype" "Type of editorial role performed by editora") + ("editorbtype" "Type of editorial role performed by editorb") + ("editorctype" "Type of editorial role performed by editorc") + ("eid" "Electronic identifier of an article") + ("eprint" "Electronic identifier of an online publication") + ("eprintclass" "Additional information related to the eprinttype") + ("eprinttype" "Type of eprint identifier") + ("eventdate" "Date of a conference or some other event") + ("eventtitle" "Title of a conference or some other event") + ("file" "Local link to an electronic version of the work") + ("foreword" "Author(s) of a foreword to the work") + ("holder" "Holder(s) of a patent") + ("howpublished" "Publication notice for unusual publications") + ("indextitle" "Title to use for indexing instead of the regular title") + ("institution" "Name of a university or some other institution") + ("introduction" "Author(s) of an introduction to the work") + ("isan" "International Standard Audiovisual Number of an audiovisual work") + ("isbn" "International Standard Book Number of a book.") + ("ismn" "International Standard Music Number for printed music") + ("isrn" "International Standard Technical Report Number") + ("issn" "International Standard Serial Number of a periodical.") + ("issue" "Issue of a journal") + ("issuesubtitle" "Subtitle of a specific issue of a journal or other periodical.") + ("issuetitle" "Title of a specific issue of a journal or other periodical.") + ("iswc" "International Standard Work Code of a musical work") + ("journalsubtitle" "Subtitle of a journal, a newspaper, or some other periodical.") + ("journaltitle" "Name of a journal, a newspaper, or some other periodical.") + ("label" "Substitute for the regular label to be used by the citation style") + ("language" "Language(s) of the work") + ("library" "Library name and a call number") + ("location" "Place(s) of publication") + ("mainsubtitle" "Subtitle related to the maintitle") + ("maintitle" "Main title of a multi-volume book, such as Collected Works") + ("maintitleaddon" "Annex to the maintitle") + ("month" "Publication month") + ("nameaddon" "Addon to be printed immediately after the author name") + ("note" "Miscellaneous bibliographic data") + ("number" "Number of a journal or the volume/number of a book in a series") + ("organization" "Organization(s) that published a work") + ("origdate" "Publication date of the original edition") + ("origlanguage" "Original publication language of a translated edition") + ("origlocation" "Location of the original edition") + ("origpublisher" "Publisher of the original edition") + ("origtitle" "Title of the original work") + ("pages" "Page number(s) or page range(s)") + ("pagetotal" "Total number of pages of the work.") + ("pagination" "Pagination of the work") + ("part" "Number of a partial volume") + ("publisher" "Name(s) of the publisher(s)") + ("pubstate" "Publication state of the work, e. g.,'in press'") + ("reprinttitle" "Title of a reprint of the work") + ("series" "Name of a publication series") + ("shortauthor" "Author(s) of the work, given in an abbreviated form") + ("shorteditor" "Editor(s) of the work, given in an abbreviated form") + ("shortjournal" "Short version or an acronym of the journal title") + ("shortseries" "Short version or an acronym of the series field") + ("shorttitle" "Title in an abridged form") + ("subtitle" "Subtitle of the work") + ("title" "Title of the work") + ("titleaddon" "Annex to the title") + ("translator" "Translator(s) of the work") + ("type" "Type of a manual, patent, report, or thesis") + ("url" " URL of an online publication.") + ("urldate" "Access date of the address specified in the url field") + ("venue" "Location of a conference, a symposium, or some other event") + ("version" "Revision number of a piece of software, a manual, etc.") + ("volume" "Volume of a multi-volume book or a periodical") + ("volumes" "Total number of volumes of a multi-volume work") + ("year" "Year of publication")) + "Alist of biblatex fields. +It has the same format as `bibtex-BibTeX-entry-alist'." + :group 'bibtex + :type 'bibtex-field-alist) + +(defcustom bibtex-dialect-list '(BibTeX biblatex) + "List of BibTeX dialects known to BibTeX mode. +For each DIALECT (a symbol) a variable bibtex-DIALECT-entry-alist defines +the allowed entries and bibtex-DIALECT-field-alist defines known field types. +Predefined dialects include BibTeX and biblatex." + :group 'bibtex + :type '(repeat (symbol :tag "Dialect"))) + +(defcustom bibtex-dialect 'BibTeX + "Current BibTeX dialect. For allowed values see `bibtex-dialect-list'. +During a session change it via `bibtex-set-dialect'." + :group 'bibtex + :set '(lambda (symbol value) + (set-default symbol value) + ;; `bibtex-set-dialect' is undefined during loading (no problem) + (if (fboundp 'bibtex-set-dialect) + (bibtex-set-dialect value))) + :type '(choice (const BibTeX) + (const biblatex) + (symbol :tag "Custom"))) + +(defcustom bibtex-no-opt-remove-re "\\`option" + "If a field name matches this regexp, the prefix OPT is not removed. +If nil prefix OPT is always removed" + :group 'bibtex + :type '(choice (regexp) (const nil))) (defcustom bibtex-comment-start "@Comment" "String starting a BibTeX comment." @@ -1120,29 +1439,15 @@ ["(Re)Initialize BibTeX Buffers" bibtex-initialize t] ["Validate Entries" bibtex-validate-globally t]))) -(easy-menu-define - bibtex-entry-menu bibtex-mode-map "Entry-Types Menu in BibTeX mode" - (list "Entry-Types" - ["Article in Journal" bibtex-Article t] - ["Article in Conference Proceedings" bibtex-InProceedings t] - ["Article in a Collection" bibtex-InCollection t] - ["Chapter or Pages in a Book" bibtex-InBook t] - ["Conference Proceedings" bibtex-Proceedings t] - ["Book" bibtex-Book t] - ["Booklet (Bound, but no Publisher/Institution)" bibtex-Booklet t] - ["PhD. Thesis" bibtex-PhdThesis t] - ["Master's Thesis" bibtex-MastersThesis t] - ["Technical Report" bibtex-TechReport t] - ["Technical Manual" bibtex-Manual t] - ["Unpublished" bibtex-Unpublished t] - ["Miscellaneous" bibtex-Misc t] - "--" - ["String" bibtex-String t] - ["Preamble" bibtex-Preamble t])) - ;; Internal Variables +(defvar bibtex-entry-alist bibtex-BibTeX-entry-alist + "Alist of currently active entry types.") + +(defvar bibtex-field-alist bibtex-BibTeX-field-alist + "Alist of currently active field types.") + (defvar bibtex-field-braces-opt nil "Optimized value of `bibtex-field-braces-alist'. Created by `bibtex-field-re-init'. @@ -1237,33 +1542,26 @@ (defconst bibtex-field-const "[][[:alnum:].:;?!`'/*@+=|<>&_^$-]+" "Regexp matching a BibTeX field constant.") -(defvar bibtex-entry-type - (concat "@[ \t]*\\(?:" - (regexp-opt (mapcar 'car bibtex-entry-field-alist)) "\\)") - "Regexp matching the type of a BibTeX entry.") - -(defvar bibtex-entry-head - (concat "^[ \t]*\\(" - bibtex-entry-type - "\\)[ \t]*[({][ \t\n]*\\(" - bibtex-reference-key - "\\)") - "Regexp matching the header line of a BibTeX entry (including key).") - -(defvar bibtex-entry-maybe-empty-head - (concat bibtex-entry-head "?") - "Regexp matching the header line of a BibTeX entry (possibly without key).") +(defvar bibtex-entry-type nil + "Regexp matching the type of a BibTeX entry. +Initialized by `bibtex-set-dialect'.") + +(defvar bibtex-entry-head nil + "Regexp matching the header line of a BibTeX entry (including key). +Initialized by `bibtex-set-dialect'.") + +(defvar bibtex-entry-maybe-empty-head nil + "Regexp matching the header line of a BibTeX entry (possibly without key). +Initialized by `bibtex-set-dialect'.") (defconst bibtex-any-entry-maybe-empty-head (concat "^[ \t]*\\(@[ \t]*" bibtex-field-name "\\)[ \t]*[({][ \t\n]*\\(" bibtex-reference-key "\\)?") "Regexp matching the header line of any BibTeX entry (possibly without key).") -(defvar bibtex-any-valid-entry-type - (concat "^[ \t]*@[ \t]*\\(?:" - (regexp-opt (append '("String" "Preamble") - (mapcar 'car bibtex-entry-field-alist))) "\\)") - "Regexp matching any valid BibTeX entry (including String and Preamble).") +(defvar bibtex-any-valid-entry-type nil + "Regexp matching any valid BibTeX entry (including String and Preamble). +Initialized by `bibtex-set-dialect'.") (defconst bibtex-type-in-head 1 "Regexp subexpression number of the type part in `bibtex-entry-head'.") @@ -1520,7 +1818,9 @@ (bibtex-start-of-name-in-field bounds) (bibtex-end-of-name-in-field bounds)))) (if (and remove-opt-alt - (string-match "\\`\\(OPT\\|ALT\\)" name)) + (string-match "\\`\\(OPT\\|ALT\\)" name) + (not (and bibtex-no-opt-remove-re + (string-match bibtex-no-opt-remove-re name)))) (substring name 3) name))) @@ -1686,7 +1986,7 @@ (defun bibtex-valid-entry (&optional empty-key) "Parse a valid BibTeX entry (maybe without key if EMPTY-KEY is t). A valid entry is a syntactical correct one with type contained in -`bibtex-entry-field-alist'. Ignore @String and @Preamble entries. +`bibtex-BibTeX-entry-alist'. Ignore @String and @Preamble entries. Return a cons pair with buffer positions of beginning and end of entry if a valid entry is found, nil otherwise. Do not move point. After a call to this function `match-data' corresponds to the header @@ -1717,7 +2017,7 @@ Do not move if we are already at beginning of a valid BibTeX entry. With optional argument BACKWARD non-nil, move backward to beginning of previous valid one. A valid entry is a syntactical correct one -with type contained in `bibtex-entry-field-alist' or, if +with type contained in `bibtex-BibTeX-entry-alist' or, if `bibtex-sort-ignore-string-entries' is nil, a syntactical correct string entry. Return buffer position of beginning and end of entry if a valid entry is found, nil otherwise." @@ -1911,6 +2211,14 @@ (let ((key (bibtex-key-in-head))) (if key (push (cons key t) bibtex-reference-keys)))))))) +(defsubst bibtex-vec-push (vec idx newelt) + "Add NEWELT to the list stored in VEC at index IDX." + (aset vec idx (cons newelt (aref vec idx)))) + +(defsubst bibtex-vec-incr (vec idx) + "Add NEWELT to the list stored in VEC at index IDX." + (aset vec idx (1+ (aref vec idx)))) + (defun bibtex-format-entry () "Helper function for `bibtex-clean-entry'. Formats current entry according to variable `bibtex-entry-format'." @@ -1932,7 +2240,7 @@ bibtex-entry-format)) (left-delim-re (regexp-quote (bibtex-field-left-delimiter))) bounds crossref-key req-field-list default-field-list field-list - alt-fields error-field-name) + num-alt alt-fields idx error-field-name) (unwind-protect ;; formatting (undone if error occurs) (atomic-change-group @@ -1954,7 +2262,7 @@ (end-type (match-end 0)) (entry-list (assoc-string (buffer-substring-no-properties beg-type end-type) - bibtex-entry-field-alist t))) + bibtex-entry-alist t))) ;; unify case of entry type (when (memq 'unify-case format) @@ -1978,13 +2286,18 @@ ;; list of required fields appropriate for an entry with ;; or without crossref key. - (setq req-field-list (if (and crossref-key (nth 2 entry-list)) - (car (nth 2 entry-list)) - (car (nth 1 entry-list))) + (setq req-field-list (if crossref-key (nth 2 entry-list) + (append (nth 2 entry-list) (nth 3 entry-list))) ;; default list of fields that may appear in this entry - default-field-list (append (nth 0 (nth 1 entry-list)) - (nth 1 (nth 1 entry-list)) - bibtex-user-optional-fields)) + default-field-list (append (nth 2 entry-list) (nth 3 entry-list) + (nth 4 entry-list) + bibtex-user-optional-fields) + ;; number of ALT fields we expect to find + num-alt (length (delq nil (delete-dups + (mapcar (lambda (x) (nth 3 x)) + req-field-list)))) + ;; ALT fields of respective groups + alt-fields (make-vector num-alt nil)) (when (memq 'sort-fields format) (goto-char (point-min)) @@ -1995,10 +2308,10 @@ (dolist (field default-field-list) (when (setq elt (assoc-string (car field) fields-alist t)) (setq fields-alist (delete elt fields-alist)) - (bibtex-make-field (list (car elt) "" (cdr elt)) nil nil t))) + (bibtex-make-field (list (car elt) nil (cdr elt)) nil nil t))) (dolist (field fields-alist) (unless (member (car field) '("=key=" "=type=")) - (bibtex-make-field (list (car field) "" (cdr field)) nil nil t)))))) + (bibtex-make-field (list (car field) nil (cdr field)) nil nil t)))))) ;; process all fields (bibtex-beginning-first-field (point-min)) @@ -2009,17 +2322,18 @@ (end-name (copy-marker (bibtex-end-of-name-in-field bounds))) (beg-text (copy-marker (bibtex-start-of-text-in-field bounds))) (end-text (copy-marker (bibtex-end-of-text-in-field bounds) t)) - (opt-alt (string-match "OPT\\|ALT" - (buffer-substring-no-properties - beg-name (+ beg-name 3)))) - (field-name (buffer-substring-no-properties - (if opt-alt (+ beg-name 3) beg-name) end-name)) (empty-field (equal "" (bibtex-text-in-field-bounds bounds t))) + (field-name (buffer-substring-no-properties beg-name end-name)) + (opt-alt (and (string-match "\\`\\(OPT\\|ALT\\)" field-name) + (not (and bibtex-no-opt-remove-re + (string-match bibtex-no-opt-remove-re + field-name))))) deleted) + (if opt-alt (setq field-name (substring field-name 3))) ;; keep track of alternatives - (if (nth 3 (assoc-string field-name req-field-list t)) - (push field-name alt-fields)) + (if (setq idx (nth 3 (assoc-string field-name req-field-list t))) + (bibtex-vec-push alt-fields idx field-name)) (if (memq 'opts-or-alts format) ;; delete empty optional and alternative fields @@ -2170,12 +2484,14 @@ ;; check whether all required fields are present (if (memq 'required-fields format) - (let ((found 0) alt-list) + (let ((alt-expect (make-vector num-alt nil)) + (alt-found (make-vector num-alt 0))) (dolist (fname req-field-list) - (cond ((nth 3 fname) ; t if field has alternative flag - (push (car fname) alt-list) + (cond ((setq idx (nth 3 fname)) + ;; t if field has alternative flag + (bibtex-vec-push alt-expect idx (car fname)) (if (member-ignore-case (car fname) field-list) - (setq found (1+ found)))) + (bibtex-vec-incr alt-found idx))) ((not (member-ignore-case (car fname) field-list)) ;; If we use the crossref field, a required field ;; can have the OPT prefix. So if it was empty, @@ -2183,17 +2499,16 @@ ;; move point on this empty field. (setq error-field-name (car fname)) (error "Mandatory field `%s' is missing" (car fname))))) - (if alt-list - (cond ((= found 0) - (if alt-fields - (setq error-field-name (car (last alt-fields)))) - (error "Alternative mandatory field `%s' is missing" - alt-list)) - ((> found 1) - (if alt-fields - (setq error-field-name (car (last alt-fields)))) - (error "Alternative fields `%s' are defined %s times" - alt-list found)))))) + (dotimes (idx num-alt) + (cond ((= 0 (aref alt-found idx)) + (setq error-field-name (car (last (aref alt-fields idx)))) + (error "Alternative mandatory field `%s' is missing" + (aref alt-expect idx))) + ((< 1 (aref alt-found idx)) + (setq error-field-name (car (last (aref alt-fields idx)))) + (error "Alternative fields `%s' are defined %s times" + (aref alt-expect idx) + (length (aref alt-fields idx)))))))) ;; update comma after last field (if (memq 'last-comma format) @@ -2547,7 +2862,7 @@ (push (list key) crossref-keys)))) ;; only keys of known entries ((assoc-string (bibtex-type-in-head) - bibtex-entry-field-alist t) + bibtex-entry-alist t) ;; This is an entry. (let ((key (bibtex-key-in-head))) (unless (assoc key ref-keys) @@ -3056,25 +3371,122 @@ bibtex-font-lock-syntactic-keywords)) (setq imenu-generic-expression (list (list nil bibtex-entry-head bibtex-key-in-head)) - imenu-case-fold-search t)) + imenu-case-fold-search t) + (bibtex-set-dialect bibtex-dialect)) + +(defun bibtex-set-dialect (dialect) + "Select BibTeX mode DIALECT. +This sets the variable `bibtex-dialect' which holds the currently active +dialect. Dialects are listed in `bibtex-dialect-list'." + (interactive (list (intern (completing-read "Dialect: " + (mapcar 'list bibtex-dialect-list) + nil t)))) + (unless (eq dialect (get 'bibtex-dialect 'dialect)) + (put 'bibtex-dialect 'dialect dialect) + (setq bibtex-dialect dialect) + + ;; Bind variables + (setq bibtex-entry-alist + (let ((var (intern (format "bibtex-%s-entry-alist" dialect))) + entry-alist) + (if (boundp var) + (setq entry-alist (symbol-value var)) + (error "BibTeX dialect `%s' undefined" dialect)) + (if (not (consp (nth 1 (car entry-alist)))) + ;; new format + entry-alist + ;; Convert old format + (unless (get var 'entry-list-format) + (put var 'entry-list-format "pre-24") + (message "Old format of `%s' (pre GNU Emacs 24). +Please convert to the new format." + (if (eq (indirect-variable 'bibtex-entry-field-alist) var) + 'bibtex-entry-field-alist var)) + (sit-for 3)) + (let (lst) + (dolist (entry entry-alist) + (let ((fl (nth 1 entry)) req xref opt) + (dolist (field (copy-tree (car fl))) + (if (nth 3 field) (setcar (nthcdr 3 field) 0)) + (if (or (not (nth 2 entry)) + (assoc-string (car field) (car (nth 2 entry)) t)) + (push field req) + (push field xref))) + (dolist (field (nth 1 fl)) + (push field opt)) + (push (list (car entry) nil (nreverse req) + (nreverse xref) (nreverse opt)) + lst))) + (nreverse lst)))) + bibtex-field-alist + (let ((var (intern (format "bibtex-%s-field-alist" dialect)))) + (if (boundp var) + (symbol-value var) + (error "Field types for BibTeX dialect `%s' undefined" dialect))) + bibtex-entry-type + (concat "@[ \t]*\\(?:" + (regexp-opt (mapcar 'car bibtex-entry-alist)) "\\)") + bibtex-entry-head (concat "^[ \t]*\\(" + bibtex-entry-type + "\\)[ \t]*[({][ \t\n]*\\(" + bibtex-reference-key + "\\)") + bibtex-entry-maybe-empty-head (concat bibtex-entry-head "?") + bibtex-any-valid-entry-type + (concat "^[ \t]*@[ \t]*\\(?:" + (regexp-opt (append '("String" "Preamble") + (mapcar 'car bibtex-entry-alist))) "\\)")) + ;; Define entry commands + (dolist (elt bibtex-entry-alist) + (let* ((entry (car elt)) + (fname (intern (concat "bibtex-" entry)))) + (unless (fboundp fname) + (eval (list 'defun fname nil + (format "Insert a new BibTeX @%s entry; see also `bibtex-entry'." + entry) + '(interactive "*") + `(bibtex-entry ,entry)))))) + ;; Define menu + ;; We use the same keymap for all BibTeX buffers. So all these buffers + ;; have the same BibTeX dialect. To define entry types buffer-locally, + ;; it would be necessary to give each BibTeX buffer a new keymap that + ;; becomes a child of `bibtex-mode-map'. Useful?? + (easy-menu-define + nil bibtex-mode-map "Entry-Types Menu in BibTeX mode" + (apply 'list "Entry-Types" + (append + (mapcar (lambda (entry) + (vector (or (nth 1 entry) (car entry)) + (intern (format "bibtex-%s" (car entry))) t)) + bibtex-entry-alist) + `("---" + ["String" bibtex-String t] + ["Preamble" bibtex-Preamble t] + "---" + ,(append '("BibTeX dialect") + (mapcar (lambda (dialect) + (vector (symbol-name dialect) + `(lambda () (interactive) + (bibtex-set-dialect ',dialect)) + t)) + bibtex-dialect-list)))))))) (defun bibtex-field-list (entry-type) "Return list of allowed fields for entry ENTRY-TYPE. More specifically, the return value is a cons pair (REQUIRED . OPTIONAL), where REQUIRED and OPTIONAL are lists of the required and optional field -names for ENTRY-TYPE according to `bibtex-entry-field-alist', +names for ENTRY-TYPE according to `bibtex-BibTeX-entry-alist' and friends, `bibtex-include-OPTkey', `bibtex-include-OPTcrossref', and `bibtex-user-optional-fields'." - (let ((e (assoc-string entry-type bibtex-entry-field-alist t)) + (let ((e-list (assoc-string entry-type bibtex-entry-alist t)) required optional) - (unless e + (unless e-list (error "Fields for BibTeX entry type %s not defined" entry-type)) - (if (and (member-ignore-case entry-type bibtex-include-OPTcrossref) - (nth 2 e)) - (setq required (nth 0 (nth 2 e)) - optional (nth 1 (nth 2 e))) - (setq required (nth 0 (nth 1 e)) - optional (nth 1 (nth 1 e)))) + (if (member-ignore-case entry-type bibtex-include-OPTcrossref) + (setq required (nth 2 e-list) + optional (append (nth 3 e-list) (nth 4 e-list))) + (setq required (append (nth 2 e-list) (nth 3 e-list)) + optional (nth 4 e-list))) (if bibtex-include-OPTkey (push (list "key" "Used for reference key creation if author and editor fields are missing" @@ -3094,7 +3506,7 @@ is non-nil." (interactive (let ((completion-ignore-case t)) - (list (completing-read "Entry Type: " bibtex-entry-field-alist + (list (completing-read "Entry Type: " bibtex-entry-alist nil t nil 'bibtex-entry-type-history)))) (let ((key (if bibtex-maintain-sorted-entries (bibtex-read-key (format "%s key: " entry-type)))) @@ -3127,7 +3539,7 @@ (interactive (list (if current-prefix-arg (let ((completion-ignore-case t)) - (completing-read "New entry type: " bibtex-entry-field-alist + (completing-read "New entry type: " bibtex-entry-alist nil t nil 'bibtex-entry-type-history))))) (save-excursion (bibtex-beginning-of-entry) @@ -3264,14 +3676,16 @@ (field-list (bibtex-field-list type)) (comment (assoc-string field (append (car field-list) (cdr field-list)) t))) - (if comment (message "%s" (nth 1 comment)) - (message "No comment available"))))) + (message "%s" (cond ((nth 1 comment) (nth 1 comment)) + ((setq comment (assoc-string field bibtex-field-alist t)) + (nth 1 comment)) + (t "No comment available")))))) (defun bibtex-make-field (field &optional move interactive nodelim) "Make a field named FIELD in current BibTeX entry. FIELD is either a string or a list of the form \(FIELD-NAME COMMENT-STRING INIT ALTERNATIVE-FLAG) as in -`bibtex-entry-field-alist'. +`bibtex-BibTeX-entry-alist' and friends. If MOVE is non-nil, move point past the present field before making the new field. If INTERACTIVE is non-nil, move point to the end of the new field. Otherwise move point past the new field. @@ -3296,6 +3710,8 @@ (forward-char))) (insert ",\n") (indent-to-column (+ bibtex-entry-offset bibtex-field-indentation)) + ;; If there are multiple sets of alternatives, we could use + ;; the numeric value of (nth 3 field) to number these sets. Useful?? (if (nth 3 field) (insert "ALT")) (insert (car field) " ") (if bibtex-align-at-equal-sign @@ -3794,14 +4210,22 @@ "Checking required fields and month fields") (let ((bibtex-sort-ignore-string-entries t)) (bibtex-map-entries - (lambda (_key beg _end) + (lambda (_key beg end) (bibtex-progress-message) - (let* ((entry-list (assoc-string (bibtex-type-in-head) - bibtex-entry-field-alist t)) - (req (copy-sequence (elt (elt entry-list 1) 0))) - (creq (copy-sequence (elt (elt entry-list 2) 0))) - crossref-there bounds alt-there field) - (bibtex-beginning-first-field beg) + (bibtex-beginning-first-field beg) + (let* ((beg-line (save-excursion (goto-char beg) + (bibtex-current-line))) + (entry-list (assoc-string (bibtex-type-in-head) + bibtex-entry-alist t)) + (crossref (bibtex-search-forward-field "crossref" end)) + (req (if crossref (copy-sequence (nth 2 entry-list)) + (append (nth 2 entry-list) + (copy-sequence (nth 3 entry-list))))) + (num-alt (length (delq nil (delete-dups + (mapcar (lambda (x) (nth 3 x)) + req))))) + (alt-fields (make-vector num-alt nil)) + bounds field idx) (while (setq bounds (bibtex-parse-field)) (let ((field-name (bibtex-name-in-field bounds))) (if (and (bibtex-string= field-name "month") @@ -3815,36 +4239,28 @@ "Questionable month field") error-list)) (setq field (assoc-string field-name req t) - req (delete field req) - creq (delete (assoc-string field-name creq t) creq)) - (if (nth 3 field) - (if alt-there + req (delete field req)) + (if (setq idx (nth 3 field)) + (if (aref alt-fields idx) (push (cons (bibtex-current-line) "More than one non-empty alternative") error-list) - (setq alt-there t))) - (if (bibtex-string= field-name "crossref") - (setq crossref-there t))) + (aset alt-fields idx t)))) (goto-char (bibtex-end-of-field bounds))) - (if crossref-there (setq req creq)) - (let (alt) - (dolist (field req) - (if (nth 3 field) - (push (car field) alt) - (push (cons (save-excursion (goto-char beg) - (bibtex-current-line)) + (let ((alt-expect (make-vector num-alt nil))) + (dolist (field req) ; absent required fields + (if (setq idx (nth 3 field)) + (bibtex-vec-push alt-expect idx (car field)) + (push (cons beg-line (format "Required field `%s' missing" (car field))) error-list))) - ;; The following fails if there are more than two - ;; alternatives in a BibTeX entry, which isn't - ;; the case momentarily. - (if (cdr alt) - (push (cons (save-excursion (goto-char beg) - (bibtex-current-line)) - (format "Alternative fields `%s'/`%s' missing" - (car alt) (cadr alt))) - error-list))))))) + (dotimes (idx num-alt) + (unless (aref alt-fields idx) + (push (cons beg-line + (format "Alternative fields `%s' missing" + (aref alt-expect idx))) + error-list)))))))) (bibtex-progress-message 'done))))) (if error-list @@ -3890,7 +4306,7 @@ (setq entry-type (bibtex-type-in-head) key (bibtex-key-in-head)) (if (or (and strings (bibtex-string= entry-type "string")) - (assoc-string entry-type bibtex-entry-field-alist t)) + (assoc-string entry-type bibtex-entry-alist t)) (if (member key key-list) (push (format "%s:%d: Duplicate key `%s'\n" (buffer-file-name) @@ -4057,7 +4473,13 @@ (bounds (bibtex-enclosing-field comma))) (save-excursion (goto-char (bibtex-start-of-name-in-field bounds)) - (when (looking-at "OPT\\|ALT") + (when (and (looking-at "OPT\\|ALT") + (not (and bibtex-no-opt-remove-re + (string-match + bibtex-no-opt-remove-re + (buffer-substring-no-properties + (bibtex-start-of-name-in-field bounds) + (bibtex-end-of-name-in-field bounds)))))) (delete-region (match-beginning 0) (match-end 0)) ;; make field non-OPT (search-forward "=") @@ -4600,71 +5022,6 @@ (when (eq status 'finished) (save-excursion (bibtex-remove-delimiters))))))))) -(defun bibtex-Article () - "Insert a new BibTeX @Article entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Article")) - -(defun bibtex-Book () - "Insert a new BibTeX @Book entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Book")) - -(defun bibtex-Booklet () - "Insert a new BibTeX @Booklet entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Booklet")) - -(defun bibtex-InBook () - "Insert a new BibTeX @InBook entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "InBook")) - -(defun bibtex-InCollection () - "Insert a new BibTeX @InCollection entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "InCollection")) - -(defun bibtex-InProceedings () - "Insert a new BibTeX @InProceedings entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "InProceedings")) - -(defun bibtex-Manual () - "Insert a new BibTeX @Manual entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Manual")) - -(defun bibtex-MastersThesis () - "Insert a new BibTeX @MastersThesis entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "MastersThesis")) - -(defun bibtex-Misc () - "Insert a new BibTeX @Misc entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Misc")) - -(defun bibtex-PhdThesis () - "Insert a new BibTeX @PhdThesis entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "PhdThesis")) - -(defun bibtex-Proceedings () - "Insert a new BibTeX @Proceedings entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Proceedings")) - -(defun bibtex-TechReport () - "Insert a new BibTeX @TechReport entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "TechReport")) - -(defun bibtex-Unpublished () - "Insert a new BibTeX @Unpublished entry; see also `bibtex-entry'." - (interactive "*") - (bibtex-entry "Unpublished")) - (defun bibtex-String (&optional key) "Insert a new BibTeX @String entry with key KEY." (interactive (list (bibtex-read-string-key))) @@ -4822,10 +5179,8 @@ (delete-dups (apply 'append bibtex-user-optional-fields - (mapcar (lambda (x) - (append (mapcar 'car (nth 0 (nth 1 x))) - (mapcar 'car (nth 1 (nth 1 x))))) - bibtex-entry-field-alist))) nil t) + (mapcar (lambda (x) (mapcar 'car (apply 'append (cdr x)))) + bibtex-entry-alist))) nil t) (read-string "Regexp: ") (if bibtex-search-entry-globally (not current-prefix-arg) ------------------------------------------------------------ revno: 104968 committer: Stefan Monnier branch nick: trunk timestamp: Tue 2011-07-05 11:31:22 -0400 message: Fix some uses of switch-to-buffer. * lisp/progmodes/compile.el (compilation-goto-locus): * lisp/net/tramp-cmds.el (tramp-append-tramp-buffers): * lisp/bs.el (bs-cycle-next, bs-cycle-previous): * lisp/bookmark.el (bookmark-bmenu-list, bookmark-bmenu-2-window): * lisp/bindings.el (mode-line-other-buffer): * lisp/autoinsert.el (auto-insert): * lisp/arc-mode.el (archive-extract): * lisp/abbrev.el (edit-abbrevs): Fix some uses of switch-to-buffer. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 15:23:15 +0000 +++ lisp/ChangeLog 2011-07-05 15:31:22 +0000 @@ -1,3 +1,14 @@ +2011-07-05 Stefan Monnier + + * progmodes/compile.el (compilation-goto-locus): + * net/tramp-cmds.el (tramp-append-tramp-buffers): + * bs.el (bs-cycle-next, bs-cycle-previous): + * bookmark.el (bookmark-bmenu-list, bookmark-bmenu-2-window): + * bindings.el (mode-line-other-buffer): + * autoinsert.el (auto-insert): + * arc-mode.el (archive-extract): + * abbrev.el (edit-abbrevs): Fix some uses of switch-to-buffer. + 2011-07-05 Juanma Barranquero * emacs-lock.el (emacs-lock-mode): Fix typo in variable name. @@ -64,8 +75,8 @@ according to whether there are or aren't any plain-text topics pending encryption. - (allout-inhibit-auto-save-info-for-decryption): Adjust - buffer-saved-size and some allout state to inhibit auto-saves if + (allout-inhibit-auto-save-info-for-decryption): + Adjust buffer-saved-size and some allout state to inhibit auto-saves if there are plain-text topics pending encryption. (allout-maybe-resume-auto-save-info-after-encryption): Adjust === modified file 'lisp/abbrev.el' --- lisp/abbrev.el 2011-06-15 18:33:33 +0000 +++ lisp/abbrev.el 2011-07-05 15:31:22 +0000 @@ -159,7 +159,7 @@ USECOUNT is an integer, and HOOK is any valid function or may be omitted (it is usually omitted)." (interactive) - (switch-to-buffer (prepare-abbrev-list-buffer))) + (pop-to-buffer-same-window (prepare-abbrev-list-buffer))) (defun edit-abbrevs-redefine () "Redefine abbrevs according to current buffer contents." === modified file 'lisp/arc-mode.el' --- lisp/arc-mode.el 2011-07-04 22:11:40 +0000 +++ lisp/arc-mode.el 2011-07-05 15:31:22 +0000 @@ -1083,7 +1083,7 @@ (view-buffer buffer (and just-created 'kill-buffer-if-not-modified))) ((eq other-window-p 'display) (display-buffer buffer)) (other-window-p (switch-to-buffer-other-window buffer)) - (t (switch-to-buffer buffer)))))) + (t (pop-to-buffer-same-window buffer)))))) (defun archive-*-extract (archive name command) (let* ((default-directory (file-name-as-directory archive-tmpdir)) === modified file 'lisp/autoinsert.el' --- lisp/autoinsert.el 2011-01-26 08:36:39 +0000 +++ lisp/autoinsert.el 2011-07-05 15:31:22 +0000 @@ -360,7 +360,7 @@ (save-window-excursion ;; make buffer visible before skeleton or function ;; which might ask the user for something - (switch-to-buffer (current-buffer)) + (pop-to-buffer-same-window (current-buffer)) (if (and (consp action) (not (eq (car action) 'lambda))) (skeleton-insert action) === modified file 'lisp/bindings.el' --- lisp/bindings.el 2011-07-04 20:45:22 +0000 +++ lisp/bindings.el 2011-07-05 15:31:22 +0000 @@ -471,7 +471,8 @@ (defun mode-line-other-buffer () "\ Switch to the most recently selected buffer other than the current one." (interactive) - (switch-to-buffer (other-buffer))) + (with-no-warnings ; We really do want to call `switch-to-buffer' here. + (switch-to-buffer (other-buffer)))) (defun mode-line-next-buffer (event) "Like `next-buffer', but temporarily select EVENT's window." === modified file 'lisp/bookmark.el' --- lisp/bookmark.el 2011-05-10 19:34:51 +0000 +++ lisp/bookmark.el 2011-07-05 15:31:22 +0000 @@ -1539,9 +1539,7 @@ (bookmark-maybe-load-default-file) (let ((buf (get-buffer-create "*Bookmark List*"))) (if (called-interactively-p 'interactive) - (if (or (window-dedicated-p) (window-minibuffer-p)) - (pop-to-buffer buf) - (switch-to-buffer buf)) + (pop-to-buffer-same-window buf) (set-buffer buf))) (let ((inhibit-read-only t)) (erase-buffer) @@ -1843,7 +1841,8 @@ (menu (current-buffer)) (pop-up-windows t)) (delete-other-windows) - (switch-to-buffer (other-buffer)) + (with-no-warnings ; We really do want to call `switch-to-buffer' here. + (switch-to-buffer (other-buffer))) (bookmark--jump-via bmrk 'pop-to-buffer) (bury-buffer menu))) === modified file 'lisp/bs.el' --- lisp/bs.el 2011-06-27 01:52:37 +0000 +++ lisp/bs.el 2011-07-05 15:31:22 +0000 @@ -1215,7 +1215,8 @@ ;; We don't want the frame iconified if the only window in the frame ;; happens to be dedicated. (bury-buffer (current-buffer)) - (switch-to-buffer next) + (with-no-warnings ; We really do want to call `switch-to-buffer' here. + (switch-to-buffer next)) (setq bs--cycle-list (append (cdr cycle-list) (list (car cycle-list)))) (bs-message-without-log "Next buffers: %s" @@ -1244,7 +1245,8 @@ bs--cycle-list))) (prev-buffer (car tupel)) (cycle-list (cdr tupel))) - (switch-to-buffer prev-buffer) + (with-no-warnings ; We really do want to call `switch-to-buffer' here. + (switch-to-buffer prev-buffer)) (setq bs--cycle-list (append (last cycle-list) (reverse (cdr (reverse cycle-list))))) (bs-message-without-log "Previous buffers: %s" === modified file 'lisp/net/tramp-cmds.el' --- lisp/net/tramp-cmds.el 2011-07-04 12:12:38 +0000 +++ lisp/net/tramp-cmds.el 2011-07-05 15:31:22 +0000 @@ -308,7 +308,7 @@ ;; There is at least one Tramp buffer. (when buffer-list - (switch-to-buffer (list-buffers-noselect nil)) + (pop-to-buffer-same-window (list-buffers-noselect nil)) (delete-other-windows) (setq buffer-read-only nil) (goto-char (point-min)) @@ -343,7 +343,7 @@ ;; OK, let's send. First we delete the buffer list. (progn (kill-buffer nil) - (switch-to-buffer curbuf) + (pop-to-buffer-same-window curbuf) (goto-char (point-max)) (insert "\n\ This is a special notion of the `gnus/message' package. If you === modified file 'lisp/progmodes/compile.el' --- lisp/progmodes/compile.el 2011-07-03 21:39:49 +0000 +++ lisp/progmodes/compile.el 2011-07-05 15:31:22 +0000 @@ -2410,9 +2410,7 @@ ;; display the source in another window. (let ((pop-up-windows t)) (pop-to-buffer (marker-buffer mk) 'other-window)) - (if (window-dedicated-p (selected-window)) - (pop-to-buffer (marker-buffer mk)) - (switch-to-buffer (marker-buffer mk)))) + (pop-to-buffer-same-window (marker-buffer mk))) (unless (eq (goto-char mk) (point)) ;; If narrowing gets in the way of going to the right place, widen. (widen) ------------------------------------------------------------ revno: 104967 committer: Chong Yidong branch nick: trunk timestamp: Tue 2011-07-05 11:23:15 -0400 message: Revert last change (r104965). diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 15:09:19 +0000 +++ lisp/ChangeLog 2011-07-05 15:23:15 +0000 @@ -4,12 +4,6 @@ Fix check of `emacs-lock-unlockable-modes'. Coerce true values of `emacs-lock--try-unlocking' to t. -2011-07-05 Lars Magne Ingebrigtsen - - * font-lock.el (font-lock-builtin-face): Change from Orchid to - MediumBlue on light-coloured backgrounds to avoid confusion with - the doc string (bug#6693). - 2011-07-05 Juanma Barranquero * obsolete/old-emacs-lock.el: Rename from emacs-lock.el. === modified file 'lisp/font-lock.el' --- lisp/font-lock.el 2011-07-05 14:25:21 +0000 +++ lisp/font-lock.el 2011-07-05 15:23:15 +0000 @@ -1906,7 +1906,7 @@ (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold)) (((class color) (min-colors 88) (background light)) (:foreground "dark slate blue")) (((class color) (min-colors 88) (background dark)) (:foreground "LightSteelBlue")) - (((class color) (min-colors 16) (background light)) (:foreground "MediumBlue")) + (((class color) (min-colors 16) (background light)) (:foreground "Orchid")) (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue")) (((class color) (min-colors 8)) (:foreground "blue" :weight bold)) (t (:weight bold))) ------------------------------------------------------------ revno: 104966 committer: Juanma Barranquero branch nick: trunk timestamp: Tue 2011-07-05 17:09:19 +0200 message: * emacs-lock.el (emacs-lock-mode): Fix typo in variable name. Fix check of `emacs-lock-unlockable-modes'. Coerce true values of `emacs-lock--try-unlocking' to t. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 14:25:21 +0000 +++ lisp/ChangeLog 2011-07-05 15:09:19 +0000 @@ -1,3 +1,9 @@ +2011-07-05 Juanma Barranquero + + * emacs-lock.el (emacs-lock-mode): Fix typo in variable name. + Fix check of `emacs-lock-unlockable-modes'. + Coerce true values of `emacs-lock--try-unlocking' to t. + 2011-07-05 Lars Magne Ingebrigtsen * font-lock.el (font-lock-builtin-face): Change from Orchid to === modified file 'lisp/emacs-lock.el' --- lisp/emacs-lock.el 2011-07-05 12:05:06 +0000 +++ lisp/emacs-lock.el 2011-07-05 15:09:19 +0000 @@ -195,7 +195,7 @@ :init-value nil :lighter ("" (emacs-lock--try-unlocking " locked:" " Locked:") - (:eval (symbol-name emacs-lock-model))) + (:eval (symbol-name emacs-lock-mode))) :group 'emacs-lock :variable (emacs-lock-mode . (lambda (mode) @@ -203,9 +203,10 @@ (when emacs-lock-mode (setq emacs-lock--old-mode emacs-lock-mode) (setq emacs-lock--try-unlocking - (or (and (eq emacs-lock-unlockable-modes t) - (emacs-lock-live-process-p (current-buffer))) - (assq major-mode emacs-lock-unlockable-modes))))) + (and (if (eq emacs-lock-unlockable-modes t) + (emacs-lock-live-process-p (current-buffer)) + (assq major-mode emacs-lock-unlockable-modes)) + t)))) (unless noninteractive (add-hook 'kill-buffer-query-functions 'emacs-lock--kill-buffer-query-functions) ------------------------------------------------------------ revno: 104965 fixes bug(s): http://debbugs.gnu.org/6693 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Tue 2011-07-05 16:25:21 +0200 message: * font-lock.el (font-lock-builtin-face): Change from Orchid to MediumBlue on light-coloured backgrounds to avoid confusion with the doc string. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2011-07-05 11:38:44 +0000 +++ lisp/ChangeLog 2011-07-05 14:25:21 +0000 @@ -1,3 +1,9 @@ +2011-07-05 Lars Magne Ingebrigtsen + + * font-lock.el (font-lock-builtin-face): Change from Orchid to + MediumBlue on light-coloured backgrounds to avoid confusion with + the doc string (bug#6693). + 2011-07-05 Juanma Barranquero * obsolete/old-emacs-lock.el: Rename from emacs-lock.el. === modified file 'lisp/font-lock.el' --- lisp/font-lock.el 2011-07-04 20:00:56 +0000 +++ lisp/font-lock.el 2011-07-05 14:25:21 +0000 @@ -1906,7 +1906,7 @@ (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold)) (((class color) (min-colors 88) (background light)) (:foreground "dark slate blue")) (((class color) (min-colors 88) (background dark)) (:foreground "LightSteelBlue")) - (((class color) (min-colors 16) (background light)) (:foreground "Orchid")) + (((class color) (min-colors 16) (background light)) (:foreground "MediumBlue")) (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue")) (((class color) (min-colors 8)) (:foreground "blue" :weight bold)) (t (:weight bold))) ------------------------------------------------------------ revno: 104964 committer: Juanma Barranquero branch nick: trunk timestamp: Tue 2011-07-05 14:05:06 +0200 message: lisp/emacs-lock.el: Add back code accidentally replaced with garbage. diff: === modified file 'lisp/emacs-lock.el' --- lisp/emacs-lock.el 2011-07-05 11:38:44 +0000 +++ lisp/emacs-lock.el 2011-07-05 12:05:06 +0000 @@ -237,4 +237,7 @@ (interactive) (call-interactively 'emacs-lock-mode)) (make-obsolete 'toggle-emacs-lock 'emacs-lock-mode "24.1") -k + +(provide 'emacs-lock) + +;;; emacs-lock.el ends here ------------------------------------------------------------ Use --include-merges or -n0 to see merged revisions.