Now on revision 108571. ------------------------------------------------------------ revno: 108571 committer: Chong Yidong branch nick: trunk timestamp: Tue 2012-06-12 13:47:14 +0800 message: Various minor variable/hook cleanups. * lisp/emacs-lisp/edebug.el (edebug-inhibit-emacs-lisp-mode-bindings): Rename from gud-inhibit-global-bindings. * lisp/emacs-lisp/eieio.el (eieio-pre-method-execution-hooks): Doc fix. * lisp/erc/erc-dcc.el (erc-dcc-chat-filter-functions): Rename from erc-dcc-chat-filter-hook, since this is an abnormal hook. * lisp/nxml/nxml-glyph.el (nxml-glyph-set-functions): Rename abnormal hook from nxml-glyph-set-hook. * lisp/progmodes/cwarn.el (cwarn-mode): Remove redundant variable declaration. * lisp/progmodes/pascal.el (pascal-toggle-completions): Doc fix. * lisp/textmodes/bibtex.el (bibtex-string-file-path, bibtex-file-path): Convert to defcustom. * lisp/url/url-handlers.el (url-handler-regexp): * lisp/url/url-nfs.el (url-nfs-automounter-directory-spec): * lisp/url/url-vars.el (url-load-hook): Convert to defcustom. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-12 01:03:10 +0000 +++ lisp/ChangeLog 2012-06-12 05:47:14 +0000 @@ -1,3 +1,21 @@ +2012-06-12 Chong Yidong + + * emacs-lisp/edebug.el (edebug-inhibit-emacs-lisp-mode-bindings): + Rename from gud-inhibit-global-bindings. + + * emacs-lisp/eieio.el (eieio-pre-method-execution-hooks): Doc fix. + + * nxml/nxml-glyph.el (nxml-glyph-set-functions): Rename abnormal + hook from nxml-glyph-set-hook. + + * progmodes/cwarn.el (cwarn-mode): Remove redundant variable + declaration. + + * progmodes/pascal.el (pascal-toggle-completions): Doc fix. + + * textmodes/bibtex.el (bibtex-string-file-path, bibtex-file-path): + Convert to defcustom. + 2012-06-12 Drew Adams * help-mode.el (help-bookmark-make-record, help-bookmark-jump): === modified file 'lisp/emacs-lisp/edebug.el' --- lisp/emacs-lisp/edebug.el 2012-06-07 19:25:48 +0000 +++ lisp/emacs-lisp/edebug.el 2012-06-12 05:47:14 +0000 @@ -3055,7 +3055,6 @@ (edebug-toggle-save-selected-window) (edebug-toggle-save-all-windows))) - (defun edebug-where () "Show the debug windows and where we stopped in the program." (interactive) @@ -3735,12 +3734,16 @@ ;;; Edebug Minor Mode -;; FIXME eh? -(defvar gud-inhibit-global-bindings - "Non-nil means don't do global rebindings of C-x C-a subcommands.") +(defvar edebug-inhibit-emacs-lisp-mode-bindings nil + "If non-nil, inhibit Edebug bindings on the C-x C-a key. +By default, loading the `edebug' library causes these bindings to +be installed in `emacs-lisp-mode-map'.") + +(define-obsolete-variable-alias 'gud-inhibit-global-bindings + 'edebug-inhibit-emacs-lisp-mode-bindings "24.2") ;; Global GUD bindings for all emacs-lisp-mode buffers. -(unless gud-inhibit-global-bindings +(unless edebug-inhibit-emacs-lisp-mode-bindings (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) === modified file 'lisp/emacs-lisp/eieio.el' --- lisp/emacs-lisp/eieio.el 2012-04-20 05:47:55 +0000 +++ lisp/emacs-lisp/eieio.el 2012-06-12 05:47:14 +0000 @@ -2044,7 +2044,7 @@ is called, the next method is popped off the stack.") (defvar eieio-pre-method-execution-hooks nil - "Hooks run just before a method is executed. + "Abnormal hook run just before an EIEIO method is executed. The hook function must accept one argument, the list of forms about to be executed.") === modified file 'lisp/erc/ChangeLog' --- lisp/erc/ChangeLog 2012-06-10 13:20:58 +0000 +++ lisp/erc/ChangeLog 2012-06-12 05:47:14 +0000 @@ -1,3 +1,8 @@ +2012-06-12 Chong Yidong + + * erc-dcc.el (erc-dcc-chat-filter-functions): Rename from + erc-dcc-chat-filter-hook, since this is an abnormal hook. + 2012-06-08 Chong Yidong * erc.el (erc-direct-msg-face, erc-header-line, erc-input-face) === modified file 'lisp/erc/erc-dcc.el' --- lisp/erc/erc-dcc.el 2012-05-14 15:42:23 +0000 +++ lisp/erc/erc-dcc.el 2012-06-12 05:47:14 +0000 @@ -627,7 +627,7 @@ ;;;###autoload (defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC) - "Hook variable for CTCP DCC queries") + "Hook variable for CTCP DCC queries.") (defvar erc-dcc-query-handler-alist '(("SEND" . erc-dcc-handle-ctcp-send) @@ -1099,8 +1099,13 @@ (pcomplete-here '("auto" "ask" "ignore"))) (defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ) -(defvar erc-dcc-chat-filter-hook '(erc-dcc-chat-parse-output) - "Hook to run after doing parsing (and possible insertion) of DCC messages.") +(defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output) + "Abnormal hook run after parsing (and maybe inserting) a DCC message. +Each function is called with two arguments: the ERC process and +the unprocessed output.") + +(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook + 'erc-dcc-chat-filter-functions "24.2") (defvar erc-dcc-chat-mode-map (let ((map (make-sparse-keymap))) @@ -1195,8 +1200,8 @@ (set-buffer (process-buffer proc)) (setq erc-dcc-unprocessed-output (concat erc-dcc-unprocessed-output str)) - (run-hook-with-args 'erc-dcc-chat-filter-hook proc - erc-dcc-unprocessed-output)) + (run-hook-with-args 'erc-dcc-chat-filter-functions + proc erc-dcc-unprocessed-output)) (set-buffer orig-buffer)))) (defun erc-dcc-chat-parse-output (proc str) === modified file 'lisp/nxml/nxml-glyph.el' --- lisp/nxml/nxml-glyph.el 2012-04-09 13:05:48 +0000 +++ lisp/nxml/nxml-glyph.el 2012-06-12 05:47:14 +0000 @@ -25,7 +25,7 @@ ;; The entry point to this file is `nxml-glyph-display-string'. ;; The current implementation is heuristic due to a lack of ;; Emacs primitives necessary to implement it properly. The user -;; can tweak the heuristics using `nxml-glyph-set-hook'. +;; can tweak the heuristics using `nxml-glyph-set-functions'. ;;; Code: @@ -332,21 +332,26 @@ (#xFB01 . #xFB02)] "Glyph set corresponding to Windows Glyph List 4.") -(defvar nxml-glyph-set-hook nil - "Hook for determining the set of glyphs in a face. -The hook will receive a single argument FACE. If it can determine -the set of glyphs representable by FACE, it must set the variable -`nxml-glyph-set' and return non-nil. Otherwise, it must return nil. -The hook will be run until success. The constants -`nxml-ascii-glyph-set', `nxml-latin1-glyph-set', +(defvar nxml-glyph-set-functions nil + "Abnormal hook for determining the set of glyphs in a face. +Each function in this hook is called in turn, unless one of them +returns non-nil. Each function is called with a single argument +FACE. If it can determine the set of glyphs representable by +FACE, it must set the variable `nxml-glyph-set' and return +non-nil. Otherwise, it must return nil. + +The constants `nxml-ascii-glyph-set', `nxml-latin1-glyph-set', `nxml-misc-fixed-1-glyph-set', `nxml-misc-fixed-2-glyph-set', `nxml-misc-fixed-3-glyph-set' and `nxml-wgl4-glyph-set' are -predefined for use by `nxml-glyph-set-hook'.") +predefined for use by `nxml-glyph-set-functions'.") + +(define-obsolete-variable-alias 'nxml-glyph-set-hook + 'nxml-glyph-set-functions "24.2") (defvar nxml-glyph-set nil - "Used by `nxml-glyph-set-hook' to return set of glyphs in a FACE. + "Used by `nxml-glyph-set-functions' to return set of glyphs in a FACE. This should dynamically bound by any function that runs -`nxml-glyph-set-hook'. The value must be either nil representing an +`nxml-glyph-set-functions'. The value must be either nil representing an empty set or a vector. Each member of the vector is either a single integer or a cons (FIRST . LAST) representing the range of integers from FIRST to LAST. An integer represents a glyph with that Unicode @@ -367,7 +372,7 @@ (defun nxml-terminal-set-glyph-set (face) (setq nxml-glyph-set nxml-ascii-glyph-set)) -(add-hook 'nxml-glyph-set-hook +(add-hook 'nxml-glyph-set-functions (or (cdr (assq window-system '((x . nxml-x-set-glyph-set) (w32 . nxml-w32-set-glyph-set) @@ -381,7 +386,7 @@ FACE gives the face that will be used for displaying the string. Return nil if the face cannot display a glyph for N." (let ((nxml-glyph-set nil)) - (run-hook-with-args-until-success 'nxml-glyph-set-hook face) + (run-hook-with-args-until-success 'nxml-glyph-set-functions face) (and nxml-glyph-set (nxml-glyph-set-contains-p n nxml-glyph-set) (let ((ch (decode-char 'ucs n))) === modified file 'lisp/nxml/nxml-mode.el' --- lisp/nxml/nxml-mode.el 2012-04-19 17:20:26 +0000 +++ lisp/nxml/nxml-mode.el 2012-06-12 05:47:14 +0000 @@ -54,9 +54,9 @@ (defcustom nxml-char-ref-display-glyph-flag t "Non-nil means display glyph following character reference. -The glyph is displayed in face `nxml-glyph'. The hook -`nxml-glyph-set-hook' can be used to customize for which characters -glyphs are displayed." +The glyph is displayed in face `nxml-glyph'. The abnormal hook +`nxml-glyph-set-functions' can be used to change the characters +for which glyphs are displayed." :group 'nxml :type 'boolean) === modified file 'lisp/progmodes/cwarn.el' --- lisp/progmodes/cwarn.el 2012-04-09 13:05:48 +0000 +++ lisp/progmodes/cwarn.el 2012-06-12 05:47:14 +0000 @@ -119,12 +119,6 @@ :version "21.1" :group 'faces) -(defvar cwarn-mode nil - "Non-nil when Cwarn mode is active. - -Never set this variable directly, use the command `cwarn-mode' -instead.") - (defcustom cwarn-configuration '((c-mode (not reference)) (c++-mode t)) === modified file 'lisp/progmodes/pascal.el' --- lisp/progmodes/pascal.el 2012-04-27 02:48:38 +0000 +++ lisp/progmodes/pascal.el 2012-06-12 05:47:14 +0000 @@ -232,10 +232,10 @@ :group 'pascal) (defvar pascal-toggle-completions nil - "Non-nil meant \\\\[pascal-complete-word] would try all possible completions one by one. -Repeated use of \\[pascal-complete-word] would show you all of them. -Normally, when there is more than one possible completion, -it displays a list of all possible completions.") + "If non-nil, `pascal-complete-word' tries all possible completions. +Repeated use of \\[pascal-complete-word] then shows all +completions in turn, instead of displaying a list of all possible +completions.") (make-obsolete-variable 'pascal-toggle-completions 'completion-cycle-threshold "24.1") === modified file 'lisp/textmodes/bibtex.el' --- lisp/textmodes/bibtex.el 2012-04-09 13:05:48 +0000 +++ lisp/textmodes/bibtex.el 2012-06-12 05:47:14 +0000 @@ -916,8 +916,10 @@ :group 'bibtex :type '(repeat file)) -(defvar bibtex-string-file-path (getenv "BIBINPUTS") - "Colon separated list of paths to search for `bibtex-string-files'.") +(defcustom bibtex-string-file-path (getenv "BIBINPUTS") + "Colon-separated list of paths to search for `bibtex-string-files'." + :group 'bibtex + :type 'string) (defcustom bibtex-files nil "List of BibTeX files that are searched for entry keys. @@ -930,8 +932,10 @@ :type '(repeat (choice (const :tag "bibtex-file-path" bibtex-file-path) directory file))) -(defvar bibtex-file-path (getenv "BIBINPUTS") - "Colon separated list of paths to search for `bibtex-files'.") +(defcustom bibtex-file-path (getenv "BIBINPUTS") + "Colon separated list of paths to search for `bibtex-files'." + :group 'bibtex + :type 'string) (defcustom bibtex-search-entry-globally nil "If non-nil, interactive calls of `bibtex-search-entry' search globally. === modified file 'lisp/url/ChangeLog' --- lisp/url/ChangeLog 2012-06-10 13:20:58 +0000 +++ lisp/url/ChangeLog 2012-06-12 05:47:14 +0000 @@ -1,3 +1,9 @@ +2012-06-12 Chong Yidong + + * url-handlers.el (url-handler-regexp): + * url-nfs.el (url-nfs-automounter-directory-spec): + * url-vars.el (url-load-hook): Convert to defcustom. + 2012-05-25 Leo Liu * url-http.el (url-http-codes): Fix mal-formed defconst. === modified file 'lisp/url/url-handlers.el' --- lisp/url/url-handlers.el 2012-04-09 13:05:48 +0000 +++ lisp/url/url-handlers.el 2012-06-12 05:47:14 +0000 @@ -90,13 +90,24 @@ ;; verify-visited-file-modtime ;; write-region -(defvar url-handler-regexp - "\\`\\(https?\\|ftp\\|file\\|nfs\\)://" - "A regular expression for matching URLs handled by `file-name-handler-alist'. -Some valid URL protocols just do not make sense to visit interactively -\(about, data, info, irc, mailto, etc\). This regular expression -avoids conflicts with local files that look like URLs \(Gnus is -particularly bad at this\).") +;;;###autoload +(defcustom url-handler-regexp "\\`\\(https?\\|ftp\\|file\\|nfs\\)://" + "Regular expression for URLs handled by `url-handler-mode'. +When URL Handler mode is enabled, this regular expression is +added to `file-name-handler-alist'. + +Some valid URL protocols just do not make sense to visit +interactively \(about, data, info, irc, mailto, etc\). This +regular expression avoids conflicts with local files that look +like URLs \(Gnus is particularly bad at this\)." + :group 'url + :type 'regexp + :set (lambda (symbol value) + (let ((enable url-handler-mode)) + (url-handler-mode 0) + (set-default symbol value) + (if enable + (url-handler-mode))))) ;;;###autoload (define-minor-mode url-handler-mode @@ -105,16 +116,13 @@ positive, and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil." :global t :group 'url - (if (not (boundp 'file-name-handler-alist)) - ;; Can't be turned ON anyway. - (setq url-handler-mode nil) - ;; Remove old entry, if any. - (setq file-name-handler-alist - (delq (rassq 'url-file-handler file-name-handler-alist) - file-name-handler-alist)) - (if url-handler-mode - (push (cons url-handler-regexp 'url-file-handler) - file-name-handler-alist)))) + ;; Remove old entry, if any. + (setq file-name-handler-alist + (delq (rassq 'url-file-handler file-name-handler-alist) + file-name-handler-alist)) + (if url-handler-mode + (push (cons url-handler-regexp 'url-file-handler) + file-name-handler-alist))) (defun url-run-real-handler (operation args) (let ((inhibit-file-name-handlers (cons 'url-file-handler === modified file 'lisp/url/url-nfs.el' --- lisp/url/url-nfs.el 2012-04-09 13:05:48 +0000 +++ lisp/url/url-nfs.el 2012-06-12 05:47:14 +0000 @@ -27,8 +27,7 @@ (require 'url-parse) (require 'url-file) -(defvar url-nfs-automounter-directory-spec - "file:/net/%h%f" +(defcustom url-nfs-automounter-directory-spec "file:/net/%h%f" "How to invoke the NFS automounter. Certain % sequences are recognized. %h -- the hostname of the NFS server @@ -38,7 +37,9 @@ %f -- the filename on the remote server %% -- a literal % -Each can be used any number of times.") +Each can be used any number of times." + :group 'url + :type 'string) (defun url-nfs-unescape (format host port user pass file) (with-current-buffer (get-buffer-create " *nfs-parse*") === modified file 'lisp/url/url-vars.el' --- lisp/url/url-vars.el 2012-05-10 06:27:12 +0000 +++ lisp/url/url-vars.el 2012-06-12 05:47:14 +0000 @@ -375,8 +375,10 @@ (modify-syntax-entry ?> ")<" url-parse-syntax-table) (modify-syntax-entry ?/ " " url-parse-syntax-table) -(defvar url-load-hook nil - "Hooks to be run after initializing the URL library.") +(defcustom url-load-hook nil + "Hook run after initializing the URL library." + :group 'url + :type 'hook) ;;; Make OS/2 happy - yeeks ;; (defvar tcp-binary-process-input-services nil ------------------------------------------------------------ revno: 108570 author: Nguyen Thai Ngoc Duy committer: Chong Yidong branch nick: trunk timestamp: Tue 2012-06-12 12:36:00 +0800 message: Add file missing from last commit. diff: === added file 'leim/quail/vnvni.el' --- leim/quail/vnvni.el 1970-01-01 00:00:00 +0000 +++ leim/quail/vnvni.el 2012-06-12 04:36:00 +0000 @@ -0,0 +1,305 @@ +;;; vnvni.el --- Quail package for Vietnamese by VNI method + +;; Copyright (C) 2001-2012 Free Software Foundation, Inc. + +;; Author: Werner Lemberg +;; Nguyen Thai Ngoc Duy +;; Keywords: multilingual, input method, Vietnamese + +;; 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 . + +;;; Commentary: + +;; There are two commonly-used input methods for Vietnamese: Telex +;; (implemented in vntelex.el) and VNI (implemented in this file, +;; which was based on vntelex.el). + +;;; Code: + +(require 'quail) + + +(quail-define-package + "vietnamese-vni" ; NAME + "Vietnamese" ; LANGUAGE + "VV" ; TITLE + t ; GUIDANCE + "Vietnamese VNI input method + +Diacritics: + + effect postfix examples + ------------------------------ + circumflex 6 a6 -> ,Ab(B + breve 8 a8 -> ,1e(B + horn 7 o7 -> ,1=(B + + acute 1 a1 -> ,1a(B + grave 2 a2 -> ,1`(B + hook above 3 a3 -> ,1d(B + tilde 4 a4 -> ,1c(B + dot below 5 a5 -> ,1U(B + + d bar 9 d9 -> ,1p(B + +Combinations: + + A82 -> ,2"(B, o74 -> ,1^(B, etc. + +Doubling the postfix (but not in combinations) separates the letter +and postfix: E66 -> E6, a55 -> a5, etc. +" ; DOCSTRING + nil ; TRANSLATION-KEYS + t ; FORGET-LAST-SELECTION + nil ; DETERMINISTIC + nil ; KBD-TRANSLATE + nil ; SHOW-LAYOUT + nil ; CREATE-DECODE-MAP + nil ; MAXIMUM-SHORTEST + nil ; OVERLAY-PLIST + nil ; UPDATE-TRANSLATION-FUNCTION + nil ; CONVERSION-KEYS + t) ; SIMPLE + +(quail-define-rules + ("a2" ?,1`(B) ; LATIN SMALL LETTER A WITH GRAVE + ("A2" ?,2`(B) ; LATIN CAPITAL LETTER A WITH GRAVE + ("a1" ?,1a(B) ; LATIN SMALL LETTER A WITH ACUTE + ("A1" ?,2a(B) ; LATIN CAPITAL LETTER A WITH ACUTE + ("a6" ?,1b(B) ; LATIN SMALL LETTER A WITH CIRCUMFLEX + ("A6" ?,2b(B) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX + ("a4" ?,1c(B) ; LATIN SMALL LETTER A WITH TILDE + ("A4" ?,2c(B) ; LATIN CAPITAL LETTER A WITH TILDE + ("e2" ?,1h(B) ; LATIN SMALL LETTER E WITH GRAVE + ("E2" ?,2h(B) ; LATIN CAPITAL LETTER E WITH GRAVE + ("e1" ?,1i(B) ; LATIN SMALL LETTER E WITH ACUTE + ("E1" ?,2i(B) ; LATIN CAPITAL LETTER E WITH ACUTE + ("e6" ?,1j(B) ; LATIN SMALL LETTER E WITH CIRCUMFLEX + ("E6" ?,2j(B) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX + ("i2" ?,1l(B) ; LATIN SMALL LETTER I WITH GRAVE + ("I2" ?,2l(B) ; LATIN CAPITAL LETTER I WITH GRAVE + ("i1" ?,1m(B) ; LATIN SMALL LETTER I WITH ACUTE + ("I1" ?,2m(B) ; LATIN CAPITAL LETTER I WITH ACUTE + ("o2" ?,1r(B) ; LATIN SMALL LETTER O WITH GRAVE + ("O2" ?,2r(B) ; LATIN CAPITAL LETTER O WITH GRAVE + ("o1" ?,1s(B) ; LATIN SMALL LETTER O WITH ACUTE + ("O1" ?,2s(B) ; LATIN CAPITAL LETTER O WITH ACUTE + ("o6" ?,1t(B) ; LATIN SMALL LETTER O WITH CIRCUMFLEX + ("O6" ?,2t(B) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX + ("o4" ?,1u(B) ; LATIN SMALL LETTER O WITH TILDE + ("O4" ?,2u(B) ; LATIN CAPITAL LETTER O WITH TILDE + ("u2" ?,1y(B) ; LATIN SMALL LETTER U WITH GRAVE + ("U2" ?,2y(B) ; LATIN CAPITAL LETTER U WITH GRAVE + ("u1" ?,1z(B) ; LATIN SMALL LETTER U WITH ACUTE + ("U1" ?,2z(B) ; LATIN CAPITAL LETTER U WITH ACUTE + ("y1" ?,1}(B) ; LATIN SMALL LETTER Y WITH ACUTE + ("Y1" ?,2}(B) ; LATIN CAPITAL LETTER Y WITH ACUTE + ("a8" ?,1e(B) ; LATIN SMALL LETTER A WITH BREVE + ("A8" ?,2e(B) ; LATIN CAPITAL LETTER A WITH BREVE + ("i4" ?,1n(B) ; LATIN SMALL LETTER I WITH TILDE + ("I4" ?,2n(B) ; LATIN CAPITAL LETTER I WITH TILDE + ("u4" ?,1{(B) ; LATIN SMALL LETTER U WITH TILDE + ("U4" ?,2{(B) ; LATIN CAPITAL LETTER U WITH TILDE + ("o7" ?,1=(B) ; LATIN SMALL LETTER O WITH HORN + ("O7" ?,2=(B) ; LATIN CAPITAL LETTER O WITH HORN + ("u7" ?,1_(B) ; LATIN SMALL LETTER U WITH HORN + ("U7" ?,2_(B) ; LATIN CAPITAL LETTER U WITH HORN + ("a5" ?,1U(B) ; LATIN SMALL LETTER A WITH DOT BELOW + ("A5" ?,2U(B) ; LATIN CAPITAL LETTER A WITH DOT BELOW + ("a3" ?,1d(B) ; LATIN SMALL LETTER A WITH HOOK ABOVE + ("A3" ?,2d(B) ; LATIN CAPITAL LETTER A WITH HOOK ABOVE + ("a61" ?,1$(B) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE + ("A61" ?,2$(B) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + ("a62" ?,1%(B) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE + ("A62" ?,2%(B) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + ("a63" ?,1&(B) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND HO6K ABOVE + ("A63" ?,2&(B) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HO6K ABOVE + ("a64" ?,1g(B) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE + ("A64" ?,2g(B) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + ("a65" ?,1'(B) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW + ("A65" ?,2'(B) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + ("a81" ?,1!(B) ; LATIN SMALL LETTER A WITH BREVE AND ACUTE + ("A81" ?,2!(B) ; LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + ("a82" ?,1"(B) ; LATIN SMALL LETTER A WITH BREVE AND GRAVE + ("A82" ?,2"(B) ; LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + ("a83" ?,1F(B) ; LATIN SMALL LETTER A WITH BREVE AND HO6K ABOVE + ("A83" ?,2F(B) ; LATIN CAPITAL LETTER A WITH BREVE AND HO6K ABOVE + ("a84" ?,1G(B) ; LATIN SMALL LETTER A WITH BREVE AND TILDE + ("A84" ?,2G(B) ; LATIN CAPITAL LETTER A WITH BREVE AND TILDE + ("a85" ?,1#(B) ; LATIN SMALL LETTER A WITH BREVE AND DOT BELOW + ("A85" ?,2#(B) ; LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + ("e5" ?,1)(B) ; LATIN SMALL LETTER E WITH DOT BELOW + ("E5" ?,2)(B) ; LATIN CAPITAL LETTER E WITH DOT BELOW + ("e3" ?,1k(B) ; LATIN SMALL LETTER E WITH HO6K ABOVE + ("E3" ?,2k(B) ; LATIN CAPITAL LETTER E WITH HO6K ABOVE + ("e4" ?,1((B) ; LATIN SMALL LETTER E WITH TILDE + ("E4" ?,2((B) ; LATIN CAPITAL LETTER E WITH TILDE + ("e61" ?,1*(B) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE + ("E61" ?,2*(B) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + ("e62" ?,1+(B) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE + ("E62" ?,2+(B) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + ("e63" ?,1,(B) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND HO6K ABOVE + ("E63" ?,2,(B) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HO6K ABOVE + ("e64" ?,1-(B) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE + ("E64" ?,2-(B) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + ("e65" ?,1.(B) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW + ("E65" ?,2.(B) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + ("i3" ?,1o(B) ; LATIN SMALL LETTER I WITH HO6K ABOVE + ("I3" ?,2o(B) ; LATIN CAPITAL LETTER I WITH HO6K ABOVE + ("i5" ?,18(B) ; LATIN SMALL LETTER I WITH DOT BELOW + ("I5" ?,28(B) ; LATIN CAPITAL LETTER I WITH DOT BELOW + ("o5" ?,1w(B) ; LATIN SMALL LETTER O WITH DOT BELOW + ("O5" ?,2w(B) ; LATIN CAPITAL LETTER O WITH DOT BELOW + ("o3" ?,1v(B) ; LATIN SMALL LETTER O WITH HO6K ABOVE + ("O3" ?,2v(B) ; LATIN CAPITAL LETTER O WITH HO6K ABOVE + ("o61" ?,1/(B) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE + ("O61" ?,2/(B) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + ("o62" ?,10(B) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE + ("O62" ?,20(B) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + ("o63" ?,11(B) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND HO6K ABOVE + ("O63" ?,21(B) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HO6K ABOVE + ("o64" ?,12(B) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE + ("O64" ?,22(B) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + ("o65" ?,15(B) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELO7 + ("O65" ?,25(B) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELO7 + ("o71" ?,1>(B) ; LATIN SMALL LETTER O WITH HORN AND ACUTE + ("O71" ?,2>(B) ; LATIN CAPITAL LETTER O WITH HORN AND ACUTE + ("o72" ?,16(B) ; LATIN SMALL LETTER O WITH HORN AND GRAVE + ("O72" ?,26(B) ; LATIN CAPITAL LETTER O WITH HORN AND GRAVE + ("o73" ?,17(B) ; LATIN SMALL LETTER O WITH HORN AND HO6K ABOVE + ("O73" ?,27(B) ; LATIN CAPITAL LETTER O WITH HORN AND HO6K ABOVE + ("o74" ?,1^(B) ; LATIN SMALL LETTER O WITH HORN AND TILDE + ("O74" ?,2^(B) ; LATIN CAPITAL LETTER O WITH HORN AND TILDE + ("o75" ?,1~(B) ; LATIN SMALL LETTER O WITH HORN AND DOT BELO7 + ("O75" ?,2~(B) ; LATIN CAPITAL LETTER O WITH HORN AND DOT BELO7 + ("u5" ?,1x(B) ; LATIN SMALL LETTER U WITH DOT BELO7 + ("U5" ?,2x(B) ; LATIN CAPITAL LETTER U WITH DOT BELO7 + ("u3" ?,1|(B) ; LATIN SMALL LETTER U WITH HO6K ABOVE + ("U3" ?,2|(B) ; LATIN CAPITAL LETTER U WITH HO6K ABOVE + ("u71" ?,1Q(B) ; LATIN SMALL LETTER U WITH HORN AND ACUTE + ("U71" ?,2Q(B) ; LATIN CAPITAL LETTER U WITH HORN AND ACUTE + ("u72" ?,1W(B) ; LATIN SMALL LETTER U WITH HORN AND GRAVE + ("U72" ?,2W(B) ; LATIN CAPITAL LETTER U WITH HORN AND GRAVE + ("u73" ?,1X(B) ; LATIN SMALL LETTER U WITH HORN AND HO6K ABOVE + ("U73" ?,2X(B) ; LATIN CAPITAL LETTER U WITH HORN AND HO6K ABOVE + ("u74" ?,1f(B) ; LATIN SMALL LETTER U WITH HORN AND TILDE + ("U74" ?,2f(B) ; LATIN CAPITAL LETTER U WITH HORN AND TILDE + ("u75" ?,1q(B) ; LATIN SMALL LETTER U WITH HORN AND DOT BELO7 + ("U75" ?,2q(B) ; LATIN CAPITAL LETTER U WITH HORN AND DOT BELO7 + ("y2" ?,1O(B) ; LATIN SMALL LETTER Y WITH GRAVE + ("Y2" ?,2O(B) ; LATIN CAPITAL LETTER Y WITH GRAVE + ("y5" ?,1\(B) ; LATIN SMALL LETTER Y WITH DOT BELO7 + ("Y5" ?,2\(B) ; LATIN CAPITAL LETTER Y WITH DOT BELO7 + ("y3" ?,1V(B) ; LATIN SMALL LETTER Y WITH HO6K ABOVE + ("Y3" ?,2V(B) ; LATIN CAPITAL LETTER Y WITH HO6K ABOVE + ("y4" ?,1[(B) ; LATIN SMALL LETTER Y WITH TILDE + ("Y4" ?,2[(B) ; LATIN CAPITAL LETTER Y WITH TILDE + ("d9" ?,1p(B) ; LATIN SMALL LETTER D WITH STROKE + ("D9" ?,2p(B) ; LATIN CAPITAL LETTER D WITH STROKE +;("$$" ?$,1tK(B) ; U+20AB DONG SIGN (#### check) + + ("a22" ["a22"]) + ("A22" ["A2"]) + ("a11" ["a1"]) + ("A11" ["A1"]) + ("a66"' ["a6"]) + ("A66"' ["A6"]) + ("a44" ["a4"]) + ("A44" ["A4"]) + ("e22" ["e2"]) + ("E22" ["E2"]) + ("e11" ["e1"]) + ("E11" ["E1"]) + ("e66" ["e6"]) + ("E66" ["E6"]) + ("i22" ["i2"]) + ("I22" ["I2"]) + ("i11" ["i1"]) + ("I11" ["I1"]) + ("o22" ["o2"]) + ("O22" ["O2"]) + ("o11" ["o1"]) + ("O11" ["O1"]) + ("o66" ["o6"]) + ("O66" ["O6"]) + ("o44" ["o4"]) + ("O44" ["O4"]) + ("u22" ["u2"]) + ("U22" ["U2"]) + ("u11" ["u1"]) + ("U11" ["U1"]) + ("y11" ["y1"]) + ("Y11" ["Y1"]) + ("a88" ["a8"]) + ("A88" ["A8"]) + ("i44" ["i4"]) + ("I44" ["I4"]) + ("u44" ["u4"]) + ("U44" ["u4"]) + ("o77" ["o7"]) + ("O77" ["O7"]) + ("u77" ["u7"]) + ("U77" ["U7"]) + ("a55" ["a5"]) + ("A55" ["A5"]) + ("a33" ["a3"]) + ("A33" ["A3"]) + ("e55" ["e5"]) + ("E55" ["E5"]) + ("e33" ["e3"]) + ("E33" ["E3"]) + ("e44" ["e4"]) + ("E44" ["E4"]) + ("i33" ["i3"]) + ("I33" ["I3"]) + ("i55" ["i5"]) + ("I55" ["I5"]) + ("o55" ["o5"]) + ("O55" ["O5"]) + ("o33" ["o3"]) + ("O33" ["O3"]) + ("u55" ["u5"]) + ("U55" ["U5"]) + ("u33" ["u3"]) + ("U33" ["U3"]) + ("y22" ["y2"]) + ("Y22" ["Y2"]) + ("y55" ["y5"]) + ("Y55" ["Y5"]) + ("y33" ["y3"]) + ("Y33" ["Y3"]) + ("y44" ["y4"]) + ("Y44" ["Y4"]) + ("d9" ["d9"]) + ("D99" ["D9"]) +;("$$$" ["$$"]) + + ;; escape from composition + ("\\1" ?1) + ("\\2" ?2) + ("\\3" ?3) + ("\\4" ?4) + ("\\5" ?5) + ("\\6" ?6) + ("\\7" ?7) + ("\\8" ?8) + ("\\9" ?9) + ("\\\\" ?\\)) ; literal backslash + + +;; Local Variables: +;; coding: iso-2022-7bit +;; End: ------------------------------------------------------------ revno: 108569 fixes bug(s): http://debbugs.gnu.org/11660 author: Nguyen Thai Ngoc Duy committer: Chong Yidong branch nick: trunk timestamp: Tue 2012-06-12 12:35:14 +0800 message: New input method vietnamese-vni. * leim/quail/vnvi.el: New file. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-06-11 14:42:55 +0000 +++ etc/NEWS 2012-06-12 04:35:14 +0000 @@ -128,6 +128,8 @@ ** `goto-char' is now bound to `M-g c'. +** New input method `vietnamese-vni'. + * Changes in Specialized Modes and Packages in Emacs 24.2 === modified file 'leim/ChangeLog' --- leim/ChangeLog 2012-06-10 13:20:58 +0000 +++ leim/ChangeLog 2012-06-12 04:35:14 +0000 @@ -1,3 +1,7 @@ +2012-06-12 Nguyen Thai Ngoc Duy + + * quail/vnvi.el: New file (Bug#4747). + 2012-05-22 Glenn Morris * Makefile.in (SUBDIRS): Remove variable and rule. === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-06-11 20:35:00 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-06-12 04:35:14 +0000 @@ -267,7 +267,7 @@ ;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case ;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function ;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" -;;;;;; "5eba72da8ff76ec1346aa355feb936cb") +;;;;;; "a0ba9f3a4a4c091875d8315052259e91") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ ------------------------------------------------------------ revno: 108568 author: Drew Adams committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-06-11 21:03:10 -0400 message: * lisp/help-mode.el (help-bookmark-make-record, help-bookmark-jump): New funs. (help-mode): Use them. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 21:07:58 +0000 +++ lisp/ChangeLog 2012-06-12 01:03:10 +0000 @@ -1,3 +1,9 @@ +2012-06-12 Drew Adams + + * help-mode.el (help-bookmark-make-record, help-bookmark-jump): + New functions. + (help-mode): Use them. + 2012-06-11 Glenn Morris * progmodes/fortran.el (fortran-font-lock-keywords-3): === modified file 'lisp/help-mode.el' --- lisp/help-mode.el 2012-06-08 04:23:26 +0000 +++ lisp/help-mode.el 2012-06-12 01:03:10 +0000 @@ -267,6 +267,8 @@ 'help-function 'customize-create-theme 'help-echo (purecopy "mouse-2, RET: edit this theme file")) +(defvar bookmark-make-record-function) + ;;;###autoload (define-derived-mode help-mode special-mode "Help" "Major mode for viewing help text and navigating references in it. @@ -274,7 +276,9 @@ Commands: \\{help-mode-map}" (set (make-local-variable 'revert-buffer-function) - 'help-mode-revert-buffer)) + 'help-mode-revert-buffer) + (set (make-local-variable 'bookmark-make-record-function) + 'help-bookmark-make-record)) ;;;###autoload (defun help-mode-setup () @@ -791,6 +795,36 @@ (with-output-to-temp-buffer (help-buffer) (insert string))) + +;; Bookmark support + +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun help-bookmark-make-record () + "Create and return a help-mode bookmark record. +Implements `bookmark-make-record-function' for help-mode buffers." + (unless (car help-xref-stack-item) + (error "Cannot create bookmark - help command not known")) + `(,@(bookmark-make-record-default 'NO-FILE 'NO-CONTEXT) + (buffer-name . "*Help*") + (help-fn . ,(car help-xref-stack-item)) + (help-arg . ,(cadr help-xref-stack-item)) + (position . ,(point)) + (handler . help-bookmark-jump))) + +;;;###autoload +(defun help-bookmark-jump (bookmark) + "Jump to help-mode bookmark BOOKMARK. +Handler function for record returned by `help-bookmark-make-record'. +BOOKMARK is a bookmark name or a bookmark record." + (let ((help-fn (bookmark-prop-get bookmark 'help-fn)) + (help-arg (bookmark-prop-get bookmark 'help-arg)) + (position (bookmark-prop-get bookmark 'position))) + (funcall help-fn help-arg) + (pop-to-buffer "*Help*") + (goto-char position))) + + (provide 'help-mode) ;;; help-mode.el ends here ------------------------------------------------------------ revno: 108567 committer: Paul Eggert branch nick: trunk timestamp: Mon 2012-06-11 17:30:18 -0700 message: * image.c (imagemagick_load_image): Remove unused label. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-11 23:17:11 +0000 +++ src/ChangeLog 2012-06-12 00:30:18 +0000 @@ -1,3 +1,7 @@ +2012-06-12 Paul Eggert + + * image.c (imagemagick_load_image): Remove unused label. + 2012-06-11 Glenn Morris * s/aix4-2.h, s/bsd-common.h, s/cygwin.h, s/darwin.h: === modified file 'src/image.c' --- src/image.c 2012-06-11 14:42:55 +0000 +++ src/image.c 2012-06-12 00:30:18 +0000 @@ -7930,7 +7930,6 @@ DestroyMagickWand (image_wand); if (bg_wand) DestroyPixelWand (bg_wand); - imagemagick_no_wand: MagickWandTerminus (); /* TODO more cleanup. */ image_error ("Error parsing IMAGEMAGICK image `%s'", img->spec, Qnil); ------------------------------------------------------------ revno: 108566 committer: Glenn Morris branch nick: trunk timestamp: Mon 2012-06-11 19:17:11 -0400 message: Move SYSTEM_TYPE from src/s to configure * configure.in (SYSTEM_TYPE): New AC_DEFINE. * msdos/sed2v2.inp (SYSTEM_TYPE): Set it. * nt/config.nt (SYSTEM_TYPE): Define it. * src/s/aix4-2.h, src/s/bsd-common.h, src/s/cygwin.h, src/s/darwin.h: * src/s/gnu-kfreebsd.h, src/s/gnu-linux.h, src/s/gnu.h, src/s/hpux10-20.h: * src/s/irix6-5.h, src/s/ms-w32.h, src/s/msdos.h, src/s/template.h: * src/s/usg5-4-common.h: Remove SYSTEM_TYPE. diff: === modified file 'ChangeLog' --- ChangeLog 2012-06-10 13:20:58 +0000 +++ ChangeLog 2012-06-11 23:17:11 +0000 @@ -1,3 +1,7 @@ +2012-06-11 Glenn Morris + + * configure.in (SYSTEM_TYPE): New AC_DEFINE. + 2012-06-09 Michael Albinus * configure.in (dbus_type_is_valid): Check for library function. === modified file 'configure.in' --- configure.in 2012-06-10 13:20:58 +0000 +++ configure.in 2012-06-11 23:17:11 +0000 @@ -934,6 +934,11 @@ LIB_MATH=-lm LIB_STANDARD= START_FILES= +dnl Current possibilities handled by sed (aix4-2 -> aix, +dnl gnu-linux -> gnu/linux, etc.): +dnl gnu, gnu/linux, gnu/kfreebsd, aix, cygwin, darwin, hpux, irix. +dnl And special cases: berkeley-unix, usg-unix-v, ms-dos, windows-nt. +SYSTEM_TYPE=`echo $opsys | sed -e 's/[0-9].*//' -e 's|-|/|'` dnl NB do not use CRT_DIR unquoted here, since it might not be set yet. case $opsys in @@ -949,6 +954,7 @@ freebsd ) LIB_STANDARD='-lgcc -lc -lgcc $(CRT_DIR)/crtend.o $(CRT_DIR)/crtn.o' START_FILES='pre-crt0.o $(CRT_DIR)/crt1.o $(CRT_DIR)/crti.o $(CRT_DIR)/crtbegin.o' + SYSTEM_TYPE=berkeley-unix ;; gnu-linux | gnu-kfreebsd ) LIB_STANDARD='-lgcc -lc -lgcc $(CRT_DIR)/crtn.o' @@ -962,11 +968,19 @@ netbsd | openbsd ) LIB_STANDARD='-lgcc -lc -lgcc $(CRT_DIR)/crtend.o' START_FILES='pre-crt0.o $(CRT_DIR)/crt0.o $(CRT_DIR)/crtbegin.o' - ;; + SYSTEM_TYPE=berkeley-unix + ;; + + sol2* | unixware ) + SYSTEM_TYPE=usg-unix-v + ;; + esac AC_SUBST(LIB_MATH) AC_SUBST(START_FILES) +AC_DEFINE_UNQUOTED(SYSTEM_TYPE, "$SYSTEM_TYPE", + [The type of system you are compiling for; sets `system-type'.]) dnl Not all platforms use crtn.o files. Check if the current one does. crt_files= === modified file 'msdos/ChangeLog' --- msdos/ChangeLog 2012-06-10 13:20:58 +0000 +++ msdos/ChangeLog 2012-06-11 23:17:11 +0000 @@ -1,3 +1,7 @@ +2012-06-11 Glenn Morris + + * sed2v2.inp (SYSTEM_TYPE): Set it. + 2012-05-27 Eli Zaretskii * sedlibmk.inp (GNULIB_GL_UNISTD_H_GETOPT, GNULIB_POSIX_OPENPT) === modified file 'msdos/sed2v2.inp' --- msdos/sed2v2.inp 2012-06-10 13:20:58 +0000 +++ msdos/sed2v2.inp 2012-06-11 23:17:11 +0000 @@ -59,6 +59,7 @@ /^#undef PACKAGE_TARNAME/s/^.*$/#define PACKAGE_TARNAME ""/ /^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION ""/ /^#undef VERSION/s/^.*$/#define VERSION "24.1.50"/ +/^#undef SYSTEM_TYPE/s/^.*$/#define SYSTEM_TYPE "ms-dos"/ /^#undef HAVE_DECL_GETENV/s/^.*$/#define HAVE_DECL_GETENV 1/ /^#undef SYS_SIGLIST_DECLARED/s/^.*$/#define SYS_SIGLIST_DECLARED 1/ /^#undef HAVE_DIRENT_H/s/^.*$/#define HAVE_DIRENT_H 1/ === modified file 'nt/ChangeLog' --- nt/ChangeLog 2012-06-10 13:20:58 +0000 +++ nt/ChangeLog 2012-06-11 23:17:11 +0000 @@ -1,3 +1,7 @@ +2012-06-11 Glenn Morris + + * config.nt (SYSTEM_TYPE): Define it. + 2012-05-31 Eli Zaretskii * configure.bat (genmakefiles): Move the redirection away from the === modified file 'nt/config.nt' --- nt/config.nt 2012-06-10 13:20:58 +0000 +++ nt/config.nt 2012-06-11 23:17:11 +0000 @@ -326,6 +326,9 @@ /* Version number of package */ #define VERSION "24.1.50" +/* The type of system you are compiling for; sets `system-type'. */ +#define SYSTEM_TYPE "windows-nt" + /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifdef __GNUC__ === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-11 15:13:27 +0000 +++ src/ChangeLog 2012-06-11 23:17:11 +0000 @@ -1,3 +1,10 @@ +2012-06-11 Glenn Morris + + * s/aix4-2.h, s/bsd-common.h, s/cygwin.h, s/darwin.h: + * s/gnu-kfreebsd.h, s/gnu-linux.h, s/gnu.h, s/hpux10-20.h: + * s/irix6-5.h, s/ms-w32.h, s/msdos.h, s/template.h: + * s/usg5-4-common.h: Move SYSTEM_TYPE to configure. + 2012-06-11 Stefan Monnier * alloc.c (make_byte_code): New function. === modified file 'src/s/aix4-2.h' --- src/s/aix4-2.h 2012-05-22 16:20:27 +0000 +++ src/s/aix4-2.h 2012-06-11 23:17:11 +0000 @@ -26,10 +26,6 @@ #define _AIX #endif -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "aix" - /* In AIX, you allocate a pty by opening /dev/ptc to get the master side. To get the name of the slave side, you just ttyname() the master side. */ #define PTY_ITERATION int c; for (c = 0; !c ; c++) === modified file 'src/s/bsd-common.h' --- src/s/bsd-common.h 2012-01-19 07:21:25 +0000 +++ src/s/bsd-common.h 2012-06-11 23:17:11 +0000 @@ -46,10 +46,6 @@ for X functions taking float or double parameters. */ #define NARROWPROTO 1 -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "berkeley-unix" - /* Do not use interrupt_input = 1 by default, because in 4.3 we can make noninterrupt input work properly. */ #undef INTERRUPT_INPUT === modified file 'src/s/cygwin.h' --- src/s/cygwin.h 2012-04-14 06:18:49 +0000 +++ src/s/cygwin.h 2012-06-11 23:17:11 +0000 @@ -17,10 +17,6 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "cygwin" - /* Emacs can read input using SIGIO and buffering characters itself, or using CBREAK mode and making C-g cause SIGINT. The choice is controlled by the variable interrupt_input. === modified file 'src/s/darwin.h' --- src/s/darwin.h 2012-04-14 06:18:49 +0000 +++ src/s/darwin.h 2012-06-11 23:17:11 +0000 @@ -31,10 +31,6 @@ #define DARWIN_OS -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "darwin" - /* Emacs can read input using SIGIO and buffering characters itself, or using CBREAK mode and making C-g cause SIGINT. The choice is controlled by the variable interrupt_input. === modified file 'src/s/gnu-kfreebsd.h' --- src/s/gnu-kfreebsd.h 2011-01-15 23:16:57 +0000 +++ src/s/gnu-kfreebsd.h 2012-06-11 23:17:11 +0000 @@ -1,9 +1,3 @@ #include "gnu-linux.h" -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#undef SYSTEM_TYPE -#define SYSTEM_TYPE "gnu/kfreebsd" /* All the best software is free */ - #define NO_TERMIO /* use only */ - === modified file 'src/s/gnu-linux.h' --- src/s/gnu-linux.h 2012-05-22 16:20:27 +0000 +++ src/s/gnu-linux.h 2012-06-11 23:17:11 +0000 @@ -25,10 +25,6 @@ #define USG #define GNU_LINUX -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "gnu/linux" /* All the best software is free. */ - #ifdef emacs #ifdef HAVE_LINUX_VERSION_H #include === modified file 'src/s/gnu.h' --- src/s/gnu.h 2012-05-22 16:20:27 +0000 +++ src/s/gnu.h 2012-06-11 23:17:11 +0000 @@ -21,9 +21,6 @@ /* Get most of the stuff from bsd-common */ #include "bsd-common.h" -#undef SYSTEM_TYPE -#define SYSTEM_TYPE "gnu" - #define SIGNALS_VIA_CHARACTERS /* libc defines data_start. */ === modified file 'src/s/hpux10-20.h' --- src/s/hpux10-20.h 2012-05-31 05:08:37 +0000 +++ src/s/hpux10-20.h 2012-06-11 23:17:11 +0000 @@ -26,10 +26,6 @@ #define USG5 #define HPUX -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "hpux" - /* Letter to use in finding device name of first pty, if system supports pty's. 'p' means it is /dev/ptym/ptyp0 */ #define FIRST_PTY_LETTER 'p' === modified file 'src/s/irix6-5.h' --- src/s/irix6-5.h 2012-05-22 16:20:27 +0000 +++ src/s/irix6-5.h 2012-06-11 23:17:11 +0000 @@ -26,11 +26,6 @@ #define SETPGRP_RELEASES_CTTY -#ifdef SYSTEM_TYPE -#undef SYSTEM_TYPE -#endif -#define SYSTEM_TYPE "irix" - #ifdef SETUP_SLAVE_PTY #undef SETUP_SLAVE_PTY #endif === modified file 'src/s/ms-w32.h' --- src/s/ms-w32.h 2012-05-22 16:20:27 +0000 +++ src/s/ms-w32.h 2012-06-11 23:17:11 +0000 @@ -36,10 +36,6 @@ convention must be whatever standard the libraries expect. */ #define _CALLBACK_ __cdecl -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "windows-nt" - #define NO_MATHERR 1 /* Letter to use in finding device name of first pty, === modified file 'src/s/msdos.h' --- src/s/msdos.h 2012-04-14 06:18:49 +0000 +++ src/s/msdos.h 2012-06-11 23:17:11 +0000 @@ -33,10 +33,6 @@ #define DOS_NT /* MSDOS or WINDOWSNT */ #undef BSD_SYSTEM -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "ms-dos" - /* subprocesses should be defined if you want to have code for asynchronous subprocesses (as used in M-x compile and M-x shell). This is the only system that needs this. */ === modified file 'src/s/template.h' --- src/s/template.h 2012-01-19 07:21:25 +0000 +++ src/s/template.h 2012-06-11 23:17:11 +0000 @@ -30,11 +30,6 @@ /* #define BSD4_3 */ /* #define BSD_SYSTEM */ -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ - -#define SYSTEM_TYPE "berkeley-unix" - /* Emacs can read input using SIGIO and buffering characters itself, or using CBREAK mode and making C-g cause SIGINT. The choice is controlled by the variable interrupt_input. === modified file 'src/s/usg5-4-common.h' --- src/s/usg5-4-common.h 2012-01-19 07:21:25 +0000 +++ src/s/usg5-4-common.h 2012-06-11 23:17:11 +0000 @@ -26,10 +26,6 @@ #define USG5 #define USG5_4 -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ -#define SYSTEM_TYPE "usg-unix-v" - /* setjmp and longjmp can safely replace _setjmp and _longjmp, but they will run slower. */ #define _setjmp setjmp ------------------------------------------------------------ revno: 108565 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Mon 2012-06-11 22:35:02 +0000 message: Merge bugfixes done in Gnus trunk Those changes fix only the bugs having appeared in the bug list. Many other Gnus changes not yet merged to Emacs are in: ftp://ftp.jpl.org/pub/tmp/MaGnus-to-Emacs.patch (or http://www.jpl.org/ftp/pub/tmp/MaGnus-to-Emacs.patch) 2012-06-11 Lars Magne Ingebrigtsen * gnus.texi (Group Timestamp): Mention where to find documentation for the `gnus-tmp-' variables (bug#11601). 2012-04-14 Wolfgang Jenkner * gnus-agent.el (gnus-agent-retrieve-headers): Recalculate the range of articles when fetch-old is non-nil (bug#11370). diff: === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2012-06-11 13:03:39 +0000 +++ doc/misc/ChangeLog 2012-06-11 22:35:02 +0000 @@ -1,3 +1,8 @@ +2012-06-11 Lars Magne Ingebrigtsen + + * gnus.texi (Group Timestamp): Mention where to find documentation for + the `gnus-tmp-' variables (bug#11601). + 2012-06-11 Michael Albinus Sync with Tramp 2.2.6-pre. === modified file 'doc/misc/gnus.texi' --- doc/misc/gnus.texi 2012-04-04 07:54:02 +0000 +++ doc/misc/gnus.texi 2012-06-11 22:35:02 +0000 @@ -4588,6 +4588,11 @@ ""))) @end lisp +To see what variables are dynamically bound (like +@code{gnus-tmp-group}), you have to look at the source code. The +variable names aren't guaranteed to be stable over Gnus versions, +either. + @node File Commands @subsection File Commands === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2012-06-10 23:27:32 +0000 +++ lisp/gnus/ChangeLog 2012-06-11 22:35:02 +0000 @@ -1,3 +1,8 @@ +2012-04-14 Wolfgang Jenkner + + * gnus-agent.el (gnus-agent-retrieve-headers): Recalculate the range of + articles when fetch-old is non-nil (bug#11370). + 2012-06-10 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-get-new-news): Respect === modified file 'lisp/gnus/gnus-agent.el' --- lisp/gnus/gnus-agent.el 2012-02-28 08:17:21 +0000 +++ lisp/gnus/gnus-agent.el 2012-06-11 22:35:02 +0000 @@ -3742,6 +3742,13 @@ (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) + (when fetch-old + (setq articles (gnus-uncompress-range + (cons (if (numberp fetch-old) + (max 1 (- (car articles) fetch-old)) + 1) + (car (last articles)))))) + ;; Populate temp buffer with known headers (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer @@ -3778,12 +3785,7 @@ (set-buffer nntp-server-buffer) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) - (min (cond ((numberp fetch-old) - (max 1 (- (car articles) fetch-old))) - (fetch-old - 1) - (t - (car articles)))) + (min (car articles)) (max (car (last articles)))) ;; Get the list of articles that were fetched @@ -3858,8 +3860,7 @@ (not (numberp fetch-old))) t ; Don't remove anything. (nnheader-nov-delete-outside-range - (if fetch-old (max 1 (- (car articles) fetch-old)) - (car articles)) + (car articles) (car (last articles))) t) ------------------------------------------------------------ revno: 108564 committer: Glenn Morris branch nick: trunk timestamp: Mon 2012-06-11 17:07:58 -0400 message: Change face used for fortran.el directives * lisp/progmodes/fortran.el (fortran-font-lock-keywords-3): Use preprocessor face for directives. (fortran-directive-re): Doc fix. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 20:47:33 +0000 +++ lisp/ChangeLog 2012-06-11 21:07:58 +0000 @@ -1,3 +1,9 @@ +2012-06-11 Glenn Morris + + * progmodes/fortran.el (fortran-font-lock-keywords-3): + Use preprocessor face for directives. + (fortran-directive-re): Doc fix. + 2012-06-11 Stefan Monnier * emacs-lisp/cl-macs.el (cl-parse-loop-clause): Fix error in recent === modified file 'lisp/progmodes/fortran.el' --- lisp/progmodes/fortran.el 2012-01-19 07:21:25 +0000 +++ lisp/progmodes/fortran.el 2012-06-11 21:07:58 +0000 @@ -165,7 +165,7 @@ (defcustom fortran-directive-re "^[ \t]*#.*" "Regexp to match a directive line. -The matching text will be fontified with `font-lock-keyword-face'. +The matching text will be fontified with `font-lock-preprocessor-face'. The matching line will be given zero indentation." :version "22.1" :type 'regexp @@ -452,7 +452,7 @@ ;; Standard continuation character and in a TAB-formatted line. '("^ \\{5\\}\\([^ 0\n]\\)" 1 font-lock-string-face) '("^\t\\([1-9]\\)" 1 font-lock-string-face)) - `((,fortran-directive-re (0 font-lock-keyword-face t))) + `((,fortran-directive-re (0 font-lock-preprocessor-face t))) ;; `fortran-font-lock-keywords-2' without types (see above). (cdr (nthcdr (length fortran-font-lock-keywords-1) fortran-font-lock-keywords-2))) ------------------------------------------------------------ revno: 108563 fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=11652 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-06-11 16:47:33 -0400 message: * lisp/emacs-lisp/cl-macs.el (cl-parse-loop-clause): Fix error in recent conversion to backquotes. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 20:35:00 +0000 +++ lisp/ChangeLog 2012-06-11 20:47:33 +0000 @@ -1,5 +1,8 @@ 2012-06-11 Stefan Monnier + * emacs-lisp/cl-macs.el (cl-parse-loop-clause): Fix error in recent + conversion to backquotes (bug#11652). + Fix compiler-expansion of CL's cXXr functions (bug#11673). * emacs-lisp/cl-lib.el (cl--defalias): New function. (cl-values, cl-values-list, cl-copy-seq, cl-svref, cl-first) @@ -15,6 +18,7 @@ * emacs-lisp/cl-macs.el (cl--compiler-macro-adjoin) (cl--compiler-macro-list*): Add autoload cookie. (cl--compiler-macro-cXXr): New function. + * help-fns.el (help-fns--compiler-macro): New function extracted from describe-function-1; follow aliases and use `compiler-macro' property. (describe-function-1): Use it. === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-11 20:35:00 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-06-11 20:47:33 +0000 @@ -1108,7 +1108,7 @@ (let ((temp-len (make-symbol "--cl-len--"))) (push (list temp-len `(length ,temp-seq)) loop-for-bindings) - (push (list var `(elt ,temp-seq temp-idx)) + (push (list var `(elt ,temp-seq ,temp-idx)) cl--loop-symbol-macs) (push `(< ,temp-idx ,temp-len) cl--loop-body)) (push (list var nil) loop-for-bindings) ------------------------------------------------------------ revno: 108562 fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=11673 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-06-11 16:35:00 -0400 message: Fix compiler-expansion of CL's cXXr functions. * emacs-lisp/cl-lib.el (cl--defalias): New function. (cl-values, cl-values-list, cl-copy-seq, cl-svref, cl-first) (cl-second, cl-rest, cl-endp, cl-third, cl-fourth): Use it. (cl-plusp, cl-minusp, cl-fifth, cl-sixth, cl-seventh, cl-eighth) (cl-ninth, cl-tenth): Mark them as inlinable. (cl-caaar, cl-caadr, cl-cadar, cl-caddr, cl-cdaar, cl-cdadr) (cl-cddar, cl-cdddr, cl-caaaar, cl-caaadr, cl-caadar, cl-caaddr) (cl-cadaar, cl-cadadr, cl-caddar, cl-cadddr, cl-cdaaar, cl-cdaadr) (cl-cdadar, cl-cdaddr, cl-cddaar, cl-cddadr, cl-cdddar, cl-cddddr): Add a compiler-macro declaration to use cl--compiler-macro-cXXr. (cl-list*, cl-adjoin): Don't put an autoload manually. * emacs-lisp/cl-macs.el (cl--compiler-macro-adjoin) (cl--compiler-macro-list*): Add autoload cookie. (cl--compiler-macro-cXXr): New function. * help-fns.el (help-fns--compiler-macro): New function extracted from describe-function-1; follow aliases and use `compiler-macro' property. (describe-function-1): Use it. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 15:55:32 +0000 +++ lisp/ChangeLog 2012-06-11 20:35:00 +0000 @@ -1,3 +1,24 @@ +2012-06-11 Stefan Monnier + + Fix compiler-expansion of CL's cXXr functions (bug#11673). + * emacs-lisp/cl-lib.el (cl--defalias): New function. + (cl-values, cl-values-list, cl-copy-seq, cl-svref, cl-first) + (cl-second, cl-rest, cl-endp, cl-third, cl-fourth): Use it. + (cl-plusp, cl-minusp, cl-fifth, cl-sixth, cl-seventh, cl-eighth) + (cl-ninth, cl-tenth): Mark them as inlinable. + (cl-caaar, cl-caadr, cl-cadar, cl-caddr, cl-cdaar, cl-cdadr) + (cl-cddar, cl-cdddr, cl-caaaar, cl-caaadr, cl-caadar, cl-caaddr) + (cl-cadaar, cl-cadadr, cl-caddar, cl-cadddr, cl-cdaaar, cl-cdaadr) + (cl-cdadar, cl-cdaddr, cl-cddaar, cl-cddadr, cl-cdddar, cl-cddddr): + Add a compiler-macro declaration to use cl--compiler-macro-cXXr. + (cl-list*, cl-adjoin): Don't put an autoload manually. + * emacs-lisp/cl-macs.el (cl--compiler-macro-adjoin) + (cl--compiler-macro-list*): Add autoload cookie. + (cl--compiler-macro-cXXr): New function. + * help-fns.el (help-fns--compiler-macro): New function extracted from + describe-function-1; follow aliases and use `compiler-macro' property. + (describe-function-1): Use it. + 2012-06-11 Chong Yidong * startup.el (fancy-splash-head): Use splash.svg even if librsvg === modified file 'lisp/emacs-lisp/cl-lib.el' --- lisp/emacs-lisp/cl-lib.el 2012-06-11 15:52:50 +0000 +++ lisp/emacs-lisp/cl-lib.el 2012-06-11 20:35:00 +0000 @@ -217,21 +217,23 @@ ;; simulated. Instead, cl-multiple-value-bind and friends simply expect ;; the target form to return the values as a list. -(defalias 'cl-values #'list +(defun cl--defalias (cl-f el-f &optional doc) + (defalias cl-f el-f doc) + (put cl-f 'byte-optimizer 'byte-compile-inline-expand)) + +(cl--defalias 'cl-values #'list "Return multiple values, Common Lisp style. The arguments of `cl-values' are the values that the containing function should return. \(fn &rest VALUES)") -(put 'cl-values 'byte-optimizer 'byte-compile-inline-expand) -(defalias 'cl-values-list #'identity +(cl--defalias 'cl-values-list #'identity "Return multiple values, Common Lisp style, taken from a list. LIST specifies the list of values that the containing function should return. \(fn LIST)") -(put 'cl-values-list 'byte-optimizer 'byte-compile-inline-expand) (defsubst cl-multiple-value-list (expression) "Return a list of the multiple values produced by EXPRESSION. @@ -300,11 +302,11 @@ always returns nil." (and (numberp object) (not (integerp object)))) -(defun cl-plusp (number) +(defsubst cl-plusp (number) "Return t if NUMBER is positive." (> number 0)) -(defun cl-minusp (number) +(defsubst cl-minusp (number) "Return t if NUMBER is negative." (< number 0)) @@ -367,7 +369,7 @@ ;;; Sequence functions. -(defalias 'cl-copy-seq 'copy-sequence) +(cl--defalias 'cl-copy-seq 'copy-sequence) (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) @@ -387,141 +389,160 @@ (nreverse cl-res))) (mapcar cl-func cl-x))) -(defalias 'cl-svref 'aref) +(cl--defalias 'cl-svref 'aref) ;;; List functions. -(defalias 'cl-first 'car) -(defalias 'cl-second 'cadr) -(defalias 'cl-rest 'cdr) -(defalias 'cl-endp 'null) - -(defun cl-third (x) - "Return the cl-third element of the list X." - (car (cdr (cdr x)))) - -(defun cl-fourth (x) - "Return the cl-fourth element of the list X." - (nth 3 x)) - -(defun cl-fifth (x) - "Return the cl-fifth element of the list X." +(cl--defalias 'cl-first 'car) +(cl--defalias 'cl-second 'cadr) +(cl--defalias 'cl-rest 'cdr) +(cl--defalias 'cl-endp 'null) + +(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") +(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") + +(defsubst cl-fifth (x) + "Return the fifth element of the list X." (nth 4 x)) -(defun cl-sixth (x) - "Return the cl-sixth element of the list X." +(defsubst cl-sixth (x) + "Return the sixth element of the list X." (nth 5 x)) -(defun cl-seventh (x) - "Return the cl-seventh element of the list X." +(defsubst cl-seventh (x) + "Return the seventh element of the list X." (nth 6 x)) -(defun cl-eighth (x) - "Return the cl-eighth element of the list X." +(defsubst cl-eighth (x) + "Return the eighth element of the list X." (nth 7 x)) -(defun cl-ninth (x) - "Return the cl-ninth element of the list X." +(defsubst cl-ninth (x) + "Return the ninth element of the list X." (nth 8 x)) -(defun cl-tenth (x) - "Return the cl-tenth element of the list X." +(defsubst cl-tenth (x) + "Return the tenth element of the list X." (nth 9 x)) (defun cl-caaar (x) "Return the `car' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (car (car x)))) (defun cl-caadr (x) "Return the `car' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (car (cdr x)))) (defun cl-cadar (x) "Return the `car' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (cdr (car x)))) (defun cl-caddr (x) "Return the `car' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (cdr (cdr x)))) (defun cl-cdaar (x) "Return the `cdr' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (car (car x)))) (defun cl-cdadr (x) "Return the `cdr' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (car (cdr x)))) (defun cl-cddar (x) "Return the `cdr' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (cdr (car x)))) (defun cl-cdddr (x) "Return the `cdr' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (cdr (cdr x)))) (defun cl-caaaar (x) "Return the `car' of the `car' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (car (car (car x))))) (defun cl-caaadr (x) "Return the `car' of the `car' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (car (car (cdr x))))) (defun cl-caadar (x) "Return the `car' of the `car' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (car (cdr (car x))))) (defun cl-caaddr (x) "Return the `car' of the `car' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (car (cdr (cdr x))))) (defun cl-cadaar (x) "Return the `car' of the `cdr' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (cdr (car (car x))))) (defun cl-cadadr (x) "Return the `car' of the `cdr' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (cdr (car (cdr x))))) (defun cl-caddar (x) "Return the `car' of the `cdr' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (cdr (cdr (car x))))) (defun cl-cadddr (x) "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (car (cdr (cdr (cdr x))))) (defun cl-cdaaar (x) "Return the `cdr' of the `car' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (car (car (car x))))) (defun cl-cdaadr (x) "Return the `cdr' of the `car' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (car (car (cdr x))))) (defun cl-cdadar (x) "Return the `cdr' of the `car' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (car (cdr (car x))))) (defun cl-cdaddr (x) "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (car (cdr (cdr x))))) (defun cl-cddaar (x) "Return the `cdr' of the `cdr' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (cdr (car (car x))))) (defun cl-cddadr (x) "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (cdr (car (cdr x))))) (defun cl-cdddar (x) "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (cdr (cdr (car x))))) (defun cl-cddddr (x) "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) (cdr (cdr (cdr (cdr x))))) ;;(defun last* (x &optional n) @@ -548,7 +569,6 @@ (last (nthcdr (- n 2) copy))) (setcdr last (car (cdr last))) (cons arg copy))))) -(autoload 'cl--compiler-macro-list* "cl-macs") (defun cl-ldiff (list sublist) "Return a copy of LIST with the tail SUBLIST removed." @@ -585,7 +605,6 @@ ((or (equal cl-keys '(:test equal)) (null cl-keys)) (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) -(autoload 'cl--compiler-macro-adjoin "cl-macs") (defun cl-subst (cl-new cl-old cl-tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (non-destructively). === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-06-11 15:52:50 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-06-11 20:35:00 +0000 @@ -254,18 +254,20 @@ ;;;*** -;;;### (autoloads (cl-defsubst cl-compiler-macroexpand cl-define-compiler-macro -;;;;;; cl-assert cl-check-type cl-typep cl-deftype cl-struct-setf-expander -;;;;;; cl-defstruct cl-define-modify-macro cl-callf2 cl-callf cl-letf* -;;;;;; cl-letf cl-rotatef cl-shiftf cl-remf cl-do-pop cl-psetf cl-setf -;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-expander cl-declare -;;;;;; cl-the cl-locally cl-multiple-value-setq cl-multiple-value-bind -;;;;;; cl-symbol-macrolet cl-macrolet cl-labels cl-flet cl-progv -;;;;;; cl-psetq cl-do-all-symbols cl-do-symbols cl-dotimes cl-dolist -;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase -;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when -;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp -;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "a8ede90b4a2ce9015d4b63254b4678a2") +;;;### (autoloads (cl--compiler-macro-cXXr cl--compiler-macro-list* +;;;;;; cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand +;;;;;; cl-define-compiler-macro cl-assert cl-check-type cl-typep +;;;;;; cl-deftype cl-struct-setf-expander cl-defstruct cl-define-modify-macro +;;;;;; cl-callf2 cl-callf cl-letf* cl-letf cl-rotatef cl-shiftf +;;;;;; cl-remf cl-do-pop cl-psetf cl-setf cl-get-setf-method cl-defsetf +;;;;;; cl-define-setf-expander cl-declare cl-the cl-locally cl-multiple-value-setq +;;;;;; cl-multiple-value-bind cl-symbol-macrolet cl-macrolet cl-labels +;;;;;; cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols +;;;;;; cl-dotimes cl-dolist cl-do* cl-do cl-loop cl-return-from +;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case +;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function +;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" +;;;;;; "5eba72da8ff76ec1346aa355feb936cb") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ @@ -777,6 +779,21 @@ \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) +(autoload 'cl--compiler-macro-adjoin "cl-macs" "\ + + +\(fn FORM A LIST &rest KEYS)" nil nil) + +(autoload 'cl--compiler-macro-list* "cl-macs" "\ + + +\(fn FORM ARG &rest OTHERS)" nil nil) + +(autoload 'cl--compiler-macro-cXXr "cl-macs" "\ + + +\(fn FORM X)" nil nil) + ;;;*** ;;;### (autoloads (cl-tree-equal cl-nsublis cl-sublis cl-nsubst-if-not === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-11 15:52:50 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-06-11 20:35:00 +0000 @@ -3011,12 +3011,14 @@ `(assoc ,a ,list) `(assq ,a ,list))) (t form)))) +;;;###autoload (defun cl--compiler-macro-adjoin (form a list &rest keys) (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) (not (memq :key keys))) `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) form)) +;;;###autoload (defun cl--compiler-macro-list* (_form arg &rest others) (let* ((args (reverse (cons arg others))) (form (car args))) @@ -3035,27 +3037,34 @@ (cl--make-type-test temp (cl--const-expr-val type))) form)) +;;;###autoload +(defun cl--compiler-macro-cXXr (form x) + (let* ((head (car form)) + (n (symbol-name (car form))) + (i (- (length n) 2))) + (if (not (string-match "c[ad]+r\\'" n)) + (if (and (fboundp head) (symbolp (symbol-function head))) + (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form)) + x) + (error "Compiler macro for cXXr applied to non-cXXr form")) + (while (> i (match-beginning 0)) + (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x)) + (setq i (1- i))) + x))) -(mapc (lambda (y) - (put (car y) 'side-effect-free t) - (put (car y) 'compiler-macro - `(lambda (_w x) - ,(if (symbolp (cadr y)) - `(list ',(cadr y) - (list ',(cl-caddr y) x)) - (cons 'list (cdr y)))))) - '((cl-first 'car x) (cl-second 'cadr x) (cl-third 'cl-caddr x) (cl-fourth 'cl-cadddr x) - (cl-fifth 'nth 4 x) (cl-sixth 'nth 5 x) (cl-seventh 'nth 6 x) - (cl-eighth 'nth 7 x) (cl-ninth 'nth 8 x) (cl-tenth 'nth 9 x) - (cl-rest 'cdr x) (cl-endp 'null x) (cl-plusp '> x 0) (cl-minusp '< x 0) - (cl-caaar car caar) (cl-caadr car cadr) (cl-cadar car cdar) - (cl-caddr car cddr) (cl-cdaar cdr caar) (cl-cdadr cdr cadr) - (cl-cddar cdr cdar) (cl-cdddr cdr cddr) (cl-caaaar car cl-caaar) - (cl-caaadr car cl-caadr) (cl-caadar car cl-cadar) (cl-caaddr car cl-caddr) - (cl-cadaar car cl-cdaar) (cl-cadadr car cl-cdadr) (cl-caddar car cl-cddar) - (cl-cadddr car cl-cdddr) (cl-cdaaar cdr cl-caaar) (cl-cdaadr cdr cl-caadr) - (cl-cdadar cdr cl-cadar) (cl-cdaddr cdr cl-caddr) (cl-cddaar cdr cl-cdaar) - (cl-cddadr cdr cl-cdadr) (cl-cdddar cdr cl-cddar) (cl-cddddr cdr cl-cdddr) )) +(dolist (y '(cl-first cl-second cl-third cl-fourth + cl-fifth cl-sixth cl-seventh + cl-eighth cl-ninth cl-tenth + cl-rest cl-endp cl-plusp cl-minusp + cl-caaar cl-caadr cl-cadar + cl-caddr cl-cdaar cl-cdadr + cl-cddar cl-cdddr cl-caaaar + cl-caaadr cl-caadar cl-caaddr + cl-cadaar cl-cadadr cl-caddar + cl-cadddr cl-cdaaar cl-cdaadr + cl-cdadar cl-cdaddr cl-cddaar + cl-cddadr cl-cdddar cl-cddddr)) + (put y 'side-effect-free t)) ;;; Things that are inline. (cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery === modified file 'lisp/help-fns.el' --- lisp/help-fns.el 2012-06-11 15:52:50 +0000 +++ lisp/help-fns.el 2012-06-11 20:35:00 +0000 @@ -380,6 +380,27 @@ (declare-function ad-get-advice-info "advice" (function)) +(defun help-fns--compiler-macro (function) + (let ((handler nil)) + ;; FIXME: Copied from macroexp.el. + (while (and (symbolp function) + (not (setq handler (get function 'compiler-macro))) + (fboundp function)) + ;; Follow the sequence of aliases. + (setq function (symbol-function function))) + (when handler + (princ "This function has a compiler macro") + (let ((lib (get function 'compiler-macro-file))) + ;; FIXME: rather than look at the compiler-macro-file property, + ;; just look at `handler' itself. + (when (stringp lib) + (princ (format " in `%s'" lib)) + (with-current-buffer standard-output + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-cmacro function lib))))) + (princ ".\n\n")))) + ;;;###autoload (defun describe-function-1 (function) (let* ((advised (and (symbolp function) (featurep 'advice) @@ -509,20 +530,7 @@ (fill-region-as-paragraph pt2 (point)) (unless (looking-back "\n\n") (terpri))))) - ;; Note that list* etc do not get this property until - ;; cl--hack-byte-compiler runs, after bytecomp is loaded. - (when (and (symbolp function) - (eq (get function 'byte-compile) - 'cl-byte-compile-compiler-macro)) - (princ "This function has a compiler macro") - (let ((lib (get function 'compiler-macro-file))) - (when (stringp lib) - (princ (format " in `%s'" lib)) - (with-current-buffer standard-output - (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) - (help-xref-button 1 'help-function-cmacro function lib))))) - (princ ".\n\n")) + (help-fns--compiler-macro function) (let* ((advertised (gethash def advertised-signature-table t)) (arglist (if (listp advertised) advertised (help-function-arglist def))) ------------------------------------------------------------ revno: 108561 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-06-11 23:55:32 +0800 message: Tweak startup image choice logic. * startup.el (fancy-splash-head): Use splash.svg even if librsvg is uninstalled, if imagemagick is installed. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 15:52:50 +0000 +++ lisp/ChangeLog 2012-06-11 15:55:32 +0000 @@ -1,3 +1,8 @@ +2012-06-11 Chong Yidong + + * startup.el (fancy-splash-head): Use splash.svg even if librsvg + is uninstalled, if imagemagick is installed. + 2012-06-11 Stefan Monnier * emacs-lisp/cl-lib.el: Use lexical-binding. === modified file 'lisp/startup.el' --- lisp/startup.el 2012-06-08 13:18:26 +0000 +++ lisp/startup.el 2012-06-11 15:55:32 +0000 @@ -1491,7 +1491,8 @@ (if (image-type-available-p 'xpm) "splash.xpm" "splash.pbm")) - ((image-type-available-p 'svg) + ((or (image-type-available-p 'svg) + (image-type-available-p 'imagemagick)) "splash.svg") ((image-type-available-p 'png) "splash.png") ------------------------------------------------------------ revno: 108560 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-06-11 11:52:50 -0400 message: Use lexical-binding for all of CL, and clean up its namespace. * lisp/emacs-lisp/cl-lib.el: Use lexical-binding. (cl-map-extents, cl-maclisp-member): Remove. (cl--set-elt, cl--set-nthcdr, cl--set-buffer-substring) (cl--set-substring, cl--block-wrapper, cl--block-throw) (cl--compiling-file, cl--mapcar-many, cl--do-subst): Use "cl--" prefix. * lisp/emacs-lisp/cl-extra.el: Use lexical-binding. (cl--mapcar-many, cl--map-keymap-recursively, cl--map-intervals) (cl--map-overlays, cl--set-frame-visible-p, cl--progv-save) (cl--progv-before, cl--progv-after, cl--finite-do, cl--set-getf) (cl--do-remf, cl--do-prettyprint): Use "cl--" prefix. * lisp/emacs-lisp/cl-seq.el: Use lexical-binding. (cl--parsing-keywords, cl--check-key, cl--check-test-nokey) (cl--check-test, cl--check-match): Use "cl--" prefix and backquotes. (cl--alist, cl--sublis-rec, cl--nsublis-rec, cl--tree-equal-rec): * lisp/emacs-lisp/cl-macs.el (cl--lambda-list-keywords): Use "cl--" prefix. * lisp/edmacro.el (edmacro-mismatch): Simplify to remove dependence on CL's internals. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 10:30:07 +0000 +++ lisp/ChangeLog 2012-06-11 15:52:50 +0000 @@ -1,3 +1,23 @@ +2012-06-11 Stefan Monnier + + * emacs-lisp/cl-lib.el: Use lexical-binding. + (cl-map-extents, cl-maclisp-member): Remove. + (cl--set-elt, cl--set-nthcdr, cl--set-buffer-substring) + (cl--set-substring, cl--block-wrapper, cl--block-throw) + (cl--compiling-file, cl--mapcar-many, cl--do-subst): Use "cl--" prefix. + * emacs-lisp/cl-extra.el: Use lexical-binding. + (cl--mapcar-many, cl--map-keymap-recursively, cl--map-intervals) + (cl--map-overlays, cl--set-frame-visible-p, cl--progv-save) + (cl--progv-before, cl--progv-after, cl--finite-do, cl--set-getf) + (cl--do-remf, cl--do-prettyprint): Use "cl--" prefix. + * emacs-lisp/cl-seq.el: Use lexical-binding. + (cl--parsing-keywords, cl--check-key, cl--check-test-nokey) + (cl--check-test, cl--check-match): Use "cl--" prefix and backquotes. + (cl--alist, cl--sublis-rec, cl--nsublis-rec, cl--tree-equal-rec): + * emacs-lisp/cl-macs.el (cl--lambda-list-keywords): Use "cl--" prefix. + * edmacro.el (edmacro-mismatch): Simplify to remove dependence on + CL's internals. + 2012-06-11 Michael Albinus Sync with Tramp 2.2.6-pre. === modified file 'lisp/edmacro.el' --- lisp/edmacro.el 2012-01-19 07:21:25 +0000 +++ lisp/edmacro.el 2012-06-11 15:52:50 +0000 @@ -594,28 +594,19 @@ Return nil if the sequences match. If one sequence is a prefix of the other, the return value indicates the end of the shorted sequence. \n(fn SEQ1 SEQ2 START1 END1 START2 END2)" - (let (cl-test cl-test-not cl-key cl-from-end) - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if cl-from-end - (progn - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (elt cl-seq1 (1- cl-end1)) - (elt cl-seq2 (1- cl-end2)))) - (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - (1- cl-end1))) - (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) - (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (if cl-p1 (car cl-p1) - (aref cl-seq1 cl-start1)) - (if cl-p2 (car cl-p2) - (aref cl-seq2 cl-start2)))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) - cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - cl-start1))))) + (or cl-end1 (setq cl-end1 (length cl-seq1))) + (or cl-end2 (setq cl-end2 (length cl-seq2))) + (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) + (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) + (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) + (eql (if cl-p1 (car cl-p1) + (aref cl-seq1 cl-start1)) + (if cl-p2 (car cl-p2) + (aref cl-seq2 cl-start2)))) + (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) + cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) + (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) + cl-start1))) (defun edmacro-subseq (seq start &optional end) "Return the subsequence of SEQ from START to END. === modified file 'lisp/emacs-lisp/bytecomp.el' --- lisp/emacs-lisp/bytecomp.el 2012-06-10 13:28:26 +0000 +++ lisp/emacs-lisp/bytecomp.el 2012-06-11 15:52:50 +0000 @@ -1399,18 +1399,18 @@ ;; These aren't all aliases of subrs, so not trivial to ;; avoid hardwiring the list. (not (memq func - '(cl-block-wrapper cl-block-throw + '(cl--block-wrapper cl--block-throw multiple-value-call nth-value copy-seq first second rest endp cl-member ;; These are included in generated code ;; that can't be called except at compile time ;; or unless cl is loaded anyway. - cl-defsubst-expand cl-struct-setf-expander + cl--defsubst-expand cl-struct-setf-expander ;; These would sometimes be warned about ;; but such warnings are never useful, ;; so don't warn about them. macroexpand cl-macroexpand-all - cl-compiling-file)))) + cl--compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) === modified file 'lisp/emacs-lisp/cl-extra.el' --- lisp/emacs-lisp/cl-extra.el 2012-06-09 02:26:47 +0000 +++ lisp/emacs-lisp/cl-extra.el 2012-06-11 15:52:50 +0000 @@ -1,4 +1,4 @@ -;;; cl-extra.el --- Common Lisp features, part 2 +;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*- ;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc. @@ -88,7 +88,7 @@ ;;; Control structures. ;;;###autoload -(defun cl-mapcar-many (cl-func cl-seqs) +(defun cl--mapcar-many (cl-func cl-seqs) (if (cdr (cdr cl-seqs)) (let* ((cl-res nil) (cl-n (apply 'min (mapcar 'length cl-seqs))) @@ -222,7 +222,7 @@ (not (apply 'cl-every cl-pred cl-seq cl-rest))) ;;;###autoload -(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) +(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base) (or cl-base (setq cl-base (copy-sequence [0]))) (map-keymap @@ -230,14 +230,14 @@ (lambda (cl-key cl-bind) (aset cl-base (1- (length cl-base)) cl-key) (if (keymapp cl-bind) - (cl-map-keymap-recursively + (cl--map-keymap-recursively cl-func-rec cl-bind (vconcat cl-base (list 0))) (funcall cl-func-rec cl-base cl-bind)))) cl-map)) ;;;###autoload -(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) +(defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) (or cl-what (setq cl-what (current-buffer))) (if (bufferp cl-what) (let (cl-mark cl-mark2 (cl-next t) cl-next2) @@ -265,7 +265,7 @@ (setq cl-start cl-next))))) ;;;###autoload -(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) +(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) (or cl-buffer (setq cl-buffer (current-buffer))) (if (fboundp 'overlay-lists) @@ -307,30 +307,30 @@ ;;; Support for `cl-setf'. ;;;###autoload -(defun cl-set-frame-visible-p (frame val) +(defun cl--set-frame-visible-p (frame val) (cond ((null val) (make-frame-invisible frame)) ((eq val 'icon) (iconify-frame frame)) (t (make-frame-visible frame))) val) ;;; Support for `cl-progv'. -(defvar cl-progv-save) +(defvar cl--progv-save) ;;;###autoload -(defun cl-progv-before (syms values) +(defun cl--progv-before (syms values) (while syms (push (if (boundp (car syms)) (cons (car syms) (symbol-value (car syms))) - (car syms)) cl-progv-save) + (car syms)) cl--progv-save) (if values (set (pop syms) (pop values)) (makunbound (pop syms))))) -(defun cl-progv-after () - (while cl-progv-save - (if (consp (car cl-progv-save)) - (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) - (makunbound (car cl-progv-save))) - (pop cl-progv-save))) +(defun cl--progv-after () + (while cl--progv-save + (if (consp (car cl--progv-save)) + (set (car (car cl--progv-save)) (cdr (car cl--progv-save))) + (makunbound (car cl--progv-save))) + (pop cl--progv-save))) ;;; Numbers. @@ -469,8 +469,8 @@ ;; Implementation limits. -(defun cl-finite-do (func a b) - (condition-case err +(defun cl--finite-do (func a b) + (condition-case _ (let ((res (funcall func a b))) ; check for IEEE infinity (and (numberp res) (/= res (/ res 2)) res)) (arith-error nil))) @@ -485,25 +485,25 @@ (or cl-most-positive-float (not (numberp '2e1)) (let ((x '2e0) y z) ;; Find maximum exponent (first two loops are optimizations) - (while (cl-finite-do '* x x) (setq x (* x x))) - (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) - (while (cl-finite-do '+ x x) (setq x (+ x x))) + (while (cl--finite-do '* x x) (setq x (* x x))) + (while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) + (while (cl--finite-do '+ x x) (setq x (+ x x))) (setq z x y (/ x 2)) ;; Now cl-fill in 1's in the mantissa. - (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) + (while (and (cl--finite-do '+ x y) (/= (+ x y) x)) (setq x (+ x y) y (/ y 2))) (setq cl-most-positive-float x cl-most-negative-float (- x)) ;; Divide down until mantissa starts rounding. (setq x (/ x z) y (/ 16 z) x (* x y)) - (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) + (while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) (arith-error nil)) (setq x (/ x 2) y (/ y 2))) (setq cl-least-positive-normalized-float y cl-least-negative-normalized-float (- y)) ;; Divide down until value underflows to zero. (setq x (/ 1 z) y x) - (while (condition-case err (> (/ x 2) 0) (arith-error nil)) + (while (condition-case _ (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) (setq cl-least-positive-float x cl-least-negative-float (- x)) @@ -612,13 +612,13 @@ (if plist (car (cdr plist)) def)))) ;;;###autoload -(defun cl-set-getf (plist tag val) +(defun cl--set-getf (plist tag val) (let ((p plist)) (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist)))) ;;;###autoload -(defun cl-do-remf (plist tag) +(defun cl--do-remf (plist tag) (let ((p (cdr plist))) (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) @@ -630,7 +630,7 @@ (let ((plist (symbol-plist sym))) (if (and plist (eq tag (car plist))) (progn (setplist sym (cdr (cdr plist))) t) - (cl-do-remf plist tag)))) + (cl--do-remf plist tag)))) ;;; Some debugging aids. @@ -646,15 +646,15 @@ (forward-sexp) (delete-char 1)) (goto-char (1+ pt)) - (cl-do-prettyprint))) + (cl--do-prettyprint))) -(defun cl-do-prettyprint () +(defun cl--do-prettyprint () (skip-chars-forward " ") (if (looking-at "(") (let ((skip (or (looking-at "((") (looking-at "(prog") (looking-at "(unwind-protect ") (looking-at "(function (") - (looking-at "(cl-block-wrapper "))) + (looking-at "(cl--block-wrapper "))) (two (or (looking-at "(defun ") (looking-at "(defmacro "))) (let (or (looking-at "(let\\*? ") (looking-at "(while "))) (set (looking-at "(p?set[qf] "))) @@ -664,21 +664,21 @@ (and (>= (current-column) 78) (progn (backward-sexp) t)))) (let ((nl t)) (forward-char 1) - (cl-do-prettyprint) - (or skip (looking-at ")") (cl-do-prettyprint)) - (or (not two) (looking-at ")") (cl-do-prettyprint)) + (cl--do-prettyprint) + (or skip (looking-at ")") (cl--do-prettyprint)) + (or (not two) (looking-at ")") (cl--do-prettyprint)) (while (not (looking-at ")")) (if set (setq nl (not nl))) (if nl (insert "\n")) (lisp-indent-line) - (cl-do-prettyprint)) + (cl--do-prettyprint)) (forward-char 1)))) (forward-sexp))) ;;;###autoload (defun cl-prettyexpand (form &optional full) (message "Expanding...") - (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) + (let ((cl--compiling-file full) (byte-compile-macro-environment nil)) (setq form (macroexpand-all form (and (not full) '((cl-block) (cl-eval-when))))) === modified file 'lisp/emacs-lisp/cl-lib.el' --- lisp/emacs-lisp/cl-lib.el 2012-06-10 13:28:26 +0000 +++ lisp/emacs-lisp/cl-lib.el 2012-06-11 15:52:50 +0000 @@ -1,4 +1,4 @@ -;;; cl-lib.el --- Common Lisp extensions for Emacs +;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. @@ -114,7 +114,7 @@ (defun cl-unload-function () "Stop unloading of the Common Lisp extensions." (message "Cannot unload the feature `cl'") - ;; stop standard unloading! + ;; Stop standard unloading! t) ;;; Generalized variables. @@ -185,19 +185,19 @@ (list 'setq place (cl-list* 'cl-adjoin x place keys))) (cl-list* 'cl-callf2 'cl-adjoin x place keys))) -(defun cl-set-elt (seq n val) +(defun cl--set-elt (seq n val) (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) -(defsubst cl-set-nthcdr (n list x) +(defsubst cl--set-nthcdr (n list x) (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) -(defun cl-set-buffer-substring (start end val) +(defun cl--set-buffer-substring (start end val) (save-excursion (delete-region start end) (goto-char start) (insert val) val)) -(defun cl-set-substring (str start end val) +(defun cl--set-substring (str start end val) (if end (if (< end 0) (cl-incf end (length str))) (setq end (length str))) (if (< start 0) (cl-incf start (length str))) @@ -206,19 +206,10 @@ (and (< end (length str)) (substring str end)))) -;;; Control structures. - -;; These macros are so simple and so often-used that it's better to have -;; them all the time than to load them from cl-macs.el. - -(defun cl-map-extents (&rest cl-args) - (apply 'cl-map-overlays cl-args)) - - ;;; Blocks and exits. -(defalias 'cl-block-wrapper 'identity) -(defalias 'cl-block-throw 'throw) +(defalias 'cl--block-wrapper 'identity) +(defalias 'cl--block-throw 'throw) ;;; Multiple values. @@ -269,9 +260,9 @@ ;;; Declarations. -(defvar cl-compiling-file nil) -(defun cl-compiling-file () - (or cl-compiling-file +(defvar cl--compiling-file nil) +(defun cl--compiling-file () + (or cl--compiling-file (and (boundp 'byte-compile--outbuffer) (bufferp (symbol-value 'byte-compile--outbuffer)) (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) @@ -287,7 +278,7 @@ (defmacro cl-declaim (&rest specs) (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x)))) specs))) - (if (cl-compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) + (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when @@ -378,7 +369,7 @@ (defalias 'cl-copy-seq 'copy-sequence) -(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) +(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) (defun cl-mapcar (cl-func cl-x &rest cl-rest) "Apply FUNCTION to each element of SEQ, and make a list of the results. @@ -389,7 +380,7 @@ \n(fn FUNCTION SEQ...)" (if cl-rest (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl-mapcar-many cl-func (cons cl-x cl-rest)) + (cl--mapcar-many cl-func (cons cl-x cl-rest)) (let ((cl-res nil) (cl-y (car cl-rest))) (while (and cl-x cl-y) (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) @@ -575,10 +566,6 @@ (prog1 (nreverse res) (setcdr res list))) (car list))) -(defun cl-maclisp-member (item list) - (while (and list (not (equal item (car list)))) (setq list (cdr list))) - list) - ;; Autoloaded, but we have not loaded cl-loaddefs yet. (declare-function cl-floor "cl-extra" (x &optional y)) (declare-function cl-ceiling "cl-extra" (x &optional y)) @@ -607,13 +594,13 @@ \n(fn NEW OLD TREE [KEYWORD VALUE]...)" (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) - (cl-do-subst cl-new cl-old cl-tree))) + (cl--do-subst cl-new cl-old cl-tree))) -(defun cl-do-subst (cl-new cl-old cl-tree) +(defun cl--do-subst (cl-new cl-old cl-tree) (cond ((eq cl-tree cl-old) cl-new) ((consp cl-tree) - (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) - (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) + (let ((a (cl--do-subst cl-new cl-old (car cl-tree))) + (d (cl--do-subst cl-new cl-old (cdr cl-tree)))) (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) cl-tree (cons a d)))) (t cl-tree))) === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-06-09 02:26:47 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-06-11 15:52:50 +0000 @@ -3,15 +3,15 @@ ;;; Code: -;;;### (autoloads (cl-prettyexpand cl-remprop cl-do-remf cl-set-getf +;;;### (autoloads (cl-prettyexpand cl-remprop cl--do-remf cl--set-getf ;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend ;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p ;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round -;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl-progv-before -;;;;;; cl-set-frame-visible-p cl-map-overlays cl-map-intervals cl-map-keymap-recursively -;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan -;;;;;; cl-mapl cl-maplist cl-map cl-mapcar-many cl-equalp cl-coerce) -;;;;;; "cl-extra" "cl-extra.el" "6661c504c379dfde0c37a0f8e2ba6568") +;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl--progv-before +;;;;;; cl--set-frame-visible-p cl--map-overlays cl--map-intervals +;;;;;; cl--map-keymap-recursively cl-notevery cl-notany cl-every +;;;;;; cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map cl--mapcar-many +;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "1f486111e93d119ceb6e95c434e3fd4b") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -28,7 +28,7 @@ \(fn X Y)" nil nil) -(autoload 'cl-mapcar-many "cl-extra" "\ +(autoload 'cl--mapcar-many "cl-extra" "\ \(fn CL-FUNC CL-SEQS)" nil nil) @@ -82,27 +82,27 @@ \(fn PREDICATE SEQ...)" nil nil) -(autoload 'cl-map-keymap-recursively "cl-extra" "\ +(autoload 'cl--map-keymap-recursively "cl-extra" "\ \(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil) -(autoload 'cl-map-intervals "cl-extra" "\ +(autoload 'cl--map-intervals "cl-extra" "\ \(fn CL-FUNC &optional CL-WHAT CL-PROP CL-START CL-END)" nil nil) -(autoload 'cl-map-overlays "cl-extra" "\ +(autoload 'cl--map-overlays "cl-extra" "\ \(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil) -(autoload 'cl-set-frame-visible-p "cl-extra" "\ +(autoload 'cl--set-frame-visible-p "cl-extra" "\ \(fn FRAME VAL)" nil nil) -(autoload 'cl-progv-before "cl-extra" "\ +(autoload 'cl--progv-before "cl-extra" "\ \(fn SYMS VALUES)" nil nil) @@ -232,12 +232,12 @@ \(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil) -(autoload 'cl-set-getf "cl-extra" "\ +(autoload 'cl--set-getf "cl-extra" "\ \(fn PLIST TAG VAL)" nil nil) -(autoload 'cl-do-remf "cl-extra" "\ +(autoload 'cl--do-remf "cl-extra" "\ \(fn PLIST TAG)" nil nil) @@ -265,7 +265,7 @@ ;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp -;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "9eb287dd2a8d20f1c6459a9d095fa335") +;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "a8ede90b4a2ce9015d4b63254b4678a2") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ @@ -791,7 +791,7 @@ ;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if ;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not ;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove -;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "8877479cb008b43a94098f3e6ec85d91") +;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "b444601641dcbd14a23ca5182bc80ffa") ;;; Generated autoloads from cl-seq.el (autoload 'cl-reduce "cl-seq" "\ === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-09 02:26:47 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-06-11 15:52:50 +0000 @@ -203,6 +203,65 @@ (def-edebug-spec cl-&key-arg (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) +(defconst cl--lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) + +(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) +(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) + +(defun cl--transform-lambda (form bind-block) + (let* ((args (car form)) (body (cdr form)) (orig-args args) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) + (header nil) (simple-args nil)) + (while (or (stringp (car body)) + (memq (car-safe (car body)) '(interactive cl-declare))) + (push (pop body) header)) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) + (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) + (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) + (if (setq cl--bind-enquote (memq '&cl-quote args)) + (setq args (delq '&cl-quote args))) + (if (memq '&whole args) (error "&whole not currently implemented")) + (let* ((p (memq '&environment args)) (v (cadr p)) + (env-exp 'macroexpand-all-environment)) + (if p (setq args (nconc (delq (car p) (delq v args)) + (list '&aux (list v env-exp)))))) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (not (and (eq (car args) '&optional) + (or cl--bind-defs (consp (cadr args)))))) + (push (pop args) simple-args)) + (or (eq cl--bind-block 'cl-none) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) + (if (null args) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (if (memq '&optional simple-args) (push '&optional args)) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq cl--bind-lets (nreverse cl--bind-lets)) + (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl--bind-inits))) + (nconc (nreverse simple-args) + (list '&rest (car (pop cl--bind-lets)))) + (nconc (let ((hdr (nreverse header))) + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help-fns) + (cons (help-add-fundoc-usage + (if (stringp (car hdr)) (pop hdr)) + (format "%S" + (cons 'fn + (cl--make-usage-args orig-args)))) + hdr))) + (list `(let* ,cl--bind-lets + ,@(nreverse cl--bind-forms) + ,@body))))))) + ;;;###autoload (defmacro cl-defun (name args &rest body) "Define NAME as a function. @@ -307,12 +366,6 @@ `(progn ,@(cdr (cdr (car res))) (put ',func ',prop #'(lambda . ,(cdr res)))))) -(defconst cl-lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) - -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) -(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) - (declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) (defun cl--make-usage-var (x) @@ -346,62 +399,9 @@ )))) arglist))) -(defun cl--transform-lambda (form bind-block) - (let* ((args (car form)) (body (cdr form)) (orig-args args) - (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive cl-declare))) - (push (pop body) header)) - (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) - (if (setq cl--bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) - (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p)) - (env-exp 'macroexpand-all-environment)) - (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v env-exp)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) - (or (eq cl--bind-block 'cl-none) - (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (push '&optional args)) - (cl--do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) - ,@(nreverse cl--bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) - ;; Macro expansion can take place in the middle of - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (require 'help-fns) - (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) - (format "%S" - (cons 'fn - (cl--make-usage-args orig-args)))) - hdr))) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) - (defun cl--do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) - (if (or (memq args cl-lambda-list-keywords) (not (symbolp args))) + (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) (push (list args expr) cl--bind-lets)) (setq args (cl-copy-list args)) @@ -410,7 +410,7 @@ (if (memq '&environment args) (error "&environment used incorrectly")) (let ((save-args args) (restarg (memq '&rest args)) - (safety (if (cl-compiling-file) cl-optimize-safety 3)) + (safety (if (cl--compiling-file) cl-optimize-safety 3)) (keys nil) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) @@ -422,14 +422,14 @@ (push (list (cl-pop2 args) restarg) cl--bind-lets)) (let ((p args)) (setq minarg restarg) - (while (and p (not (memq (car p) cl-lambda-list-keywords))) + (while (and p (not (memq (car p) cl--lambda-list-keywords))) (or (eq p args) (setq minarg (list 'cdr minarg))) (setq p (cdr p))) (if (memq (car p) '(nil &aux)) (setq minarg `(= (length ,restarg) ,(length (cl-ldiff args p))) exactarg (not (eq args p))))) - (while (and args (not (memq (car args) cl-lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) restarg))) (cl--do-arglist @@ -442,7 +442,7 @@ (length ,restarg))))))) (setq num (1+ num) laterarg t)) (while (and (eq (car args) '&optional) (pop args)) - (while (and args (not (memq (car args) cl-lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) @@ -466,7 +466,7 @@ (+ ,num (length ,restarg))))) cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) - (while (and args (not (memq (car args) cl-lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) (let* ((karg (if (consp (car arg)) (caar arg) @@ -511,7 +511,7 @@ (car ,var))))))) (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) cl-lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (if (consp (car args)) (if (and cl--bind-enquote (cl-cadar args)) (cl--do-arglist (caar args) @@ -525,7 +525,7 @@ (let ((res nil) (kind nil) arg) (while (consp args) (setq arg (pop args)) - (if (memq arg cl-lambda-list-keywords) (setq kind arg) + (if (memq arg cl--lambda-list-keywords) (setq kind arg) (if (eq arg '&cl-defs) (pop args) (and (consp arg) kind (setq arg (car arg))) (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) @@ -557,7 +557,7 @@ \(fn (WHEN...) BODY...)" (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) - (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) + (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl-not-toplevel t)) @@ -586,7 +586,7 @@ "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) - (if (cl-compiling-file) + (if (cl--compiling-file) (let* ((temp (cl-gentemp "--cl-load-time--")) (set `(set ',temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) @@ -700,7 +700,7 @@ called from BODY." (declare (indent 1) (debug (symbolp body))) (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) - `(cl-block-wrapper + `(cl--block-wrapper (catch ',(intern (format "--cl-block-%s--" name)) ,@body)))) @@ -720,7 +720,7 @@ `defmacro' do not create implicit blocks as they do in Common Lisp." (declare (indent 1) (debug (symbolp &optional form))) (let ((name2 (intern (format "--cl-block-%s--" name)))) - `(cl-block-throw ',name2 ,result))) + `(cl--block-throw ',name2 ,result))) ;;; The "cl-loop" macro. @@ -1151,7 +1151,7 @@ ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) (t (setq buf (cl-pop2 cl--loop-args))))) (setq cl--loop-map-form - `(cl-map-extents + `(cl--map-overlays (lambda (,var ,(make-symbol "--cl-var--")) (progn . --cl-map) nil) ,buf ,from ,to)))) @@ -1170,7 +1170,7 @@ (setq var1 (car var) var2 (cdr var)) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) (setq cl--loop-map-form - `(cl-map-intervals + `(cl--map-intervals (lambda (,var1 ,var2) . --cl-map) ,buf ,prop ,from ,to)))) @@ -1188,7 +1188,7 @@ (setq var (prog1 other (setq other var)))) (setq cl--loop-map-form `(,(if (memq word '(key-seq key-seqs)) - 'cl-map-keymap-recursively 'map-keymap) + 'cl--map-keymap-recursively 'map-keymap) (lambda (,var ,other) . --cl-map) ,cl-map)))) ((memq word '(frame frames screen screens)) @@ -1606,10 +1606,10 @@ BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." (declare (indent 2) (debug (form form body))) - `(let ((cl-progv-save nil)) + `(let ((cl--progv-save nil)) (unwind-protect - (progn (cl-progv-before ,symbols ,values) ,@body) - (cl-progv-after)))) + (progn (cl--progv-before ,symbols ,values) ,@body) + (cl--progv-after)))) (defvar cl--labels-convert-cache nil) @@ -1868,7 +1868,7 @@ will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." - (if (cl-compiling-file) + (if (cl--compiling-file) (while specs (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) (cl-do-proclaim (pop specs) nil))) @@ -2028,7 +2028,7 @@ (cl-defsetf buffer-name rename-buffer t) (cl-defsetf buffer-string () (store) `(progn (erase-buffer) (insert ,store))) -(cl-defsetf buffer-substring cl-set-buffer-substring) +(cl-defsetf buffer-substring cl--set-buffer-substring) (cl-defsetf current-buffer set-buffer) (cl-defsetf current-case-table set-case-table) (cl-defsetf current-column move-to-column t) @@ -2050,7 +2050,7 @@ (cl-defsetf file-modes set-file-modes t) (cl-defsetf frame-height set-screen-height t) (cl-defsetf frame-parameters modify-frame-parameters t) -(cl-defsetf frame-visible-p cl-set-frame-visible-p) +(cl-defsetf frame-visible-p cl--set-frame-visible-p) (cl-defsetf frame-width set-screen-width t) (cl-defsetf frame-parameter set-frame-parameter t) (cl-defsetf terminal-parameter set-terminal-parameter) @@ -2151,8 +2151,8 @@ (cons n (nth 1 method)) (list store-temp) `(let ((,(car (nth 2 method)) - (cl-set-nthcdr ,n-temp ,(nth 4 method) - ,store-temp))) + (cl--set-nthcdr ,n-temp ,(nth 4 method) + ,store-temp))) ,(nth 3 method) ,store-temp) `(nthcdr ,n-temp ,(nth 4 method))))) @@ -2165,7 +2165,7 @@ (append (nth 1 method) (list tag def)) (list store-temp) `(let ((,(car (nth 2 method)) - (cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp))) + (cl--set-getf ,(nth 4 method) ,tag-temp ,store-temp))) ,(nth 3 method) ,store-temp) `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) @@ -2178,8 +2178,8 @@ (append (nth 1 method) (list from to)) (list store-temp) `(let ((,(car (nth 2 method)) - (cl-set-substring ,(nth 4 method) - ,from-temp ,to-temp ,store-temp))) + (cl--set-substring ,(nth 4 method) + ,from-temp ,to-temp ,store-temp))) ,(nth 3 method) ,store-temp) `(substring ,(nth 4 method) ,from-temp ,to-temp)))) @@ -2325,7 +2325,7 @@ (if (eq ,ttag (car ,tval)) (progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval)) t) - `(cl-do-remf ,tval ,ttag))))) + `(cl--do-remf ,tval ,ttag))))) ;;;###autoload (defmacro cl-shiftf (place &rest args) @@ -2549,7 +2549,7 @@ (copier (intern (format "copy-%s" name))) (predicate (intern (format "%s-p" name))) (print-func nil) (print-auto nil) - (safety (if (cl-compiling-file) cl-optimize-safety 3)) + (safety (if (cl--compiling-file) cl-optimize-safety 3)) (include nil) (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) @@ -2835,7 +2835,7 @@ "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) - (and (or (not (cl-compiling-file)) + (and (or (not (cl--compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let* ((temp (if (cl--simple-expr-p form 3) form (make-symbol "--cl-var--"))) @@ -2854,7 +2854,7 @@ They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (declare (debug (form &rest form))) - (and (or (not (cl-compiling-file)) + (and (or (not (cl--compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar (lambda (x) @@ -2919,7 +2919,7 @@ (defvar cl--active-block-names nil) -(cl-define-compiler-macro cl-block-wrapper (cl-form) +(cl-define-compiler-macro cl--block-wrapper (cl-form) (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) (cl--active-block-names (cons cl-entry cl--active-block-names)) (cl-body (macroexpand-all ;Performs compiler-macro expansions. @@ -2931,7 +2931,7 @@ `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) cl-body))) -(cl-define-compiler-macro cl-block-throw (cl-tag cl-value) +(cl-define-compiler-macro cl--block-throw (cl-tag cl-value) (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) @@ -2955,7 +2955,7 @@ ,(if (memq '&key args) `(&whole cl-whole &cl-quote ,@args) (cons '&cl-quote args)) - (cl-defsubst-expand + (cl--defsubst-expand ',argns '(cl-block ,name ,@body) ;; We used to pass `simple' as ;; (not (or unsafe (cl-expr-access-order pbody argns))) @@ -2966,7 +2966,7 @@ ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns))) (cl-defun ,name ,args ,@body)))) -(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) +(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs) (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole (if (cl--simple-exprs-p argvs) (setq simple t)) (let* ((substs ()) @@ -3059,7 +3059,7 @@ ;;; Things that are inline. (cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery - cl-set-elt cl-revappend cl-nreconc gethash)) + cl--set-elt cl-revappend cl-nreconc gethash)) ;;; Things that are side-effect-free. (mapc (lambda (x) (put x 'side-effect-free t)) === modified file 'lisp/emacs-lisp/cl-seq.el' --- lisp/emacs-lisp/cl-seq.el 2012-06-09 02:26:47 +0000 +++ lisp/emacs-lisp/cl-seq.el 2012-06-11 15:52:50 +0000 @@ -1,4 +1,4 @@ -;;; cl-seq.el --- Common Lisp features, part 3 +;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*- ;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. @@ -43,99 +43,91 @@ (require 'cl-lib) -;;; Keyword parsing. This is special-cased here so that we can compile -;;; this file independent from cl-macs. +;; Keyword parsing. +;; This is special-cased here so that we can compile +;; this file independent from cl-macs. -(defmacro cl-parsing-keywords (kwords other-keys &rest body) +(defmacro cl--parsing-keywords (kwords other-keys &rest body) (declare (indent 2) (debug (sexp sexp &rest form))) - (cons - 'let* - (cons (mapcar - (function - (lambda (x) - (let* ((var (if (consp x) (car x) x)) - (mem (list 'car (list 'cdr (list 'memq (list 'quote var) - 'cl-keys))))) - (if (eq var :test-not) - (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) - (if (eq var :if-not) - (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) - (list (intern - (format "cl-%s" (substring (symbol-name var) 1))) - (if (consp x) (list 'or mem (car (cdr x))) mem))))) - kwords) - (append - (and (not (eq other-keys t)) - (list - (list 'let '((cl-keys-temp cl-keys)) - (list 'while 'cl-keys-temp - (list 'or (list 'memq '(car cl-keys-temp) - (list 'quote - (mapcar - (function - (lambda (x) - (if (consp x) - (car x) x))) - (append kwords - other-keys)))) - '(car (cdr (memq (quote :allow-other-keys) - cl-keys))) - '(error "Bad keyword argument %s" - (car cl-keys-temp))) - '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) - body)))) - -(defmacro cl-check-key (x) - (declare (debug edebug-forms)) - (list 'if 'cl-key (list 'funcall 'cl-key x) x)) - -(defmacro cl-check-test-nokey (item x) - (declare (debug edebug-forms)) - (list 'cond - (list 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test item x)) - 'cl-test-not)) - (list 'cl-if - (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) - (list 't (list 'if (list 'numberp item) - (list 'equal item x) (list 'eq item x))))) - -(defmacro cl-check-test (item x) - (declare (debug edebug-forms)) - (list 'cl-check-test-nokey item (list 'cl-check-key x))) - -(defmacro cl-check-match (x y) - (declare (debug edebug-forms)) - (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) - (list 'if 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) - (list 'if (list 'numberp x) - (list 'equal x y) (list 'eq x y)))) + `(let* ,(mapcar + (lambda (x) + (let* ((var (if (consp x) (car x) x)) + (mem `(car (cdr (memq ',var cl-keys))))) + (if (eq var :test-not) + (setq mem `(and ,mem (setq cl-test ,mem) t))) + (if (eq var :if-not) + (setq mem `(and ,mem (setq cl-if ,mem) t))) + (list (intern + (format "cl-%s" (substring (symbol-name var) 1))) + (if (consp x) `(or ,mem ,(car (cdr x))) mem)))) + kwords) + ,@(append + (and (not (eq other-keys t)) + (list + (list 'let '((cl-keys-temp cl-keys)) + (list 'while 'cl-keys-temp + (list 'or (list 'memq '(car cl-keys-temp) + (list 'quote + (mapcar + (function + (lambda (x) + (if (consp x) + (car x) x))) + (append kwords + other-keys)))) + '(car (cdr (memq (quote :allow-other-keys) + cl-keys))) + '(error "Bad keyword argument %s" + (car cl-keys-temp))) + '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) + body))) + +(defmacro cl--check-key (x) ;Expects `cl-key' in context of generated code. + (declare (debug edebug-forms)) + `(if cl-key (funcall cl-key ,x) ,x)) + +(defmacro cl--check-test-nokey (item x) ;cl-test cl-if cl-test-not cl-if-not. + (declare (debug edebug-forms)) + `(cond + (cl-test (eq (not (funcall cl-test ,item ,x)) + cl-test-not)) + (cl-if (eq (not (funcall cl-if ,x)) cl-if-not)) + (t (eql ,item ,x)))) + +(defmacro cl--check-test (item x) ;all of the above. + (declare (debug edebug-forms)) + `(cl--check-test-nokey ,item (cl--check-key ,x))) + +(defmacro cl--check-match (x y) ;cl-key cl-test cl-test-not + (declare (debug edebug-forms)) + (setq x `(cl--check-key ,x) y `(cl--check-key ,y)) + `(if cl-test + (eq (not (funcall cl-test ,x ,y)) cl-test-not) + (eql ,x ,y))) (defvar cl-test) (defvar cl-test-not) (defvar cl-if) (defvar cl-if-not) (defvar cl-key) - ;;;###autoload (defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () + (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) (setq cl-seq (cl-subseq cl-seq cl-start cl-end)) (if cl-from-end (setq cl-seq (nreverse cl-seq))) (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) - (cl-seq (cl-check-key (pop cl-seq))) + (cl-seq (cl--check-key (pop cl-seq))) (t (funcall cl-func))))) (if cl-from-end (while cl-seq - (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) + (setq cl-accum (funcall cl-func (cl--check-key (pop cl-seq)) cl-accum))) (while cl-seq (setq cl-accum (funcall cl-func cl-accum - (cl-check-key (pop cl-seq)))))) + (cl--check-key (pop cl-seq)))))) cl-accum))) ;;;###autoload @@ -143,7 +135,7 @@ "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end \n(fn SEQ ITEM [KEYWORD VALUE]...)" - (cl-parsing-keywords ((:start 0) :end) () + (cl--parsing-keywords ((:start 0) :end) () (if (listp seq) (let ((p (nthcdr cl-start seq)) (n (if cl-end (- cl-end cl-start) 8000000))) @@ -164,14 +156,14 @@ SEQ1 is destructively modified, then returned. \nKeywords supported: :start1 :end1 :start2 :end2 \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () + (cl--parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) (or (= cl-start1 cl-start2) (let* ((cl-len (length cl-seq1)) (cl-n (min (- (or cl-end1 cl-len) cl-start1) (- (or cl-end2 cl-len) cl-start2)))) (while (>= (setq cl-n (1- cl-n)) 0) - (cl-set-elt cl-seq1 (+ cl-start1 cl-n) + (cl--set-elt cl-seq1 (+ cl-start1 cl-n) (elt cl-seq2 (+ cl-start2 cl-n)))))) (if (listp cl-seq1) (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) @@ -208,7 +200,7 @@ to avoid corrupting the original SEQ. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end + (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () (if (<= (or cl-count (setq cl-count 8000000)) 0) cl-seq @@ -227,14 +219,14 @@ (setq cl-end (- (or cl-end 8000000) cl-start)) (if (= cl-start 0) (while (and cl-seq (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) + (cl--check-test cl-item (car cl-seq)) (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) (> (setq cl-count (1- cl-count)) 0)))) (if (and (> cl-count 0) (> cl-end 0)) (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) (setq cl-end (1- cl-end)) (cdr cl-seq)))) (while (and cl-p (> cl-end 0) - (not (cl-check-test cl-item (car cl-p)))) + (not (cl--check-test cl-item (car cl-p)))) (setq cl-p (cdr cl-p) cl-end (1- cl-end))) (if (and cl-p (> cl-end 0)) (nconc (cl-ldiff cl-seq cl-p) @@ -271,7 +263,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end + (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () (if (<= (or cl-count (setq cl-count 8000000)) 0) cl-seq @@ -291,7 +283,7 @@ (progn (while (and cl-seq (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) + (cl--check-test cl-item (car cl-seq)) (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) (> (setq cl-count (1- cl-count)) 0))) (setq cl-end (1- cl-end))) @@ -299,7 +291,7 @@ (if (and (> cl-count 0) (> cl-end 0)) (let ((cl-p (nthcdr cl-start cl-seq))) (while (and (cdr cl-p) (> cl-end 0)) - (if (cl-check-test cl-item (car (cdr cl-p))) + (if (cl--check-test cl-item (car (cdr cl-p))) (progn (setcdr cl-p (cdr (cdr cl-p))) (if (= (setq cl-count (1- cl-count)) 0) @@ -341,14 +333,14 @@ (defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) - (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) + (cl--parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) () (if cl-from-end (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) (while (> cl-end 1) (setq cl-i 0) - (while (setq cl-i (cl--position (cl-check-key (car cl-p)) + (while (setq cl-i (cl--position (cl--check-key (car cl-p)) (cdr cl-p) cl-i (1- cl-end))) (if cl-copy (setq cl-seq (copy-sequence cl-seq) cl-p (nthcdr cl-start cl-seq) cl-copy nil)) @@ -360,13 +352,13 @@ cl-seq) (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl--position (cl-check-key (car cl-seq)) + (cl--position (cl--check-key (car cl-seq)) (cdr cl-seq) 0 (1- cl-end))) (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) (setq cl-end (1- cl-end) cl-start 1) cl-seq))) (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl--position (cl-check-key (car (cdr cl-p))) + (if (cl--position (cl--check-key (car (cdr cl-p))) (cdr (cdr cl-p)) 0 (1- cl-end)) (progn (if cl-copy (setq cl-seq (copy-sequence cl-seq) @@ -386,7 +378,7 @@ to avoid corrupting the original SEQ. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count + (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () (if (or (eq cl-old cl-new) (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) @@ -396,7 +388,7 @@ cl-seq (setq cl-seq (copy-sequence cl-seq)) (or cl-from-end - (progn (cl-set-elt cl-seq cl-i cl-new) + (progn (cl--set-elt cl-seq cl-i cl-new) (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) @@ -425,14 +417,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count + (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) (let ((cl-p (nthcdr cl-start cl-seq))) (setq cl-end (- (or cl-end 8000000) cl-start)) (while (and cl-p (> cl-end 0) (> cl-count 0)) - (if (cl-check-test cl-old (car cl-p)) + (if (cl--check-test cl-old (car cl-p)) (progn (setcar cl-p cl-new) (setq cl-count (1- cl-count)))) @@ -441,12 +433,12 @@ (if cl-from-end (while (and (< cl-start cl-end) (> cl-count 0)) (setq cl-end (1- cl-end)) - (if (cl-check-test cl-old (elt cl-seq cl-end)) + (if (cl--check-test cl-old (elt cl-seq cl-end)) (progn - (cl-set-elt cl-seq cl-end cl-new) + (cl--set-elt cl-seq cl-end cl-new) (setq cl-count (1- cl-count))))) (while (and (< cl-start cl-end) (> cl-count 0)) - (if (cl-check-test cl-old (aref cl-seq cl-start)) + (if (cl--check-test cl-old (aref cl-seq cl-start)) (progn (aset cl-seq cl-start cl-new) (setq cl-count (1- cl-count)))) @@ -500,7 +492,7 @@ Return the index of the matching item, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not + (cl--parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end :from-end) () (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) @@ -510,7 +502,7 @@ (or cl-end (setq cl-end 8000000)) (let ((cl-res nil)) (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) - (if (cl-check-test cl-item (car cl-p)) + (if (cl--check-test cl-item (car cl-p)) (setq cl-res cl-start)) (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) cl-res)) @@ -518,10 +510,10 @@ (if cl-from-end (progn (while (and (>= (setq cl-end (1- cl-end)) cl-start) - (not (cl-check-test cl-item (aref cl-seq cl-end))))) + (not (cl--check-test cl-item (aref cl-seq cl-end))))) (and (>= cl-end cl-start) cl-end)) (while (and (< cl-start cl-end) - (not (cl-check-test cl-item (aref cl-seq cl-start)))) + (not (cl--check-test cl-item (aref cl-seq cl-start)))) (setq cl-start (1+ cl-start))) (and (< cl-start cl-end) cl-start)))) @@ -546,13 +538,13 @@ "Count the number of occurrences of ITEM in SEQ. \nKeywords supported: :test :test-not :key :start :end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () + (cl--parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () (let ((cl-count 0) cl-x) (or cl-end (setq cl-end (length cl-seq))) (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) (while (< cl-start cl-end) (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) - (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) + (if (cl--check-test cl-item cl-x) (setq cl-count (1+ cl-count))) (setq cl-start (1+ cl-start))) cl-count))) @@ -577,14 +569,14 @@ other, the return value indicates the end of the shorter sequence. \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :from-end + (cl--parsing-keywords (:test :test-not :key :from-end (:start1 0) :end1 (:start2 0) :end2) () (or cl-end1 (setq cl-end1 (length cl-seq1))) (or cl-end2 (setq cl-end2 (length cl-seq2))) (if cl-from-end (progn (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (elt cl-seq1 (1- cl-end1)) + (cl--check-match (elt cl-seq1 (1- cl-end1)) (elt cl-seq2 (1- cl-end2)))) (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) @@ -592,7 +584,7 @@ (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (if cl-p1 (car cl-p1) + (cl--check-match (if cl-p1 (car cl-p1) (aref cl-seq1 cl-start1)) (if cl-p2 (car cl-p2) (aref cl-seq2 cl-start2)))) @@ -608,14 +600,14 @@ return nil if there are no matches. \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :from-end + (cl--parsing-keywords (:test :test-not :key :from-end (:start1 0) :end1 (:start2 0) :end2) () (or cl-end1 (setq cl-end1 (length cl-seq1))) (or cl-end2 (setq cl-end2 (length cl-seq2))) (if (>= cl-start1 cl-end1) (if cl-from-end cl-end2 cl-start2) (let* ((cl-len (- cl-end1 cl-start1)) - (cl-first (cl-check-key (elt cl-seq1 cl-start1))) + (cl-first (cl--check-key (elt cl-seq1 cl-start1))) (cl-if nil) cl-pos) (setq cl-end2 (- cl-end2 (1- cl-len))) (while (and (< cl-start2 cl-end2) @@ -636,7 +628,7 @@ \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" (if (nlistp cl-seq) (cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys)) - (cl-parsing-keywords (:key) () + (cl--parsing-keywords (:key) () (if (memq cl-key '(nil identity)) (sort cl-seq cl-pred) (sort cl-seq (function (lambda (cl-x cl-y) @@ -660,16 +652,15 @@ \n(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) - (cl-parsing-keywords (:key) () + (cl--parsing-keywords (:key) () (let ((cl-res nil)) (while (and cl-seq1 cl-seq2) - (if (funcall cl-pred (cl-check-key (car cl-seq2)) - (cl-check-key (car cl-seq1))) + (if (funcall cl-pred (cl--check-key (car cl-seq2)) + (cl--check-key (car cl-seq1))) (push (pop cl-seq2) cl-res) (push (pop cl-seq1) cl-res))) (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) -;;; See compiler macro in cl-macs.el ;;;###autoload (defun cl-member (cl-item cl-list &rest cl-keys) "Find the first occurrence of ITEM in LIST. @@ -678,8 +669,8 @@ \n(fn ITEM LIST [KEYWORD VALUE]...)" (declare (compiler-macro cl--compiler-macro-member)) (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) + (cl--parsing-keywords (:test :test-not :key :if :if-not) () + (while (and cl-list (not (cl--check-test cl-item (car cl-list)))) (setq cl-list (cdr cl-list))) cl-list) (if (and (numberp cl-item) (not (integerp cl-item))) @@ -705,12 +696,11 @@ ;;;###autoload (defun cl--adjoin (cl-item cl-list &rest cl-keys) - (if (cl-parsing-keywords (:key) t - (apply 'cl-member (cl-check-key cl-item) cl-list cl-keys)) + (if (cl--parsing-keywords (:key) t + (apply 'cl-member (cl--check-key cl-item) cl-list cl-keys)) cl-list (cons cl-item cl-list))) -;;; See compiler macro in cl-macs.el ;;;###autoload (defun cl-assoc (cl-item cl-alist &rest cl-keys) "Find the first item whose car matches ITEM in LIST. @@ -718,10 +708,10 @@ \n(fn ITEM LIST [KEYWORD VALUE]...)" (declare (compiler-macro cl--compiler-macro-assoc)) (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (cl--parsing-keywords (:test :test-not :key :if :if-not) () (while (and cl-alist (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (car (car cl-alist)))))) + (not (cl--check-test cl-item (car (car cl-alist)))))) (setq cl-alist (cdr cl-alist))) (and cl-alist (car cl-alist))) (if (and (numberp cl-item) (not (integerp cl-item))) @@ -749,10 +739,10 @@ \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" (if (or cl-keys (numberp cl-item)) - (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (cl--parsing-keywords (:test :test-not :key :if :if-not) () (while (and cl-alist (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (cdr (car cl-alist)))))) + (not (cl--check-test cl-item (cdr (car cl-alist)))))) (setq cl-alist (cdr cl-alist))) (and cl-alist (car cl-alist))) (rassq cl-item cl-alist))) @@ -813,13 +803,13 @@ \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (and cl-list1 cl-list2 (if (equal cl-list1 cl-list2) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) + (cl--parsing-keywords (:key) (:test :test-not) (let ((cl-res nil)) (or (>= (length cl-list1) (length cl-list2)) (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) (while cl-list2 (if (if (or cl-keys (numberp (car cl-list2))) - (apply 'cl-member (cl-check-key (car cl-list2)) + (apply 'cl-member (cl--check-key (car cl-list2)) cl-list1 cl-keys) (memq (car cl-list2) cl-list1)) (push (car cl-list2) cl-res)) @@ -845,11 +835,11 @@ \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (if (or (null cl-list1) (null cl-list2)) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) + (cl--parsing-keywords (:key) (:test :test-not) (let ((cl-res nil)) (while cl-list1 (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'cl-member (cl-check-key (car cl-list1)) + (apply 'cl-member (cl--check-key (car cl-list1)) cl-list2 cl-keys) (memq (car cl-list1) cl-list2)) (push (car cl-list1) cl-res)) @@ -901,9 +891,9 @@ \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) t) ((null cl-list2) nil) ((equal cl-list1 cl-list2) t) - (t (cl-parsing-keywords (:key) (:test :test-not) + (t (cl--parsing-keywords (:key) (:test :test-not) (while (and cl-list1 - (apply 'cl-member (cl-check-key (car cl-list1)) + (apply 'cl-member (cl--check-key (car cl-list1)) cl-list2 cl-keys)) (pop cl-list1)) (null cl-list1))))) @@ -949,24 +939,26 @@ \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) +(defvar cl--alist) + ;;;###autoload (defun cl-sublis (cl-alist cl-tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. \nKeywords supported: :test :test-not :key \n(fn ALIST TREE [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (cl-sublis-rec cl-tree))) + (cl--parsing-keywords (:test :test-not :key :if :if-not) () + (let ((cl--alist cl-alist)) + (cl--sublis-rec cl-tree)))) -(defvar cl-alist) -(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* - (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) +(defun cl--sublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*. + (let ((cl-temp (cl--check-key cl-tree)) (cl-p cl--alist)) + (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp))) (setq cl-p (cdr cl-p))) (if cl-p (cdr (car cl-p)) (if (consp cl-tree) - (let ((cl-a (cl-sublis-rec (car cl-tree))) - (cl-d (cl-sublis-rec (cdr cl-tree)))) + (let ((cl-a (cl--sublis-rec (car cl-tree))) + (cl-d (cl--sublis-rec (cdr cl-tree)))) (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) cl-tree (cons cl-a cl-d))) @@ -978,20 +970,21 @@ Any matching element of TREE is changed via a call to `setcar'. \nKeywords supported: :test :test-not :key \n(fn ALIST TREE [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl-hold (list cl-tree))) - (cl-nsublis-rec cl-hold) + (cl--parsing-keywords (:test :test-not :key :if :if-not) () + (let ((cl-hold (list cl-tree)) + (cl--alist cl-alist)) + (cl--nsublis-rec cl-hold) (car cl-hold)))) -(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* +(defun cl--nsublis-rec (cl-tree) ;Uses cl--alist cl-key/test*/if*. (while (consp cl-tree) - (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) + (let ((cl-temp (cl--check-key (car cl-tree))) (cl-p cl--alist)) + (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp))) (setq cl-p (cdr cl-p))) (if cl-p (setcar cl-tree (cdr (car cl-p))) - (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) - (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) + (if (consp (car cl-tree)) (cl--nsublis-rec (car cl-tree)))) + (setq cl-temp (cl--check-key (cdr cl-tree)) cl-p cl--alist) + (while (and cl-p (not (cl--check-test-nokey (car (car cl-p)) cl-temp))) (setq cl-p (cdr cl-p))) (if cl-p (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) @@ -1003,14 +996,14 @@ Atoms are compared by `eql'; cons cells are compared recursively. \nKeywords supported: :test :test-not :key \n(fn TREE1 TREE2 [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key) () - (cl-tree-equal-rec cl-x cl-y))) + (cl--parsing-keywords (:test :test-not :key) () + (cl--tree-equal-rec cl-x cl-y))) -(defun cl-tree-equal-rec (cl-x cl-y) +(defun cl--tree-equal-rec (cl-x cl-y) ;Uses cl-key/test*. (while (and (consp cl-x) (consp cl-y) - (cl-tree-equal-rec (car cl-x) (car cl-y))) + (cl--tree-equal-rec (car cl-x) (car cl-y))) (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) - (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) + (and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y))) (run-hooks 'cl-seq-load-hook) === modified file 'lisp/emacs-lisp/cl.el' --- lisp/emacs-lisp/cl.el 2012-06-08 02:54:35 +0000 +++ lisp/emacs-lisp/cl.el 2012-06-11 15:52:50 +0000 @@ -337,6 +337,7 @@ - closure-conversion of lambda expressions for `lexical-let'. - renaming of F when it's a function defined via `cl-labels' or `labels'." (require 'cl-macs) + (declare-function cl--expr-contains-any "cl-macs" (x y)) (cond ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked ;; *after* handling `function', but we want to stop macroexpansion from @@ -460,7 +461,7 @@ (let ((func `(cl-function (lambda ,(cadr x) (cl-block ,(car x) ,@(cddr x)))))) - (when (cl-compiling-file) + (when (cl--compiling-file) ;; Bug#411. It would be nice to fix this. (and (get (car x) 'byte-compile) (error "Byte-compiling a redefinition of `%s' \ @@ -532,6 +533,11 @@ (define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2") (define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2") +(defun cl-maclisp-member (item list) + (declare (obsolete member "24.2")) + (while (and list (not (equal item (car list)))) (setq list (cdr list))) + list) + ;; FIXME: More candidates: define-modify-macro, define-setf-expander. (provide 'cl) === modified file 'lisp/help-fns.el' --- lisp/help-fns.el 2012-02-26 09:24:13 +0000 +++ lisp/help-fns.el 2012-06-11 15:52:50 +0000 @@ -510,7 +510,7 @@ (unless (looking-back "\n\n") (terpri))))) ;; Note that list* etc do not get this property until - ;; cl-hack-byte-compiler runs, after bytecomp is loaded. + ;; cl--hack-byte-compiler runs, after bytecomp is loaded. (when (and (symbolp function) (eq (get function 'byte-compile) 'cl-byte-compile-compiler-macro)) ------------------------------------------------------------ revno: 108559 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-06-11 11:13:27 -0400 message: Don't purify in Fmake_byte_code. * src/alloc.c (make_byte_code): New function. (Fmake_byte_code): Use it. Don't purify here. * src/lread.c (read1): Use it as well to avoid extra allocation. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-11 14:42:55 +0000 +++ src/ChangeLog 2012-06-11 15:13:27 +0000 @@ -1,3 +1,9 @@ +2012-06-11 Stefan Monnier + + * alloc.c (make_byte_code): New function. + (Fmake_byte_code): Use it. Don't purify here. + * lread.c (read1): Use it as well to avoid extra allocation. + 2012-06-11 Chong Yidong * image.c (imagemagick_load_image): Implement transparency. === modified file 'src/alloc.c' --- src/alloc.c 2012-06-08 09:58:43 +0000 +++ src/alloc.c 2012-06-11 15:13:27 +0000 @@ -3401,6 +3401,19 @@ return val; } +void +make_byte_code (struct Lisp_Vector *v) +{ + if (v->header.size > 1 && STRINGP (v->contents[1]) + && STRING_MULTIBYTE (v->contents[1])) + /* BYTECODE-STRING must have been produced by Emacs 20.2 or the + earlier because they produced a raw 8-bit string for byte-code + and now such a byte-code string is loaded as multibyte while + raw 8-bit characters converted to multibyte form. Thus, now we + must convert them back to the original unibyte form. */ + v->contents[1] = Fstring_as_unibyte (v->contents[1]); + XSETPVECTYPE (v, PVEC_COMPILED); +} DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. @@ -3424,28 +3437,21 @@ ptrdiff_t i; register struct Lisp_Vector *p; + /* We used to purecopy everything here, if purify-flga was set. This worked + OK for Emacs-23, but with Emacs-24's lexical binding code, it can be + dangerous, since make-byte-code is used during execution to build + closures, so any closure built during the preload phase would end up + copied into pure space, including its free variables, which is sometimes + just wasteful and other times plainly wrong (e.g. those free vars may want + to be setcar'd). */ + XSETFASTINT (len, nargs); - if (!NILP (Vpurify_flag)) - val = make_pure_vector (nargs); - else - val = Fmake_vector (len, Qnil); - - if (nargs > 1 && STRINGP (args[1]) && STRING_MULTIBYTE (args[1])) - /* BYTECODE-STRING must have been produced by Emacs 20.2 or the - earlier because they produced a raw 8-bit string for byte-code - and now such a byte-code string is loaded as multibyte while - raw 8-bit characters converted to multibyte form. Thus, now we - must convert them back to the original unibyte form. */ - args[1] = Fstring_as_unibyte (args[1]); + val = Fmake_vector (len, Qnil); p = XVECTOR (val); for (i = 0; i < nargs; i++) - { - if (!NILP (Vpurify_flag)) - args[i] = Fpurecopy (args[i]); - p->contents[i] = args[i]; - } - XSETPVECTYPE (p, PVEC_COMPILED); + p->contents[i] = args[i]; + make_byte_code (p); XSETCOMPILED (val, p); return val; } @@ -3470,7 +3476,7 @@ /* Each symbol_block is just under 1020 bytes long, since malloc really allocates in units of powers of two and uses 4 bytes for its - own overhead. */ + own overhead. */ #define SYMBOL_BLOCK_SIZE \ ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol)) === modified file 'src/lisp.h' --- src/lisp.h 2012-06-08 08:44:30 +0000 +++ src/lisp.h 2012-06-11 15:13:27 +0000 @@ -2880,6 +2880,7 @@ extern Lisp_Object make_pure_c_string (const char *data); extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); EXFUN (Fgarbage_collect, 0); +extern void make_byte_code (struct Lisp_Vector *); EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_bool_vector, 2); extern Lisp_Object Qchar_table_extra_slots; === modified file 'src/lread.c' --- src/lread.c 2012-06-08 13:18:26 +0000 +++ src/lread.c 2012-06-11 15:13:27 +0000 @@ -2551,8 +2551,8 @@ build them using function calls. */ Lisp_Object tmp; tmp = read_vector (readcharfun, 1); - return Fmake_byte_code (ASIZE (tmp), - XVECTOR (tmp)->contents); + make_byte_code (XVECTOR (tmp)); + return tmp; } if (c == '(') { ------------------------------------------------------------ revno: 108558 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-06-11 22:42:55 +0800 message: Support transparency for ImageMagick images. * src/image.c (imagemagick_load_image): Implement transparency. * doc/lispref/display.texi (ImageMagick Images): ImageMagick now supports the :background property. diff: === modified file 'doc/lispref/ChangeLog' --- doc/lispref/ChangeLog 2012-06-10 13:20:58 +0000 +++ doc/lispref/ChangeLog 2012-06-11 14:42:55 +0000 @@ -1,3 +1,8 @@ +2012-06-11 Chong Yidong + + * display.texi (ImageMagick Images): ImageMagick now supports the + :background property. + 2012-06-10 Dmitry Antipov * internals.texi (Garbage Collection): Typo fix. === modified file 'doc/lispref/display.texi' --- doc/lispref/display.texi 2012-06-09 06:26:46 +0000 +++ doc/lispref/display.texi 2012-06-11 14:42:55 +0000 @@ -4603,6 +4603,12 @@ image descriptor properties: @table @code +@item :background @var{background} +@var{background}, if non-@code{nil}, should be a string specifying a +color, which is used as the image's background color if the image +supports transparency. If the value is @code{nil}, it defaults to the +frame's background color. + @item :width, :height The @code{:width} and @code{:height} keywords are used for scaling the image. If only one of them is specified, the other one will be === modified file 'etc/NEWS' --- etc/NEWS 2012-06-11 13:22:53 +0000 +++ etc/NEWS 2012-06-11 14:42:55 +0000 @@ -80,6 +80,9 @@ `imagemagick-filter-types' returns the list of types that will be treated as images. +*** Images displayed via ImageMagick now support transparency and the +:background image spec property. + ** String values for `initial-buffer-choice' also apply to emacsclient frames, if emacsclient is only told to open a new frame without specifying any file to visit or expression to evaluate. === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-10 13:20:58 +0000 +++ src/ChangeLog 2012-06-11 14:42:55 +0000 @@ -1,3 +1,7 @@ +2012-06-11 Chong Yidong + + * image.c (imagemagick_load_image): Implement transparency. + 2012-06-10 Andreas Schwab * regex.c (at_begline_loc_p): Also recognize `(?N:' and correctly === modified file 'src/image.c' --- src/image.c 2012-05-31 07:22:33 +0000 +++ src/image.c 2012-06-11 14:42:55 +0000 @@ -7599,19 +7599,14 @@ unsigned char *contents, unsigned int size, char *filename) { - size_t width; - size_t height; - + size_t width, height; MagickBooleanType status; - XImagePtr ximg; - int x; - int y; - - MagickWand *image_wand; - MagickWand *ping_wand; + int x, y; + MagickWand *image_wand; + MagickWand *ping_wand; PixelIterator *iterator; - PixelWand **pixels; + PixelWand **pixels, *bg_wand = NULL; MagickPixelPacket pixel; Lisp_Object image; Lisp_Object value; @@ -7620,10 +7615,6 @@ int desired_width, desired_height; double rotation; int pixelwidth; - ImageInfo *image_info; - ExceptionInfo *exception; - Image * im_image; - /* Handle image index for image types who can contain more than one image. Interface :index is same as for GIF. First we "ping" the image to see how @@ -7637,14 +7628,9 @@ ping_wand = NewMagickWand (); /* MagickSetResolution (ping_wand, 2, 2); (Bug#10112) */ - if (filename != NULL) - { - status = MagickPingImage (ping_wand, filename); - } - else - { - status = MagickPingImageBlob (ping_wand, contents, size); - } + status = filename + ? MagickPingImage (ping_wand, filename) + : MagickPingImageBlob (ping_wand, contents, size); if (status == MagickFalse) { @@ -7653,7 +7639,7 @@ return 0; } - if (! (0 <= ino && ino < MagickGetNumberImages (ping_wand))) + if (ino < 0 || ino >= MagickGetNumberImages (ping_wand)) { image_error ("Invalid image number `%s' in image `%s'", image, img->spec); @@ -7670,39 +7656,46 @@ DestroyMagickWand (ping_wand); /* Now we know how many images are inside the file. If it's not a - bundle, the number is one. */ - - if (filename != NULL) - { - image_info = CloneImageInfo ((ImageInfo *) NULL); - (void) strcpy (image_info->filename, filename); - image_info->number_scenes = 1; - image_info->scene = ino; - exception = AcquireExceptionInfo (); - - im_image = ReadImage (image_info, exception); - DestroyExceptionInfo (exception); - - if (im_image == NULL) - goto imagemagick_no_wand; - image_wand = NewMagickWandFromImage (im_image); - DestroyImage (im_image); - } - else - { - image_wand = NewMagickWand (); - if (MagickReadImageBlob (image_wand, contents, size) == MagickFalse) - { - imagemagick_error (image_wand); - goto imagemagick_error; - } - } + bundle, the number is one. Load the image data. */ + + image_wand = NewMagickWand (); + + if ((filename + ? MagickReadImage (image_wand, filename) + : MagickReadImageBlob (image_wand, contents, size)) + == MagickFalse) + { + imagemagick_error (image_wand); + goto imagemagick_error; + } + + /* Retrieve the frame's background color, for use later. */ + { + XColor bgcolor; + Lisp_Object specified_bg; + + specified_bg = image_spec_value (img->spec, QCbackground, NULL); + if (!STRINGP (specified_bg) + || !x_defined_color (f, SSDATA (specified_bg), &bgcolor, 0)) + { +#ifndef HAVE_NS + bgcolor.pixel = FRAME_BACKGROUND_PIXEL (f); + x_query_color (f, &bgcolor); +#else + ns_query_color (FRAME_BACKGROUND_COLOR (f), &bgcolor, 1); +#endif + } + + bg_wand = NewPixelWand (); + PixelSetRed (bg_wand, (double) bgcolor.red / 65535); + PixelSetGreen (bg_wand, (double) bgcolor.green / 65535); + PixelSetBlue (bg_wand, (double) bgcolor.blue / 65535); + } /* If width and/or height is set in the display spec assume we want to scale to those values. If either h or w is unspecified, the unspecified should be calculated from the specified to preserve aspect ratio. */ - value = image_spec_value (img->spec, QCwidth, NULL); desired_width = (INTEGERP (value) ? XFASTINT (value) : -1); value = image_spec_value (img->spec, QCheight, NULL); @@ -7768,13 +7761,8 @@ value = image_spec_value (img->spec, QCrotation, NULL); if (FLOATP (value)) { - PixelWand* background = NewPixelWand (); - PixelSetColor (background, "#ffffff");/*TODO remove hardcode*/ - rotation = extract_float (value); - - status = MagickRotateImage (image_wand, background, rotation); - DestroyPixelWand (background); + status = MagickRotateImage (image_wand, bg_wand, rotation); if (status == MagickFalse) { image_error ("Imagemagick image rotate failed", Qnil, Qnil); @@ -7788,6 +7776,18 @@ height = MagickGetImageHeight (image_wand); width = MagickGetImageWidth (image_wand); + /* Set the canvas background color to the frame or specified + background, and flatten the image. Note: as of ImageMagick + 6.6.0, SVG image transparency is not handled properly + (e.g. etc/images/splash.svg shows a white background always). */ + { + MagickWand *new_wand; + MagickSetImageBackgroundColor (image_wand, bg_wand); + new_wand = MagickMergeImageLayers (image_wand, MergeLayer); + DestroyMagickWand (image_wand); + image_wand = new_wand; + } + if (! (width <= INT_MAX && height <= INT_MAX && check_image_size (f, width, height))) { @@ -7895,7 +7895,6 @@ width, height, exportdepth, pixelwidth, - /*&(img->pixmap));*/ ximg->data); #else image_error ("You don't have MagickExportImagePixels, upgrade ImageMagick!", @@ -7910,7 +7909,6 @@ free_color_table (); #endif /* COLOR_TABLE_SUPPORT */ - img->width = width; img->height = height; @@ -7919,9 +7917,10 @@ x_put_x_image (f, ximg, img->pixmap, width, height); x_destroy_x_image (ximg); - /* Final cleanup. image_wand should be the only resource left. */ DestroyMagickWand (image_wand); + if (bg_wand) DestroyPixelWand (bg_wand); + /* `MagickWandTerminus' terminates the imagemagick environment. */ MagickWandTerminus (); @@ -7929,6 +7928,8 @@ imagemagick_error: DestroyMagickWand (image_wand); + if (bg_wand) DestroyPixelWand (bg_wand); + imagemagick_no_wand: MagickWandTerminus (); /* TODO more cleanup. */ ------------------------------------------------------------ revno: 108557 committer: Michael Albinus branch nick: trunk timestamp: Mon 2012-06-11 15:22:53 +0200 message: New Tramp features. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-06-07 14:39:28 +0000 +++ etc/NEWS 2012-06-11 13:22:53 +0000 @@ -250,6 +250,15 @@ ** which-function-mode now applies to all applicable major modes by default. +** Tramp + ++++ +*** The syntax has been extended in order to allow ad-hoc proxy +definitions. See the manual for details. + ++++ +*** Remote processes are now supported also on remote Windows host. + ** D-Bus +++ ------------------------------------------------------------ revno: 108556 committer: Michael Albinus branch nick: trunk timestamp: Mon 2012-06-11 15:03:39 +0200 message: Sync with Tramp 2.2.6-pre. * tramp.texi (all): Use consequently @command{}, @env{} and @kbd{} where appropriate. (Ad-hoc multi-hops): New section. (Remote processes): New subsection "Running remote processes on Windows hosts". (History): Add remote commands on Windows, and ad-hoc multi-hop methods. (External methods): "ControlPersist" must be set to "no" for the `scpc' method. (Remote processes): Add a note about `auto-revert-tail-mode'. (Frequently Asked Questions): Use "scpx" in combination with "ControlPersist". Reported by Adam Spiers . * trampver.texi: Update release number. diff: === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2012-06-10 13:20:58 +0000 +++ doc/misc/ChangeLog 2012-06-11 13:03:39 +0000 @@ -1,3 +1,22 @@ +2012-06-11 Michael Albinus + + Sync with Tramp 2.2.6-pre. + + * tramp.texi (all): Use consequently @command{}, @env{} and @kbd{} + where appropriate. + (Ad-hoc multi-hops): New section. + (Remote processes): New subsection "Running remote processes on + Windows hosts". + (History): Add remote commands on Windows, and ad-hoc multi-hop + methods. + (External methods): "ControlPersist" must be set to "no" for the + `scpc' method. + (Remote processes): Add a note about `auto-revert-tail-mode'. + (Frequently Asked Questions): Use "scpx" in combination with + "ControlPersist". Reported by Adam Spiers . + + * trampver.texi: Update release number. + 2012-06-10 Chong Yidong * sc.texi: Remove bogus @ifinfo commands which prevent makeinfo === modified file 'doc/misc/tramp.texi' --- doc/misc/tramp.texi 2012-01-20 20:12:38 +0000 +++ doc/misc/tramp.texi 2012-06-11 13:03:39 +0000 @@ -197,6 +197,7 @@ * Filename Syntax:: @value{tramp} filename conventions. * Alternative Syntax:: URL-like filename syntax. * Filename completion:: Filename completion. +* Ad-hoc multi-hops:: Declaring multiple hops in the file name. * Remote processes:: Integration with other @value{emacsname} packages. * Cleanup remote connections:: Cleanup remote connections. @@ -442,6 +443,11 @@ @ifset emacsgvfs GVFS integration started in February 2009. @end ifset +@ifset emacs +Remote commands on Windows hosts are available since September 2011. +@end ifset +Ad-hoc multi-hop methods (with a changed syntax) have been reenabled +in November 2011. In December 2001, @value{tramp} has been added to the XEmacs package repository. Being part of the Emacs repository happened in June 2002, @@ -510,7 +516,7 @@ @node Connection types -@section Types of connections made to remote machines. +@section Types of connections made to remote machines @cindex connection types, overview There are two basic types of transfer methods, each with its own @@ -880,7 +886,9 @@ command-line: line 0: Bad configuration option: ControlMaster @end example -then you cannot use it. +then you cannot use it. Note, that the option +@option{ControlPersist}, if it is supported by your @option{ssh} +version, must be set to @option{no}. This method supports the @samp{-p} argument. @@ -976,8 +984,8 @@ @command{smbclient} command on different Unices in order to connect to an SMB server. An SMB server might be a Samba (or CIFS) server on another UNIX host or, more interesting, a host running MS Windows. So -far, it is tested against MS Windows NT, MS Windows 2000, and MS -Windows XP. +far, it is tested against MS Windows NT, MS Windows 2000, MS Windows +XP, MS Windows Vista, and MS Windows 7. The first directory in the localname must be a share name on the remote host. Remember that the @code{$} character, in which default shares @@ -1259,8 +1267,8 @@ One trap to fall in must be known. If @value{tramp} finds a default user, this user will be passed always to the connection command as -parameter (for example @samp{ssh here.somewhere.else -l john}. If you -have specified another user for your command in its configuration +parameter (for example @command{ssh here.somewhere.else -l john}. If +you have specified another user for your command in its configuration files, @value{tramp} cannot know it, and the remote access will fail. If you have specified in the given example in @file{~/.ssh/config} the lines @@ -1398,8 +1406,8 @@ @var{host}, @var{user} and @var{proxy} can also be Lisp forms. These forms are evaluated, and must return a string, or @code{nil}. The previous example could be generalized then: For all hosts except my -local one connect via @code{ssh} first, and apply @code{sudo -u root} -afterwards: +local one connect via @command{ssh} first, and apply @command{sudo -u +root} afterwards: @lisp (add-to-list 'tramp-default-proxies-alist @@ -1571,7 +1579,7 @@ @node Password handling -@section Reusing passwords for several connections. +@section Reusing passwords for several connections @cindex passwords Sometimes it is necessary to connect to the same remote host several @@ -1645,7 +1653,7 @@ @node Connection caching -@section Reusing connection related information. +@section Reusing connection related information @cindex caching @vindex tramp-persistency-file-name @@ -1690,7 +1698,7 @@ @node Remote Programs -@section How @value{tramp} finds and uses programs on the remote machine. +@section How @value{tramp} finds and uses programs on the remote machine @value{tramp} depends on a number of programs on the remote host in order to function, including @command{ls}, @command{test}, @command{find} and @@ -1867,7 +1875,7 @@ @value{tramp} does not know how to answer these questions. There are two approaches for dealing with this problem. One approach is to take care that the shell does not ask any questions when invoked from -@value{tramp}. You can do this by checking the @code{TERM} +@value{tramp}. You can do this by checking the @env{TERM} environment variable, it will be set to @code{dumb} when connecting. @vindex tramp-terminal-type @@ -1898,9 +1906,9 @@ @item Environment variables named like users in @file{.profile} -If you have a user named frumple and set the variable @code{FRUMPLE} in +If you have a user named frumple and set the variable @env{FRUMPLE} in your shell environment, then this might cause trouble. Maybe rename -the variable to @code{FRUMPLE_DIR} or the like. +the variable to @env{FRUMPLE_DIR} or the like. This weird effect was actually reported by a @value{tramp} user! @@ -1925,7 +1933,7 @@ this line. Another example is the tilde (@code{~}) character, say when adding -@file{~/bin} to @code{PATH}. Many Bourne shells will not expand this +@file{~/bin} to @env{PATH}. Many Bourne shells will not expand this character, and since there is usually no directory whose name consists of the single character tilde, strange things will happen. @@ -1960,10 +1968,10 @@ shell}, this doesn't look nice. You can redefine the shell prompt by checking the environment variable -@code{INSIDE_EMACS}, which is set by @value{tramp}, in your startup -script @file{~/.emacs_SHELLNAME}. @code{SHELLNAME} might be the string +@env{INSIDE_EMACS}, which is set by @value{tramp}, in your startup +script @file{~/.emacs_SHELLNAME}. @env{SHELLNAME} might be the string @code{bash} or similar, in case of doubt you could set it the -environment variable @code{ESHELL} in your @file{.emacs}: +environment variable @env{ESHELL} in your @file{.emacs}: @lisp (setenv "ESHELL" "bash") @@ -2177,7 +2185,7 @@ you might encounter problems with @command{ssh-agent}. Using this program, you can avoid typing the pass-phrase every time you log in. However, if you start @value{emacsname} from a desktop shortcut, then -the environment variable @code{SSH_AUTH_SOCK} is not set and so +the environment variable @env{SSH_AUTH_SOCK} is not set and so @value{emacsname} and thus @value{tramp} and thus @command{ssh} and @command{scp} started from @value{tramp} cannot communicate with @command{ssh-agent}. It works better to start @value{emacsname} from @@ -2215,6 +2223,7 @@ * Filename Syntax:: @value{tramp} filename conventions. * Alternative Syntax:: URL-like filename syntax. * Filename completion:: Filename completion. +* Ad-hoc multi-hops:: Declaring multiple hops in the file name. * Remote processes:: Integration with other @value{emacsname} packages. * Cleanup remote connections:: Cleanup remote connections. @end menu @@ -2455,16 +2464,56 @@ @end defopt +@node Ad-hoc multi-hops +@section Declaring multiple hops in the file name +@cindex multi-hop, ad-hoc +@cindex proxy hosts, ad-hoc + +Multiple hops are configured with the variable +@code{tramp-default-proxies-alist} (@pxref{Multi-hops}). However, +sometimes it is desirable to reach a remote host immediately, without +configuration changes. This can be reached by an ad-hoc specification +of the proxies. + +A proxy looks like a remote file name specification without the local +file name part. It is prepended to the target remote file name, +separated by @samp{|}. As an example, a remote file on +@samp{you@@remotehost}, passing the proxy @samp{bird@@bastion}, could +be opened by + +@example +@c @kbd{C-x C-f @trampfn{ssh@value{postfixhop}bird@@bastion|ssh, you, +@c remotehost, /path}} +@kbd{C-x C-f @value{prefix}ssh@value{postfixhop}bird@@bastion|ssh@value{postfixhop}you@@remotehost@value{postfix}/path} +@end example + +Multiple hops can be cascaded, separating all proxies by @samp{|}. +The proxies can also contain the patterns @code{%h} or @code{%u}. + +The ad-hoc definition is added on the fly to +@code{tramp-default-proxies-alist}. Therefore, during the lifetime of +the @value{emacsname} session it is not necessary to enter this ad-hoc +specification, again. The remote file name @samp{@trampfn{ssh, you, +remotehost, /path}} would be sufficient from now on. + +@vindex tramp-save-ad-hoc-proxies +@defopt tramp-save-ad-hoc-proxies +This customer option controls whether ad-hoc definitions are kept +persistently in @code{tramp-default-proxies-alist}. That means, those +definitions are available also for future @value{emacsname} sessions. +@end defopt + + @node Remote processes -@section Integration with other @value{emacsname} packages. +@section Integration with other @value{emacsname} packages @cindex compile @cindex recompile @value{tramp} supports running processes on a remote host. This allows to exploit @value{emacsname} packages without modification for -remote file names. It does not work for the @option{ftp} and -@option{smb} methods. Association of a pty, as specified in -@code{start-file-process}, is not supported. +remote file names. It does not work for the @option{ftp} method. +Association of a pty, as specified in @code{start-file-process}, is +not supported. @code{process-file} and @code{start-file-process} work on the remote host when the variable @code{default-directory} is remote: @@ -2503,9 +2552,9 @@ The environment for your program can be adapted by customizing @code{tramp-remote-process-environment}. This variable is a list of strings. It is structured like @code{process-environment}. Each -element is a string of the form ENVVARNAME=VALUE. An entry -ENVVARNAME= disables the corresponding environment variable, which -might have been set in your init file like @file{~/.profile}. +element is a string of the form @code{"ENVVARNAME=VALUE"}. An entry +@code{"ENVVARNAME="} disables the corresponding environment variable, +which might have been set in your init file like @file{~/.profile}. @noindent Adding an entry can be performed via @code{add-to-list}: @@ -2517,7 +2566,7 @@ Changing or removing an existing entry is not encouraged. The default values are chosen for proper @value{tramp} work. Nevertheless, if for example a paranoid system administrator disallows changing the -@code{HISTORY} environment variable, you can customize +@env{HISTORY} environment variable, you can customize @code{tramp-remote-process-environment}, or you can apply the following code in your @file{.emacs}: @@ -2536,7 +2585,7 @@ If you want to run a remote program, which shall connect the X11 server you are using with your local host, you can set the -@code{DISPLAY} environment variable on the remote host: +@env{DISPLAY} environment variable on the remote host: @lisp (add-to-list 'tramp-remote-process-environment @@ -2557,7 +2606,7 @@ @subsection Running @code{shell} on a remote host @cindex shell -Calling @code{M-x shell} in a buffer related to a remote host runs the +Calling @kbd{M-x shell} in a buffer related to a remote host runs the local shell as defined in @option{shell-file-name}. This might be also a valid path name for a shell to be applied on the remote host, but it will fail at least when your local and remote hosts belong to @@ -2590,13 +2639,18 @@ You will see the buffer @file{*Async Shell Command*}, containing the continuous output of the @command{tail} command. +@ifset emacs +A similar behaviour can be reached by @kbd{M-x auto-revert-tail-mode}, +if available. +@end ifset + @subsection Running @code{eshell} on a remote host @cindex eshell @value{tramp} is integrated into @file{eshell.el}. That is, you can open an interactive shell on your remote host, and run commands there. -After you have started @code{M-x eshell}, you could perform commands +After you have started @kbd{M-x eshell}, you could perform commands like this: @example @@ -2672,8 +2726,40 @@ absolute file names, without any remote specification. +@subsection Running remote processes on Windows hosts +@cindex winexe +@cindex powershell + +With the help of the @command{winexe} it is possible tu run processes +on a remote Windows host. @value{tramp} has implemented this for +@code{process-file} and @code{start-file-process}. + +The variable @code{tramp-smb-winexe-program} must contain the file +name of your local @command{winexe} command. On the remote host, +Powershell V2.0 must be installed; it is used to run the remote +process. + +In order to open a remote shell on the Windows host via @kbd{M-x +shell}, you must set the variables @option{explicit-shell-file-name} +and @option{explicit-*-args}. If you want, for example, run +@command{cmd}, you must set: + +@lisp +(setq explicit-shell-file-name "cmd" + explicit-cmd-args '("/q")) +@end lisp + +@noindent +In case of running @command{powershell} as remote shell, the settings are + +@lisp +(setq explicit-shell-file-name "powershell" + explicit-powershell-args '("-file" "-")) +@end lisp + + @node Cleanup remote connections -@section Cleanup remote connections. +@section Cleanup remote connections @cindex cleanup Sometimes it is useful to cleanup remote connections. The following @@ -2869,7 +2955,7 @@ When the remote machine opens an echoing shell, there might be control characters in the welcome message. @value{tramp} tries to suppress -such echoes via the @code{stty -echo} command, but sometimes this +such echoes via the @command{stty -echo} command, but sometimes this command is not reached, because the echoed output has confused @value{tramp} already. In such situations it might be helpful to use the @option{sshx} or @option{scpx} methods, which allocate a pseudo tty. @@ -2924,6 +3010,20 @@ @item +How can I use @samp{ControlPersist}? + +When @samp{ControlPersist} is set to @samp{yes}, the @option{scpc} +method does not work. You can use @option{scpx} instead with the +following settings in @file{~/.ssh/config}: + +@example +Host * + ControlMaster auto + ControlPersist yes +@end example + + +@item File name completion does not work with @value{tramp} When you log in to the remote machine, do you see the output of @@ -3385,7 +3485,7 @@ emacsclient @trampfn{ssh, $(whoami), $(hostname --fqdn), $1} @end example -Then you must set the environment variable @code{EDITOR} pointing to +Then you must set the environment variable @env{EDITOR} pointing to that script: @example @@ -3477,7 +3577,7 @@ @node Localname deconstruction -@section Breaking a localname into its components. +@section Breaking a localname into its components @value{tramp} file names are somewhat different, obviously, to ordinary file names. As such, the lisp functions @code{file-name-directory} and @@ -3494,7 +3594,7 @@ @ifset emacs @node External packages -@section Integration with external Lisp packages. +@section Integration with external Lisp packages @subsection Filename completion. While reading filenames in the minibuffer, @value{tramp} must decide === modified file 'doc/misc/trampver.texi' --- doc/misc/trampver.texi 2012-01-19 07:21:25 +0000 +++ doc/misc/trampver.texi 2012-06-11 13:03:39 +0000 @@ -8,7 +8,7 @@ @c In the Tramp CVS, the version number is auto-frobbed from @c configure.ac, so you should edit that file and run @c "autoconf && ./configure" to change the version number. -@set trampver 2.2.3-24.1 +@set trampver 2.2.6-pre @c Other flags from configuration @set instprefix /usr/local ------------------------------------------------------------ revno: 108555 committer: Michael Albinus branch nick: trunk timestamp: Mon 2012-06-11 12:30:07 +0200 message: Sync with Tramp 2.2.6-pre. * net/tramp-cache.el (tramp-dump-connection-properties): Let-bind `print-length' and `print-level' to nil, in order to avoid truncation. Reported by Christopher Schmidt . * net/tramp-cmds.el (tramp-cleanup-connection): Delete also process. * net/tramp-compat.el (tramp-compat-condition-case-unless-debug): New defmacro. (tramp-compat-copy-directory): Add optional argument COPY-CONTENTS. It is not handled yet. * net/tramp-ftp.el (tramp-disable-ange-ftp): Fix docstring. (tramp-ftp-file-name-p): Simplify. * net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name): * net/tramp-gw.el (tramp-gw-open-connection): Add hop to connection vector. * net/tramp-sh.el (tramp-copy-size-limit): Fix docstring. (tramp-methods): Do not use `tramp-password-end-of-line'. (tramp-completion-function-alist-putty): Handle UNIX case. (tramp-remote-path): Add "/opt/bin", "/opt/sbin" and "/opt/local/bin". (tramp-do-file-attributes-with-stat) (tramp-do-directory-files-and-attributes-with-stat) Return uid and gid as real numbers. They could run out of integer range on cygwin. (tramp-do-copy-or-rename-file-out-of-band): Better trace format. (tramp-sh-handle-expand-file-name): Handle hops. (tramp-open-connection-setup-interactive-shell): Use `tramp-cleanup'. Move check for busyboxes ... (tramp-find-shell): ... here. Simplify implementation. Set "remote-shell" property also for alternative shells. (tramp-remote-coding-commands): Check "test -c /dev/stdout". If failing, a regular file would be written otherwise. Reported by Dmitry Kurochkin . (tramp-find-inline-encoding): Cache the coding commands in the process cache. Apply test command on the remote side, if defined. (tramp-find-inline-compress): Cache the compress commands in the process cache. (tramp-compute-multi-hops): Save `tramp-default-proxies-alist' when requested. Handle hops. (tramp-current-connection): New defvar. (tramp-maybe-open-connection): Use `tramp-cleanup'. Throw `suppress', if there was a failed connection shortly before. Handle user interrupt. (Bug#10187) (tramp-get-inline-compress, tramp-get-inline-coding): Read connection properties from the process cache. * net/tramp-smb.el (tramp-smb-server-version) (tramp-smb-wrong-passwd-regexp, tramp-smb-actions-with-tar): New defconsts. (tramp-smb-prompt): Extend for powershell prompt. (tramp-smb-file-name-handler-alist): Add handlers for `process-file', `shell-command' and `start-file-process'. (tramp-smb-winexe-program, tramp-smb-winexe-shell-command) (tramp-smb-winexe-shell-command-switch): New defcustoms. (tramp-smb-file-name-p): Simplify. (tramp-smb-action-with-tar, tramp-smb-handle-process-file) (tramp-smb-kill-winexe-function, tramp-smb-call-winexe) (tramp-smb-shell-quote-argument): New defuns. (tramp-smb-handle-copy-directory): Add COPY-CONTENTS argument. Implement using "tar". By this, time-stamps are preserved. (tramp-smb-handle-copy-file): Handle also the case of directories. (tramp-smb-do-file-attributes-with-stat) (tramp-smb-get-file-entries, tramp-smb-get-cifs-capabilities): Use `tramp-get-connection-buffer'). (tramp-smb-handle-rename-file): Use "rename", when source and target are on the same share. (tramp-smb-maybe-open-connection): Handle wrong passwords. Use `tramp-smb-server-version'. (tramp-smb-wait-for-output): Remove prompt. * net/tramp.el (top): Require 'cl. (tramp-methods, tramp-rsh-end-of-line): Remove `tramp-password-end-of-line' from docstring. (tramp-save-ad-hoc-proxies): New defcustom. (tramp-completion-function-alist): Adapt docstring. (tramp-default-password-end-of-line): Remove defcustom. (tramp-shell-prompt-pattern): Allow "[]" style prompts. (Bug#11065) (tramp-user-regexp, tramp-file-name-regexp-unified) (tramp-file-name-regexp-url): Extend regexp by hop separator. (tramp-postfix-hop-format, tramp-postfix-hop-regexp) (tramp-remote-file-name-spec-regexp): New defconst. (tramp-file-name-structure): Extend structure for hops. (tramp-get-method-parameter): Move up. (tramp-file-name-p, tramp-dissect-file-name) (with-parsed-tramp-file-name): Handle hops. (tramp-file-name-hop): New defun. (tramp-make-tramp-file-name): New optional arg HOP. (tramp-message-show-progress-reporter-message): New defvar. (tramp-with-progress-reporter): Use it. We cannot use `tramp-message-show-message' here, because this suppresses also error buffers. (tramp-error-with-buffer): Suppress buffer view, if `tramp-message-show-message' is nil. Use `tramp-get-connection-buffer'. (tramp-cleanup): New defun. (tramp-rfn-eshadow-update-overlay): Let-bind `non-essential' to `t'. (tramp-file-name-handler): If `debug-on-error' is set, propagate an error unchanged. (tramp-completion-handle-file-name-all-completions): Handle hops. Fix an error when called from ido. (tramp-completion-dissect-file-name): Use better local variable name. Add hop to the vector. (tramp-handle-insert-file-contents): Use progress-reporter for the whole scenario. (tramp-action-password): Let-bind `enable-recursive-minibuffers' to `t'. (tramp-check-for-regexp): Simplify search. (tramp-enter-password): Remove it. Move implementation ... (tramp-action-password): ... here. (tramp-mode-string-to-int, tramp-local-host-p) (tramp-make-tramp-temp-file, tramp-read-passwd) (tramp-clear-passwd, tramp-time-less-p, tramp-time-diff): Set tramp-autoload cookie. * net/trampver.el: Update release number. * net/tramp.el (tramp-set-completion-function): Fix docstring. (tramp-parse-group, tramp-parse-file) (tramp-parse-shostkeys-sknownhosts): New defuns. (tramp-parse-rhosts, tramp-parse-rhosts-group, tramp-parse-shosts) (tramp-parse-shosts-group, tramp-parse-sconfig) (tramp-parse-sconfig-group, tramp-parse-shostkeys) (tramp-parse-sknownhosts, tramp-parse-hosts) (tramp-parse-hosts-group, tramp-parse-passwd, tramp-parse-netrc): Use them. (tramp-parse-passwd-group, tramp-parse-netrc-group) (tramp-parse-putty-group): Don't narrow. (tramp-parse-putty): Make a loop. (tramp-file-name-handler): Catch the `suppress' signal. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 10:16:47 +0000 +++ lisp/ChangeLog 2012-06-11 10:30:07 +0000 @@ -1,3 +1,142 @@ +2012-06-11 Michael Albinus + + Sync with Tramp 2.2.6-pre. + + * net/tramp-cache.el (tramp-dump-connection-properties): Let-bind + `print-length' and `print-level' to nil, in order to avoid + truncation. Reported by Christopher Schmidt + . + + * net/tramp-cmds.el (tramp-cleanup-connection): Delete also process. + + * net/tramp-compat.el (tramp-compat-condition-case-unless-debug): + New defmacro. + (tramp-compat-copy-directory): Add optional argument + COPY-CONTENTS. It is not handled yet. + + * net/tramp-ftp.el (tramp-disable-ange-ftp): Fix docstring. + (tramp-ftp-file-name-p): Simplify. + + * net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name): + * net/tramp-gw.el (tramp-gw-open-connection): Add hop to + connection vector. + + * net/tramp-sh.el (tramp-copy-size-limit): Fix docstring. + (tramp-methods): Do not use `tramp-password-end-of-line'. + (tramp-completion-function-alist-putty): Handle UNIX case. + (tramp-remote-path): Add "/opt/bin", "/opt/sbin" and "/opt/local/bin". + (tramp-do-file-attributes-with-stat) + (tramp-do-directory-files-and-attributes-with-stat) Return uid and + gid as real numbers. They could run out of integer range on cygwin. + (tramp-do-copy-or-rename-file-out-of-band): Better trace format. + (tramp-sh-handle-expand-file-name): Handle hops. + (tramp-open-connection-setup-interactive-shell): Use + `tramp-cleanup'. Move check for busyboxes ... + (tramp-find-shell): ... here. Simplify implementation. Set + "remote-shell" property also for alternative shells. + (tramp-remote-coding-commands): Check "test -c /dev/stdout". If + failing, a regular file would be written otherwise. Reported by + Dmitry Kurochkin . + (tramp-find-inline-encoding): Cache the coding commands in the + process cache. Apply test command on the remote side, if defined. + (tramp-find-inline-compress): Cache the compress commands in the + process cache. + (tramp-compute-multi-hops): Save `tramp-default-proxies-alist' + when requested. Handle hops. + (tramp-current-connection): New defvar. + (tramp-maybe-open-connection): Use `tramp-cleanup'. Throw + `suppress', if there was a failed connection shortly before. + Handle user interrupt. (Bug#10187) + (tramp-get-inline-compress, tramp-get-inline-coding): Read + connection properties from the process cache. + + * net/tramp-smb.el (tramp-smb-server-version) + (tramp-smb-wrong-passwd-regexp, tramp-smb-actions-with-tar): New + defconsts. + (tramp-smb-prompt): Extend for powershell prompt. + (tramp-smb-file-name-handler-alist): Add handlers for + `process-file', `shell-command' and `start-file-process'. + (tramp-smb-winexe-program, tramp-smb-winexe-shell-command) + (tramp-smb-winexe-shell-command-switch): New defcustoms. + (tramp-smb-file-name-p): Simplify. + (tramp-smb-action-with-tar, tramp-smb-handle-process-file) + (tramp-smb-kill-winexe-function, tramp-smb-call-winexe) + (tramp-smb-shell-quote-argument): New defuns. + (tramp-smb-handle-copy-directory): Add COPY-CONTENTS argument. + Implement using "tar". By this, time-stamps are preserved. + (tramp-smb-handle-copy-file): Handle also the case of directories. + (tramp-smb-do-file-attributes-with-stat) + (tramp-smb-get-file-entries, tramp-smb-get-cifs-capabilities): Use + `tramp-get-connection-buffer'). + (tramp-smb-handle-rename-file): Use "rename", when source and + target are on the same share. + (tramp-smb-maybe-open-connection): Handle wrong passwords. Use + `tramp-smb-server-version'. + (tramp-smb-wait-for-output): Remove prompt. + + * net/tramp.el (top): Require 'cl. + (tramp-methods, tramp-rsh-end-of-line): Remove + `tramp-password-end-of-line' from docstring. + (tramp-save-ad-hoc-proxies): New defcustom. + (tramp-completion-function-alist): Adapt docstring. + (tramp-default-password-end-of-line): Remove defcustom. + (tramp-shell-prompt-pattern): Allow "[]" style prompts. (Bug#11065) + (tramp-user-regexp, tramp-file-name-regexp-unified) + (tramp-file-name-regexp-url): Extend regexp by hop separator. + (tramp-postfix-hop-format, tramp-postfix-hop-regexp) + (tramp-remote-file-name-spec-regexp): New defconst. + (tramp-file-name-structure): Extend structure for hops. + (tramp-get-method-parameter): Move up. + (tramp-file-name-p, tramp-dissect-file-name) + (with-parsed-tramp-file-name): Handle hops. + (tramp-file-name-hop): New defun. + (tramp-make-tramp-file-name): New optional arg HOP. + (tramp-message-show-progress-reporter-message): New defvar. + (tramp-with-progress-reporter): Use it. We cannot use + `tramp-message-show-message' here, because this suppresses also + error buffers. + (tramp-error-with-buffer): Suppress buffer view, if + `tramp-message-show-message' is nil. Use + `tramp-get-connection-buffer'. + (tramp-cleanup): New defun. + (tramp-rfn-eshadow-update-overlay): Let-bind `non-essential' to `t'. + (tramp-file-name-handler): If `debug-on-error' is set, propagate + an error unchanged. + (tramp-completion-handle-file-name-all-completions): Handle hops. + Fix an error when called from ido. + (tramp-completion-dissect-file-name): Use better local variable + name. Add hop to the vector. + (tramp-handle-insert-file-contents): Use progress-reporter for the + whole scenario. + (tramp-action-password): Let-bind `enable-recursive-minibuffers' + to `t'. + (tramp-check-for-regexp): Simplify search. + (tramp-enter-password): Remove it. Move implementation ... + (tramp-action-password): ... here. + (tramp-mode-string-to-int, tramp-local-host-p) + (tramp-make-tramp-temp-file, tramp-read-passwd) + (tramp-clear-passwd, tramp-time-less-p, tramp-time-diff): Set + tramp-autoload cookie. + + * net/trampver.el: Update release number. + +2012-06-11 Thierry Volpiatto + Michael Albinus + + * net/tramp.el (tramp-set-completion-function): Fix docstring. + (tramp-parse-group, tramp-parse-file) + (tramp-parse-shostkeys-sknownhosts): New defuns. + (tramp-parse-rhosts, tramp-parse-rhosts-group, tramp-parse-shosts) + (tramp-parse-shosts-group, tramp-parse-sconfig) + (tramp-parse-sconfig-group, tramp-parse-shostkeys) + (tramp-parse-sknownhosts, tramp-parse-hosts) + (tramp-parse-hosts-group, tramp-parse-passwd, tramp-parse-netrc): + Use them. + (tramp-parse-passwd-group, tramp-parse-netrc-group) + (tramp-parse-putty-group): Don't narrow. + (tramp-parse-putty): Make a loop. + (tramp-file-name-handler): Catch the `suppress' signal. + 2012-06-11 Chong Yidong * image.el (imagemagick-register-types): Put the ImageMagick entry @@ -4884,9 +5023,6 @@ * net/tramp.el (tramp-action-login): Set connection property "login-as". - * net/tramp-cache.el (tramp-dump-connection-properties): Do not dump - properties, when "login-as" is set. - * net/tramp-sh.el (tramp-methods): Add user spec to "pscp" and "psftp". (tramp-default-user-alist): Don't add "pscp". (tramp-do-copy-or-rename-file-out-of-band): Use connection @@ -6211,9 +6347,6 @@ 2011-11-16 Michael Albinus - * net/tramp-cache.el (tramp-flush-file-property): Flush also - properties of linked files. (Bug#9879) - * net/tramp-sh.el (tramp-sh-handle-file-truename): Cache only the local file name. === modified file 'lisp/net/tramp-cache.el' --- lisp/net/tramp-cache.el 2012-01-22 12:55:36 +0000 +++ lisp/net/tramp-cache.el 2012-06-11 10:30:07 +0000 @@ -328,7 +328,8 @@ (not (zerop (hash-table-count tramp-cache-data))) tramp-cache-data-changed (stringp tramp-persistency-file-name)) - (let ((cache (copy-hash-table tramp-cache-data))) + (let ((cache (copy-hash-table tramp-cache-data)) + print-length print-level) ;; Remove temporary data. If there is the key "login-as", we ;; don't save either, because all other properties might ;; depend on the login name, and we want to give the === modified file 'lisp/net/tramp-cmds.el' --- lisp/net/tramp-cmds.el 2012-01-19 07:21:25 +0000 +++ lisp/net/tramp-cmds.el 2012-06-11 10:30:07 +0000 @@ -89,7 +89,9 @@ (tramp-flush-directory-property vec "") ;; Flush connection cache. - (tramp-flush-connection-property (tramp-get-connection-process vec)) + (when (processp (tramp-get-connection-process vec)) + (delete-process (tramp-get-connection-process vec)) + (tramp-flush-connection-property (tramp-get-connection-process vec))) (tramp-flush-connection-property vec) ;; Remove buffers. === modified file 'lisp/net/tramp-compat.el' --- lisp/net/tramp-compat.el 2012-06-08 13:27:06 +0000 +++ lisp/net/tramp-compat.el 2012-06-11 10:30:07 +0000 @@ -194,6 +194,22 @@ "Display MESSAGE temporarily if non-nil while BODY is evaluated." `(progn ,@body))) +;; `condition-case-unless-debug' is introduced with Emacs 24. +(if (fboundp 'condition-case-unless-debug) + (defalias 'tramp-compat-condition-case-unless-debug + 'condition-case-unless-debug) + (defmacro tramp-compat-condition-case-unless-debug + (var bodyform &rest handlers) + "Like `condition-case' except that it does not catch anything when debugging." + (declare (debug condition-case) (indent 2)) + (let ((bodysym (make-symbol "body"))) + `(let ((,bodysym (lambda () ,bodyform))) + (if debug-on-error + (funcall ,bodysym) + (condition-case ,var + (funcall ,bodysym) + ,@handlers)))))) + ;; `font-lock-add-keywords' does not exist in XEmacs. (defun tramp-compat-font-lock-add-keywords (mode keywords &optional how) "Add highlighting KEYWORDS for MODE." @@ -312,43 +328,49 @@ ;; `copy-directory' is a new function in Emacs 23.2. Implementation ;; is taken from there. (defun tramp-compat-copy-directory - (directory newname &optional keep-time parents) + (directory newname &optional keep-time parents copy-contents) "Make a copy of DIRECTORY (compat function)." - (if (fboundp 'copy-directory) - (tramp-compat-funcall 'copy-directory directory newname keep-time parents) - - ;; If `default-directory' is a remote directory, make sure we find - ;; its `copy-directory' handler. - (let ((handler (or (find-file-name-handler directory 'copy-directory) - (find-file-name-handler newname 'copy-directory)))) - (if handler - (funcall handler 'copy-directory directory newname keep-time parents) - - ;; Compute target name. - (setq directory (directory-file-name (expand-file-name directory)) - newname (directory-file-name (expand-file-name newname))) - (if (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory directory) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory directory) newname))) - (if (not (file-directory-p newname)) (make-directory newname parents)) - - ;; Copy recursively. - (mapc - (lambda (file) - (if (file-directory-p file) - (tramp-compat-copy-directory file newname keep-time parents) - (copy-file file newname t keep-time))) - ;; We do not want to delete "." and "..". - (directory-files - directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) - - ;; Set directory attributes. - (set-file-modes newname (file-modes directory)) - (if keep-time - (set-file-times newname (nth 5 (file-attributes directory)))))))) + (condition-case nil + (tramp-compat-funcall + 'copy-directory directory newname keep-time parents copy-contents) + + ;; `copy-directory' is either not implemented, or it does not + ;; support the the COPY-CONTENTS flag. For the time being, we + ;; ignore COPY-CONTENTS as well. + + (error + ;; If `default-directory' is a remote directory, make sure we + ;; find its `copy-directory' handler. + (let ((handler (or (find-file-name-handler directory 'copy-directory) + (find-file-name-handler newname 'copy-directory)))) + (if handler + (funcall handler 'copy-directory directory newname keep-time parents) + + ;; Compute target name. + (setq directory (directory-file-name (expand-file-name directory)) + newname (directory-file-name (expand-file-name newname))) + (if (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory directory) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory directory) newname))) + (if (not (file-directory-p newname)) (make-directory newname parents)) + + ;; Copy recursively. + (mapc + (lambda (file) + (if (file-directory-p file) + (tramp-compat-copy-directory file newname keep-time parents) + (copy-file file newname t keep-time))) + ;; We do not want to delete "." and "..". + (directory-files + directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) + + ;; Set directory attributes. + (set-file-modes newname (file-modes directory)) + (if keep-time + (set-file-times newname (nth 5 (file-attributes directory))))))))) ;; TRASH has been introduced with Emacs 24.1. (defun tramp-compat-delete-file (filename &optional trash) === modified file 'lisp/net/tramp-ftp.el' --- lisp/net/tramp-ftp.el 2012-04-09 13:05:48 +0000 +++ lisp/net/tramp-ftp.el 2012-06-11 10:30:07 +0000 @@ -49,9 +49,8 @@ (defun tramp-disable-ange-ftp () "Turn Ange-FTP off. This is useful for unified remoting. See -`tramp-file-name-structure-unified' and -`tramp-file-name-structure-separate' for details. Requests suitable -for Ange-FTP will be forwarded to Ange-FTP. Also see the variables +`tramp-file-name-structure' for details. Requests suitable for +Ange-FTP will be forwarded to Ange-FTP. Also see the variables `tramp-ftp-method', `tramp-default-method', and `tramp-default-method-alist'. @@ -204,8 +203,8 @@ ;;;###tramp-autoload (defsubst tramp-ftp-file-name-p (filename) "Check if it's a filename that should be forwarded to Ange-FTP." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-ftp-method))) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-ftp-method)) ;;;###tramp-autoload (unless (featurep 'xemacs) === modified file 'lisp/net/tramp-gvfs.el' --- lisp/net/tramp-gvfs.el 2012-04-09 13:05:48 +0000 +++ lisp/net/tramp-gvfs.el 2012-06-11 10:30:07 +0000 @@ -625,7 +625,7 @@ ;; If there is a default location, expand tilde. (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname) (save-match-data - (tramp-gvfs-maybe-open-connection (vector method user host "/"))) + (tramp-gvfs-maybe-open-connection (vector method user host "/" hop))) (setq localname (replace-match (tramp-get-file-property v "/" "default-location" "~") === modified file 'lisp/net/tramp-gw.el' --- lisp/net/tramp-gw.el 2012-04-09 13:05:48 +0000 +++ lisp/net/tramp-gw.el 2012-06-11 10:30:07 +0000 @@ -154,7 +154,7 @@ (memq (process-status tramp-gw-aux-proc) '(listen))) (let ((aux-vec (vector "aux" (tramp-file-name-user gw-vec) - (tramp-file-name-host gw-vec) nil))) + (tramp-file-name-host gw-vec) nil nil))) (setq tramp-gw-aux-proc (make-network-process :name (tramp-buffer-name aux-vec) :buffer nil :host 'local === modified file 'lisp/net/tramp-sh.el' --- lisp/net/tramp-sh.el 2012-06-06 13:32:36 +0000 +++ lisp/net/tramp-sh.el 2012-06-11 10:30:07 +0000 @@ -51,8 +51,9 @@ :type '(choice (const nil) integer)) (defcustom tramp-copy-size-limit 10240 - "The maximum file size where inline copying is preferred over an out-of-the-band copy. -If it is nil, inline out-of-the-band copy will be used without a check." + "The maximum file size where inline copying is preferred over an \ +out-of-the-band copy. +If it is nil, out-of-the-band copy will be used without a check." :group 'tramp :type '(choice (const nil) integer)) @@ -347,7 +348,6 @@ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) (tramp-remote-shell "/bin/sh") (tramp-remote-shell-args ("-c")) - (tramp-password-end-of-line "xy") ;see docstring for "xy" (tramp-default-port 22))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -356,7 +356,6 @@ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-1" "-ssh") ("%h"))) (tramp-remote-shell "/bin/sh") (tramp-remote-shell-args ("-c")) - (tramp-password-end-of-line "xy") ;see docstring for "xy" (tramp-default-port 22))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -384,7 +383,6 @@ ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) - (tramp-password-end-of-line "xy") ;see docstring for "xy" (tramp-default-port 22))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -397,8 +395,7 @@ (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line "xy"))) ;see docstring for "xy" + (tramp-copy-recursive t))) ;;;###tramp-autoload (add-to-list 'tramp-methods '("fcp" @@ -462,9 +459,11 @@ ;;;###tramp-autoload (defconst tramp-completion-function-alist-putty - '((tramp-parse-putty - "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions")) - "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.") + `((tramp-parse-putty + ,(if (memq system-type '(windows-nt)) + "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions" + "~/.putty/sessions"))) + "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") ;;;###tramp-autoload (eval-after-load 'tramp @@ -513,9 +512,10 @@ ;; IRIX64: /usr/bin ;;;###tramp-autoload (defcustom tramp-remote-path - '(tramp-default-remote-path "/bin" "/usr/bin" "/usr/sbin" "/usr/local/bin" - "/local/bin" "/local/freeware/bin" "/local/gnu/bin" - "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin") + '(tramp-default-remote-path "/bin" "/usr/bin" "/usr/sbin" + "/usr/local/bin" "/local/bin" "/local/freeware/bin" "/local/gnu/bin" + "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin" + "/opt/bin" "/opt/sbin" "/opt/local/bin") "List of directories to search for executables on remote host. For every remote host, this variable will be set buffer local, keeping the list of existing directories on that host. @@ -545,7 +545,6 @@ ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=\"\"" "autocorrect=" "correct=") - "List of environment variables to be set on the remote host. Each element should be a string of the form ENVVARNAME=VALUE. An @@ -1180,9 +1179,6 @@ (tramp-get-file-exists-command v) (tramp-shell-quote-argument localname))))))) -;; CCC: This should check for an error condition and signal failure -;; when something goes wrong. -;; Daniel Pittman (defun tramp-sh-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) @@ -1318,8 +1314,8 @@ (tramp-get-test-command vec) (tramp-shell-quote-argument localname) (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%u" "\"%U\"") - (if (eq id-format 'integer) "%g" "\"%G\"") + (if (eq id-format 'integer) "%ue0" "\"%U\"") + (if (eq id-format 'integer) "%ge0" "\"%G\"") (tramp-shell-quote-argument localname)))) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) @@ -1702,8 +1698,8 @@ (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%u" "\"%U\"") - (if (eq id-format 'integer) "%g" "\"%G\"")))) + (if (eq id-format 'integer) "%ue0" "\"%U\"") + (if (eq id-format 'integer) "%ge0" "\"%G\"")))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -2394,7 +2390,7 @@ p v nil tramp-actions-copy-out-of-band))) ;; Reset the transfer process properties. - (tramp-message orig-vec 6 "%s" (buffer-string)) + (tramp-message orig-vec 6 "\n%s" (buffer-string)) (tramp-set-connection-property v "process-name" nil) (tramp-set-connection-property v "process-buffer" nil))) @@ -2457,11 +2453,11 @@ "Recursively delete the directory given. This is like `dired-recursive-delete-directory' for Tramp files." (with-parsed-tramp-file-name filename nil - ;; Run a shell command 'rm -r ' + ;; Run a shell command 'rm -r '. ;; Code shamelessly stolen from the dired implementation and, um, hacked :) (unless (file-exists-p filename) (tramp-error v 'file-error "No such directory: %s" filename)) - ;; Which is better, -r or -R? (-r works for me ) + ;; Which is better, -r or -R? (-r works for me ). (tramp-send-command v (format "rm -rf %s" (tramp-shell-quote-argument localname)) @@ -2699,7 +2695,8 @@ method user host (tramp-drop-volume-letter (tramp-run-real-handler - 'expand-file-name (list localname)))))))) + 'expand-file-name (list localname))) + hop))))) ;;; Remote commands: @@ -3609,37 +3606,48 @@ (defun tramp-find-shell (vec) "Opens a shell on the remote host which groks tilde expansion." - (unless (tramp-get-connection-property vec "remote-shell" nil) - (let (shell) + (with-connection-property vec "remote-shell" + (let ((shell (tramp-get-method-parameter + (tramp-file-name-method vec) 'tramp-remote-shell))) (with-current-buffer (tramp-get-buffer vec) + ;; CCC: "root" does not exist always, see QNAP 459. Which + ;; check could we apply instead? (tramp-send-command vec "echo ~root" t) - (cond - ((or (string-match "^~root$" (buffer-string)) - ;; The default shell (ksh93) of OpenSolaris and Solaris - ;; is buggy. We've got reports for "SunOS 5.10" and - ;; "SunOS 5.11" so far. - (string-match (regexp-opt '("SunOS 5.10" "SunOS 5.11")) - (tramp-get-connection-property vec "uname" ""))) - (setq shell - (or (tramp-find-executable - vec "bash" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "ksh" (tramp-get-remote-path vec) t t))) - (unless shell - (tramp-error - vec 'file-error - "Couldn't find a shell which groks tilde expansion")) - (tramp-message - vec 5 "Starting remote shell `%s' for tilde expansion" - (tramp-set-connection-property vec "remote-shell" shell)) - (tramp-open-shell vec shell)) - - (t (tramp-message - vec 5 "Remote `%s' groks tilde expansion, good" - (tramp-set-connection-property - vec "remote-shell" - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-shell))))))))) + (when (or (string-match "^~root$" (buffer-string)) + ;; The default shell (ksh93) of OpenSolaris and + ;; Solaris is buggy. We've got reports for "SunOS + ;; 5.10" and "SunOS 5.11" so far. + (string-match (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + (tramp-get-connection-property vec "uname" ""))) + (if (setq shell + (or (tramp-find-executable + vec "bash" (tramp-get-remote-path vec) t t) + (tramp-find-executable + vec "ksh" (tramp-get-remote-path vec) t t))) + (progn + (tramp-message + vec 5 "Starting remote shell `%s' for tilde expansion" shell) + (tramp-open-shell vec shell)) + + ;; Maybe it works at least for some other commands. + (setq shell + (tramp-get-method-parameter + (tramp-file-name-method vec) 'tramp-remote-shell)) + (tramp-message + vec 2 + (concat + "Couldn't find a remote shell which groks tilde expansion, " + "using `%s'") + shell))) + + ;; Busyboxes tend to behave strange. We check for the existence. + (with-connection-property vec "busybox" + (tramp-send-command vec (format "%s --version" shell) t) + (let ((case-fold-search t)) + (and (string-match "busybox" (buffer-string)) t))) + + ;; Return the shell. + shell)))) ;; Utility functions. @@ -3747,21 +3755,12 @@ vec "uname" (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) - (with-current-buffer (tramp-get-debug-buffer vec) - ;; Keep the debug buffer. - (rename-buffer - (generate-new-buffer-name tramp-temp-buffer-name) 'unique) - (tramp-cleanup-connection vec) - (if (= (point-min) (point-max)) - (kill-buffer nil) - (rename-buffer (tramp-debug-buffer-name vec) 'unique)) - ;; We call `tramp-get-buffer' in order to keep the debug buffer. - (tramp-get-buffer vec) - (tramp-message - vec 3 - "Connection reset, because remote host changed from `%s' to `%s'" - old-uname new-uname) - (throw 'uname-changed (tramp-maybe-open-connection vec))))) + (tramp-cleanup vec) + (tramp-message + vec 3 + "Connection reset, because remote host changed from `%s' to `%s'" + old-uname new-uname) + (throw 'uname-changed (tramp-maybe-open-connection vec)))) ;; Check whether the remote host suffers from buggy ;; `send-process-string'. This is known for FreeBSD (see comment in @@ -3798,17 +3797,6 @@ ;; Disable unexpected output. (tramp-send-command vec "mesg n; biff n" t) - ;; Busyboxes tend to behave strange. We check for the existence. - (with-connection-property vec "busybox" - (tramp-send-command - vec - (format - "%s --version" (tramp-get-connection-property vec "remote-shell" "echo")) - t) - (with-current-buffer (process-buffer proc) - (let ((case-fold-search t)) - (and (string-match "busybox" (buffer-string)) t)))) - ;; IRIX64 bash expands "!" even when in single quotes. This ;; destroys our shell functions, we must disable it. See ;; . @@ -3902,7 +3890,7 @@ (b64 "recode data..base64" "recode base64..data") (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) (b64 tramp-perl-encode tramp-perl-decode) - (uu "uuencode xxx" "uudecode -o /dev/stdout") + (uu "uuencode xxx" "uudecode -o /dev/stdout" "test -c /dev/stdout") (uu "uuencode xxx" "uudecode -o -") (uu "uuencode xxx" "uudecode -p") (uu "uuencode xxx" tramp-uudecode) @@ -3912,7 +3900,7 @@ "List of remote coding commands for inline transfer. Each item is a list that looks like this: -\(FORMAT ENCODING DECODING\) +\(FORMAT ENCODING DECODING [TEST]\) FORMAT is symbol describing the encoding/decoding format. It can be `b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. @@ -3926,7 +3914,10 @@ If they are variables, this variable is a string containing a Perl implementation for this functionality. This Perl program will be transferred -to the remote host, and it is available as shell function with the same name.") +to the remote host, and it is available as shell function with the same name. + +The optional TEST command can be used for further tests, whether +ENCODING and DECODING are applicable.") (defun tramp-find-inline-encoding (vec) "Find an inline transfer encoding that works. @@ -3935,7 +3926,8 @@ (save-excursion (let ((local-commands tramp-local-coding-commands) (magic "xyzzy") - loc-enc loc-dec rem-enc rem-dec litem ritem found) + (p (tramp-get-connection-process vec)) + loc-enc loc-dec rem-enc rem-dec rem-test litem ritem found) (while (and local-commands (not found)) (setq litem (pop local-commands)) (catch 'wont-work-local @@ -3968,6 +3960,13 @@ (when (equal format (nth 0 ritem)) (setq rem-enc (nth 1 ritem)) (setq rem-dec (nth 2 ritem)) + (setq rem-test (nth 3 ritem)) + ;; Check the remote test command if exists. + (when (stringp rem-test) + (tramp-message + vec 5 "Checking remote test command `%s'" rem-test) + (unless (tramp-send-command-and-check vec rem-test t) + (throw 'wont-work-remote nil))) ;; Check if remote encoding and decoding commands can be ;; called remotely with null input and output. This makes ;; sure there are no syntax errors and the command is really @@ -4019,15 +4018,16 @@ (tramp-error vec 'file-error "Couldn't find an inline transfer encoding")) - ;; Set connection properties. + ;; Set connection properties. Since the commands are risky (due + ;; to output direction), we cache them in the process cache. (tramp-message vec 5 "Using local encoding `%s'" loc-enc) - (tramp-set-connection-property vec "local-encoding" loc-enc) + (tramp-set-connection-property p "local-encoding" loc-enc) (tramp-message vec 5 "Using local decoding `%s'" loc-dec) - (tramp-set-connection-property vec "local-decoding" loc-dec) + (tramp-set-connection-property p "local-decoding" loc-dec) (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) - (tramp-set-connection-property vec "remote-encoding" rem-enc) + (tramp-set-connection-property p "remote-encoding" rem-enc) (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) - (tramp-set-connection-property vec "remote-decoding" rem-dec)))) + (tramp-set-connection-property p "remote-decoding" rem-dec)))) (defun tramp-call-local-coding-command (cmd input output) "Call the local encoding or decoding command. @@ -4065,8 +4065,8 @@ (save-excursion (let ((commands tramp-inline-compress-commands) (magic "xyzzy") - item compress decompress - found) + (p (tramp-get-connection-process vec)) + item compress decompress found) (while (and commands (not found)) (catch 'next (setq item (pop commands) @@ -4100,16 +4100,18 @@ ;; Did we find something? (if found (progn - ;; Set connection properties. + ;; Set connection properties. Since the commands are + ;; risky (due to output direction), we cache them in the + ;; process cache. (tramp-message vec 5 "Using inline transfer compress command `%s'" compress) - (tramp-set-connection-property vec "inline-compress" compress) + (tramp-set-connection-property p "inline-compress" compress) (tramp-message vec 5 "Using inline transfer decompress command `%s'" decompress) - (tramp-set-connection-property vec "inline-decompress" decompress)) + (tramp-set-connection-property p "inline-decompress" decompress)) - (tramp-set-connection-property vec "inline-compress" nil) - (tramp-set-connection-property vec "inline-decompress" nil) + (tramp-set-connection-property p "inline-compress" nil) + (tramp-set-connection-property p "inline-decompress" nil) (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) @@ -4117,18 +4119,43 @@ "Expands VEC according to `tramp-default-proxies-alist'. Gateway hops are already opened." (let ((target-alist `(,vec)) - (choices tramp-default-proxies-alist) - item proxy) + (hops (or (tramp-file-name-hop vec) "")) + (item vec) + choices proxy) + + ;; Ad-hoc proxy definitions. + (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) + (let ((user (tramp-file-name-user item)) + (host (tramp-file-name-host item)) + (proxy (concat + tramp-prefix-format proxy tramp-postfix-host-format))) + (tramp-message + vec 5 "Add proxy (\"%s\" \"%s\" \"%s\")" + (and (stringp host) (regexp-quote host)) + (and (stringp user) (regexp-quote user)) + proxy) + ;; Add the hop. + (add-to-list + 'tramp-default-proxies-alist + (list (and (stringp host) (regexp-quote host)) + (and (stringp user) (regexp-quote user)) + proxy)) + (setq item (tramp-dissect-file-name proxy)))) + ;; Save the new value. + (when (and hops tramp-save-ad-hoc-proxies) + (customize-save-variable + 'tramp-default-proxies-alist tramp-default-proxies-alist)) ;; Look for proxy hosts to be passed. + (setq choices tramp-default-proxies-alist) (while choices (setq item (pop choices) proxy (eval (nth 2 item))) (when (and - ;; host + ;; Host. (string-match (or (eval (nth 0 item)) "") (or (tramp-file-name-host (car target-alist)) "")) - ;; user + ;; User. (string-match (or (eval (nth 1 item)) "") (or (tramp-file-name-user (car target-alist)) ""))) (if (null proxy) @@ -4164,7 +4191,7 @@ 'target-alist (vector (tramp-file-name-method hop) (tramp-file-name-user hop) - (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil)) + (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil nil)) ;; For the password prompt, we need the correct values. ;; Therefore, we must remember the gateway vector. But we ;; cannot do it as connection property, because it shouldn't @@ -4212,6 +4239,9 @@ ;; Result. target-alist)) +(defvar tramp-current-connection nil + "Last connection timestamp.") + (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -4222,6 +4252,16 @@ (process-environment (copy-sequence process-environment)) (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) + ;; If Tramp opens the same connection within a short time frame, + ;; there is a problem. We shall signal this. + (unless (or (and p (processp p) (memq (process-status p) '(run open))) + (not (equal (butlast (append vec nil)) + (car tramp-current-connection))) + (> (tramp-time-diff + (current-time) (cdr tramp-current-connection)) + 5)) + (throw 'suppress 'suppress)) + ;; If too much time has passed since last command was sent, look ;; whether process is still alive. If it isn't, kill it. When ;; using ssh, it can sometimes happen that the remote end has @@ -4242,9 +4282,7 @@ ;; The error will be caught locally. (tramp-error vec 'file-error "Awake did fail"))) (file-error - (tramp-flush-connection-property vec) - (tramp-flush-connection-property p) - (delete-process p) + (tramp-cleanup vec) (setq p nil))) ;; New connection must be opened. @@ -4293,6 +4331,8 @@ (tramp-set-connection-property p "vector" vec) (set-process-sentinel p 'tramp-process-sentinel) (tramp-compat-set-process-query-on-exit-flag p nil) + (setq tramp-current-connection + (cons (butlast (append vec nil)) (current-time))) (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) @@ -4401,11 +4441,7 @@ ;; When the user did interrupt, we must cleanup. (quit - (let ((p (tramp-get-connection-process vec))) - (when (and p (processp p)) - (tramp-flush-connection-property vec) - (tramp-flush-connection-property p) - (delete-process p))) + (tramp-cleanup vec) ;; Propagate the quit signal. (signal (car err) (cdr err))))))) @@ -4942,9 +4978,10 @@ If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) (> size tramp-inline-compress-start-size)) - (with-connection-property vec prop + (with-connection-property (tramp-get-connection-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property vec prop nil)))) + (tramp-get-connection-property + (tramp-get-connection-process vec) prop nil)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -4962,9 +4999,10 @@ ;; no inline coding is found. (ignore-errors (let ((coding - (with-connection-property vec prop + (with-connection-property (tramp-get-connection-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property vec prop nil))) + (tramp-get-connection-property + (tramp-get-connection-process vec) prop nil))) (prop1 (if (string-match "encoding" prop) "inline-compress" "inline-decompress")) compress) === modified file 'lisp/net/tramp-smb.el' --- lisp/net/tramp-smb.el 2012-04-09 13:05:48 +0000 +++ lisp/net/tramp-smb.el 2012-06-11 10:30:07 +0000 @@ -43,7 +43,7 @@ ;; We define an empty command, because `tramp-smb-call-winexe' ;; opens already the powershell. Used in `tramp-handle-shell-command'. (tramp-remote-shell "") - ;; This is just a guess. We don't know whether the share "$C" + ;; This is just a guess. We don't know whether the share "C$" ;; is available for public use, and whether the user has write ;; access. (tramp-tmpdir "/C$/Temp")))) @@ -82,8 +82,18 @@ (defvar tramp-smb-version nil "Version string of the SMB client.") -(defconst tramp-smb-prompt "^smb: .+> \\|^\\s-+Server\\s-+Comment$" - "Regexp used as prompt in smbclient.") +(defconst tramp-smb-server-version + "Domain=\\[[^]]*\\] OS=\\[[^]]*\\] Server=\\[[^]]*\\]" + "Regexp of SMB server identification.") + +(defconst tramp-smb-prompt "^\\(smb:\\|PS\\) .+> \\|^\\s-+Server\\s-+Comment$" + "Regexp used as prompt in smbclient or powershell.") + +(defconst tramp-smb-wrong-passwd-regexp + (regexp-opt + '("NT_STATUS_LOGON_FAILURE" + "NT_STATUS_WRONG_PASSWORD")) + "Regexp for login error strings of SMB servers.") (defconst tramp-smb-errors (mapconcat @@ -155,6 +165,16 @@ See `tramp-actions-before-shell' for more info.") +(defconst tramp-smb-actions-with-tar + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-smb-errors tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-smb-action-with-tar)) + "List of pattern/action pairs. +This list is used for tar-like copy of directories. + +See `tramp-actions-before-shell' for more info.") + ;; New handlers should be added here. (defconst tramp-smb-file-name-handler-alist '( @@ -205,12 +225,14 @@ (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) + (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) (set-file-modes . tramp-smb-handle-set-file-modes) ;; `set-file-selinux-context' performed by default handler. (set-file-times . ignore) (set-visited-file-modtime . ignore) - (shell-command . ignore) + (shell-command . tramp-handle-shell-command) + (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) (vc-registered . ignore) @@ -220,11 +242,34 @@ "Alist of handler functions for Tramp SMB method. Operations not mentioned here will be handled by the default Emacs primitives.") +;; Options for remote processes via winexe. +(defcustom tramp-smb-winexe-program "winexe" + "Name of winexe client to run. +If it isn't found in the local $PATH, the absolute path of winexe +shall be given. This is needed for remote processes." + :group 'tramp + :type 'string + :version "24.2") + +(defcustom tramp-smb-winexe-shell-command "powershell.exe" + "Shell to be used for processes on remote machines. +This must be Powershell V2 compatible." + :group 'tramp + :type 'string + :version "24.2") + +(defcustom tramp-smb-winexe-shell-command-switch "-file -" + "Command switch used together with `tramp-smb-winexe-shell-command'. +This can be used to disable echo etc." + :group 'tramp + :type 'string + :version "24.2") + ;;;###tramp-autoload (defsubst tramp-smb-file-name-p (filename) "Check if it's a filename for SMB servers." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-smb-method))) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-smb-method)) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -287,14 +332,31 @@ "error with add-name-to-file, see buffer `%s' for details" (buffer-name)))))) +(defun tramp-smb-action-with-tar (proc vec) + "Untar from connection buffer." + (if (not (memq (process-status proc) '(run open))) + (throw 'tramp-action 'process-died) + + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (when (search-forward-regexp tramp-smb-server-version nil t) + ;; There might be a hidden password prompt. + (widen) + (forward-line) + (tramp-message vec 6 (buffer-substring (point-min) (point))) + (delete-region (point-min) (point)) + (throw 'tramp-action 'ok))))) + (defun tramp-smb-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) - "Like `copy-directory' for Tramp files. KEEP-DATE is not handled." + "Like `copy-directory' for Tramp files." (setq dirname (expand-file-name dirname) newname (expand-file-name newname)) (let ((t1 (tramp-tramp-file-p dirname)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 dirname newname) nil + (tramp-with-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) (cond ;; We must use a local temporary directory. ((and t1 t2) @@ -311,46 +373,121 @@ ;; We can copy recursively. ((or t1 t2) - (let ((prompt (tramp-smb-send-command v "prompt")) - (recurse (tramp-smb-send-command v "recurse"))) - (unless (file-directory-p newname) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) (make-directory newname parents)) + + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-real-host v)) + + (let* ((real-user (tramp-file-name-real-user v)) + (real-host (tramp-file-name-real-host v)) + (domain (tramp-file-name-domain v)) + (port (tramp-file-name-port v)) + (share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory)))) + (args (list tramp-smb-program + (concat "//" real-host "/" share) "-E"))) + + (if (not (zerop (length real-user))) + (setq args (append args (list "-U" real-user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq args + (if t1 + ;; Source is remote. + (append args + (list "-D" (shell-quote-argument localname) + "-c" (shell-quote-argument "tar qc - *") + "|" "tar" "xfC" "-" + (shell-quote-argument tmpdir))) + ;; Target is remote. + (append (list "tar" "cfC" "-" (shell-quote-argument dirname) + "." "|") + args + (list "-D" (shell-quote-argument localname) + "-c" (shell-quote-argument "tar qx -"))))) + (unwind-protect - (unless - (and - prompt recurse - (tramp-smb-send-command - v (format "cd \"%s\"" (tramp-smb-get-localname v))) - (tramp-smb-send-command - v (format "lcd \"%s\"" (if t1 newname dirname))) - (if t1 - (tramp-smb-send-command v "mget *") - (tramp-smb-send-command v "mput *"))) - ;; Error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (search-forward-regexp tramp-smb-errors nil t) - (tramp-error - v 'file-error - "%s `%s'" (match-string 0) (if t1 dirname newname)))) - ;; Go home. - (tramp-smb-send-command - v (format - "cd %s" (if (tramp-smb-get-cifs-capabilities v) "/" "\\"))) - ;; Toggle prompt and recurse OFF. - (if prompt (tramp-smb-send-command v "prompt")) - (if recurse (tramp-smb-send-command v "recurse"))))) + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + (when t1 + ;; The smbclient tar command creates always complete + ;; paths. We must emulate the directory structure, + ;; and symlink to the real target. + (make-directory + (expand-file-name ".." (concat tmpdir localname)) 'parents) + (make-symbolic-link + newname (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By this, password + ;; can be handled. + (let* ((default-directory tmpdir) + (p (start-process-shell-command + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + (mapconcat 'identity args " ")))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-with-tar) + + (while (memq (process-status p) '(run open)) + (sit-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil) + (when t1 (delete-directory tmpdir 'recurse)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (set-file-times newname (nth 5 (file-attributes dirname)))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))) ;; We must do it file-wise. (t (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))))))) + 'copy-directory (list dirname newname keep-date parents)))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-selinux-context) "Like `copy-file' for Tramp files. -KEEP-DATE is not handled in case NEWNAME resides on an SMB server. +KEEP-DATE has no effect in case NEWNAME resides on an SMB server. PRESERVE-UID-GID and PRESERVE-SELINUX-CONTEXT are completely ignored." (setq filename (expand-file-name filename) newname (expand-file-name newname)) @@ -358,40 +495,43 @@ (tramp-dissect-file-name (if (file-remote-p filename) filename newname)) 0 (format "Copying %s to %s" filename newname) - (let ((tmpfile (file-local-copy filename))) - - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (file-directory-p newname) - (setq newname - (expand-file-name (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (unless (tramp-smb-get-share v) - (tramp-error - v 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v (format "put \"%s\" \"%s\"" - filename (tramp-smb-get-localname v))) - (tramp-error v 'file-error "Cannot copy `%s'" filename)))))) - - ;; KEEP-DATE handling. - (when keep-date (set-file-times newname (nth 5 (file-attributes filename))))) + (if (file-directory-p filename) + (tramp-compat-copy-directory filename newname keep-date t t) + + (let ((tmpfile (file-local-copy filename))) + (if tmpfile + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (file-directory-p newname) + (setq newname + (expand-file-name (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + (unless (tramp-smb-get-share v) + (tramp-error + v 'file-error "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v (format "put \"%s\" \"%s\"" + filename (tramp-smb-get-localname v))) + (tramp-error v 'file-error "Cannot copy `%s'" filename)))))) + + ;; KEEP-DATE handling. + (when keep-date + (set-file-times newname (nth 5 (file-attributes filename)))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive) "Like `delete-directory' for Tramp files." @@ -539,7 +679,7 @@ "Implement `file-attributes' for Tramp files using stat command." (tramp-message vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec)) - (with-current-buffer (tramp-get-buffer vec) + (with-current-buffer (tramp-get-connection-buffer vec) (let* (size id link uid gid atime mtime ctime mode inode) (when (tramp-smb-send-command vec (format "stat \"%s\"" (tramp-smb-get-localname vec))) @@ -845,44 +985,170 @@ "error with make-symbolic-link, see buffer `%s' for details" (buffer-name)))))) +(defun tramp-smb-handle-process-file + (program &optional infile destination display &rest args) + "Like `process-file' for Tramp files." + ;; The implementation is not complete yet. + (when (and (numberp destination) (zerop destination)) + (error "Implementation does not handle immediate return")) + + (with-parsed-tramp-file-name default-directory nil + (let* ((name (file-name-nondirectory program)) + (name1 name) + (i 0) + input tmpinput outbuf command ret) + + ;; Determine input. + (when infile + (setq infile (expand-file-name infile)) + (if (tramp-equal-remote default-directory infile) + ;; INFILE is on the same remote host. + (setq input (with-parsed-tramp-file-name infile nil localname)) + ;; INFILE must be copied to remote host. + (setq input (tramp-make-tramp-temp-file v) + tmpinput (tramp-make-tramp-file-name method user host input)) + (copy-file infile tmpinput t)) + ;; Transform input into a filename powershell does understand. + (setq input (format "//%s%s" host input))) + + ;; Determine output. + (cond + ;; Just a buffer. + ((bufferp destination) + (setq outbuf destination)) + ;; A buffer name. + ((stringp destination) + (setq outbuf (get-buffer-create destination))) + ;; (REAL-DESTINATION ERROR-DESTINATION) + ((consp destination) + ;; output. + (cond + ((bufferp (car destination)) + (setq outbuf (car destination))) + ((stringp (car destination)) + (setq outbuf (get-buffer-create (car destination)))) + ((car destination) + (setq outbuf (current-buffer)))) + ;; stderr. + (tramp-message v 2 "%s" "STDERR not supported")) + ;; 't + (destination + (setq outbuf (current-buffer)))) + + ;; Construct command. + (setq command (mapconcat 'identity (cons program args) " ") + command (if input + (format + "get-content %s | & %s" + (tramp-smb-shell-quote-argument input) command) + (format "& %s" command))) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property + v "process-buffer" + (or outbuf (generate-new-buffer tramp-temp-buffer-name))) + + ;; Call it. + (condition-case nil + (with-current-buffer (tramp-get-connection-buffer v) + ;; Preserve buffer contents. + (narrow-to-region (point-max) (point-max)) + (tramp-smb-call-winexe v) + (when (tramp-smb-get-share v) + (tramp-smb-send-command + v (format "cd \"//%s%s\"" host (file-name-directory localname)))) + (tramp-smb-send-command v command) + ;; Preserve command output. + (narrow-to-region (point-max) (point-max)) + (let ((p (tramp-get-connection-process v))) + (tramp-smb-send-command v "exit $lasterrorcode") + (while (memq (process-status p) '(run open)) + (sleep-for 0.1) + (setq ret (process-exit-status p)))) + (delete-region (point-min) (point-max)) + (widen)) + + ;; When the user did interrupt, we should do it also. We use + ;; return code -1 as marker. + (quit + (setq ret -1)) + ;; Handle errors. + (error + (setq ret 1))) + + ;; We should show the output anyway. + (when (and outbuf display) (display-buffer outbuf)) + + ;; Cleanup. We remove all file cache values for the connection, + ;; because the remote process could have changed them. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil) + (when tmpinput (delete-file tmpinput)) + (unless outbuf + (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) + + ;; `process-file-side-effects' has been introduced with GNU + ;; Emacs 23.2. If set to `nil', no remote file will be changed + ;; by `program'. If it doesn't exist, we assume its default + ;; value `t'. + (unless (and (boundp 'process-file-side-effects) + (not (symbol-value 'process-file-side-effects))) + (tramp-flush-directory-property v "")) + + ;; Return exit status. + (if (equal ret -1) + (keyboard-quit) + ret)))) + (defun tramp-smb-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." (setq filename (expand-file-name filename) newname (expand-file-name newname)) + + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error + (tramp-dissect-file-name + (if (file-remote-p filename) filename newname)) + 'file-already-exists newname)) + (tramp-with-progress-reporter (tramp-dissect-file-name (if (file-remote-p filename) filename newname)) 0 (format "Renaming %s to %s" filename newname) - (let ((tmpfile (file-local-copy filename))) - - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (file-directory-p newname) - (setq newname (expand-file-name - (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (unless (tramp-smb-send-command - v (format "put %s \"%s\"" - filename (tramp-smb-get-localname v))) - (tramp-error v 'file-error "Cannot rename `%s'" filename))))) - - (delete-file filename))) + (if (and (tramp-equal-remote filename newname) + (string-equal + (tramp-smb-get-share (tramp-dissect-file-name filename)) + (tramp-smb-get-share (tramp-dissect-file-name newname)))) + ;; We can rename directly. + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-property v2 (file-name-directory v2-localname)) + (tramp-flush-file-property v2 v2-localname) + (unless (tramp-smb-get-share v2) + (tramp-error + v2 'file-error "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v2 (format "rename \"%s\" \"%s\"" + (tramp-smb-get-localname v1) + (tramp-smb-get-localname v2))) + (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) + + ;; We must rename via copy. + (tramp-compat-copy-file filename newname ok-if-already-exists t t t) + (if (file-directory-p filename) + (tramp-compat-delete-directory filename 'recursive) + (delete-file filename))))) (defun tramp-smb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." @@ -896,6 +1162,54 @@ (tramp-error v 'file-error "Error while changing file's mode %s" filename))))) +;; We use BUFFER also as connection buffer during setup. Because of +;; this, its original contents must be saved, and restored once +;; connection has been setup. +(defun tramp-smb-handle-start-file-process (name buffer program &rest args) + "Like `start-file-process' for Tramp files." + (with-parsed-tramp-file-name default-directory nil + (let ((command (mapconcat 'identity (cons program args) " ")) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + (unwind-protect + (save-excursion + (save-restriction + (unless buffer + ;; BUFFER can be nil. We use a temporary buffer. + (setq buffer (generate-new-buffer tramp-temp-buffer-name))) + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property v "process-buffer" buffer) + ;; Activate narrowing in order to save BUFFER contents. + (with-current-buffer (tramp-get-connection-buffer v) + (let ((buffer-undo-list t)) + (narrow-to-region (point-max) (point-max)) + (tramp-smb-call-winexe v) + (when (tramp-smb-get-share v) + (tramp-smb-send-command + v (format + "cd \"//%s%s\"" + host (file-name-directory localname)))) + (tramp-message v 6 "(%s); exit" command) + (tramp-send-string v command))) + ;; Return value. + (tramp-get-connection-process v))) + + ;; Save exit. + (with-current-buffer (tramp-get-connection-buffer v) + (if (string-match tramp-temp-buffer-name (buffer-name)) + (progn + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp))) + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil))))) + (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `handle-substitute-in-file-name' for Tramp files. \"//\" substitutes only in the local filename part. Catches @@ -999,7 +1313,7 @@ (with-parsed-tramp-file-name (file-name-as-directory directory) nil (setq localname (or localname "/")) (with-file-property v localname "file-entries" - (with-current-buffer (tramp-get-buffer v) + (with-current-buffer (tramp-get-connection-buffer v) (let* ((share (tramp-smb-get-share v)) (cache (tramp-get-connection-property v "share-cache" nil)) res entry) @@ -1187,7 +1501,7 @@ (tramp-get-connection-process vec) "cifs-capabilities" (save-match-data (when (tramp-smb-send-command vec "posix") - (with-current-buffer (tramp-get-buffer vec) + (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) (when (re-search-forward "Server supports CIFS capabilities" nil t) @@ -1216,18 +1530,20 @@ (tramp-send-string vec command) (tramp-smb-wait-for-output vec)) -(defun tramp-smb-maybe-open-connection (vec) +(defun tramp-smb-maybe-open-connection (vec &optional argument) "Maybe open a connection to HOST, log in as USER, using `tramp-smb-program'. Does not do anything if a connection is already open, but re-opens the -connection if a previous connection has died for some reason." +connection if a previous connection has died for some reason. +If ARGUMENT is non-nil, use it as argument for +`tramp-smb-winexe-program', and suppress any checks." (let* ((share (tramp-smb-get-share vec)) - (buf (tramp-get-buffer vec)) + (buf (tramp-get-connection-buffer vec)) (p (get-buffer-process buf))) ;; Check whether we still have the same smbclient version. ;; Otherwise, we must delete the connection cache, because ;; capabilities migh have changed. - (unless (processp p) + (unless (or argument (processp p)) (let ((default-directory (tramp-compat-temporary-file-directory)) (command (concat tramp-smb-program " -V"))) @@ -1271,9 +1587,10 @@ ;; Check whether it is still the same share. (unless (and p (processp p) (memq (process-status p) '(run open)) - (string-equal - share - (tramp-get-connection-property p "smb-share" ""))) + (or argument + (string-equal + share + (tramp-get-connection-property p "smb-share" "")))) (save-match-data ;; There might be unread output from checking for share names. @@ -1288,9 +1605,13 @@ (port (tramp-file-name-port vec)) args) - (if share - (setq args (list (concat "//" real-host "/" share))) - (setq args (list "-g" "-L" real-host ))) + (cond + (argument + (setq args (list (concat "//" real-host)))) + (share + (setq args (list (concat "//" real-host "/" share)))) + (t + (setq args (list "-g" "-L" real-host )))) (if (not (zerop (length real-user))) (setq args (append args (list "-U" real-user))) @@ -1300,6 +1621,8 @@ (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (when argument + (setq args (append args (list argument)))) ;; OK, let's go. (tramp-with-progress-reporter @@ -1313,8 +1636,11 @@ (p (let ((default-directory (tramp-compat-temporary-file-directory))) (apply #'start-process - (tramp-buffer-name vec) (tramp-get-buffer vec) - tramp-smb-program args)))) + (tramp-get-connection-name vec) + (tramp-get-connection-buffer vec) + (if argument + tramp-smb-winexe-program tramp-smb-program) + args)))) (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) @@ -1325,40 +1651,58 @@ tramp-current-user user tramp-current-host host) - ;; Play login scenario. - (tramp-process-actions - p vec nil - (if share - tramp-smb-actions-with-share - tramp-smb-actions-without-share)) - - ;; Check server version. - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-min)) - (search-forward-regexp - "Domain=\\[[^]]*\\] OS=\\[[^]]*\\] Server=\\[[^]]*\\]" nil t) - (let ((smbserver-version (match-string 0))) - (unless - (string-equal - smbserver-version - (tramp-get-connection-property - vec "smbserver-version" smbserver-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) - (tramp-set-connection-property - vec "smbserver-version" smbserver-version))) - - ;; Set chunksize. Otherwise, `tramp-send-string' might - ;; try it itself. - (tramp-set-connection-property p "smb-share" share) - (tramp-set-connection-property - p "chunksize" tramp-chunksize)))))))) + (condition-case err + (let (tramp-message-show-message) + ;; Play login scenario. + (tramp-process-actions + p vec nil + (if (or argument share) + tramp-smb-actions-with-share + tramp-smb-actions-without-share)) + + ;; Check server version. + (unless argument + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (search-forward-regexp tramp-smb-server-version nil t) + (let ((smbserver-version (match-string 0))) + (unless + (string-equal + smbserver-version + (tramp-get-connection-property + vec "smbserver-version" smbserver-version)) + (tramp-flush-directory-property vec "") + (tramp-flush-connection-property vec)) + (tramp-set-connection-property + vec "smbserver-version" smbserver-version)))) + + ;; Set chunksize. Otherwise, `tramp-send-string' might + ;; try it itself. + (tramp-set-connection-property p "smb-share" share) + (tramp-set-connection-property + p "chunksize" tramp-chunksize)) + + ;; Check for the error reason. If it was due to wrong + ;; password, reestablish the connection. We cannot + ;; handle this in `tramp-process-actions', because + ;; smbclient does not ask for the password, again. + (error + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (if (search-forward-regexp + tramp-smb-wrong-passwd-regexp nil t) + ;; Disable `auth-source' and `password-cache'. + (let (auth-sources) + (tramp-cleanup vec) + (tramp-smb-maybe-open-connection vec argument)) + ;; Propagate the error. + (signal (car err) (cdr err))))))))))))) ;; We don't use timeouts. If needed, the caller shall wrap around. (defun tramp-smb-wait-for-output (vec) "Wait for output from smbclient command. Returns nil if an error message has appeared." - (with-current-buffer (tramp-get-buffer vec) + (with-current-buffer (tramp-get-connection-buffer vec) (let ((p (get-buffer-process (current-buffer))) (found (progn (goto-char (point-min)) (re-search-forward tramp-smb-prompt nil t))) @@ -1392,10 +1736,68 @@ (goto-char (point-min)) (setq found (re-search-forward tramp-smb-prompt nil t))) + (tramp-message vec 6 "\n%s" (buffer-string)) + + ;; Remove prompt. + (when found + (goto-char (point-max)) + (re-search-backward tramp-smb-prompt nil t) + (delete-region (point) (point-max))) + ;; Return value is whether no error message has appeared. - (tramp-message vec 6 "\n%s" (buffer-string)) (not err)))) +(defun tramp-smb-kill-winexe-function () + "Send SIGKILL to the winexe process." + (ignore-errors + (let ((p (get-buffer-process (current-buffer)))) + (when (and p (processp p) (memq (process-status p) '(run open))) + (signal-process (process-id p) 'SIGINT))))) + +(defun tramp-smb-call-winexe (vec) + "Apply a remote command, if possible, using `tramp-smb-winexe-program'." + + ;; We call `tramp-get-buffer' in order to get a debug buffer for + ;; messages. + (tramp-get-buffer vec) + + ;; Check for program. + (unless (let ((default-directory + (tramp-compat-temporary-file-directory))) + (executable-find tramp-smb-winexe-program)) + (tramp-error + vec 'file-error "Cannot find program: %s" tramp-smb-winexe-program)) + + ;; winexe does not supports ports. + (when (tramp-file-name-port vec) + (tramp-error vec 'file-error "Port not supported for remote processes")) + + (tramp-smb-maybe-open-connection + vec + (format + "%s %s" + tramp-smb-winexe-shell-command tramp-smb-winexe-shell-command-switch)) + + (set (make-local-variable 'kill-buffer-hook) + '(tramp-smb-kill-winexe-function)) + + ;; Suppress "^M". Shouldn't we specify utf8? + (set-process-coding-system (tramp-get-connection-process vec) 'raw-text-dos) + + ;; Set width to 128. This avoids mixing prompt and long error messages. + (tramp-smb-send-command vec "$rawui = (Get-Host).UI.RawUI") + (tramp-smb-send-command vec "$bufsize = $rawui.BufferSize") + (tramp-smb-send-command vec "$winsize = $rawui.WindowSize") + (tramp-smb-send-command vec "$bufsize.Width = 128") + (tramp-smb-send-command vec "$winsize.Width = 128") + (tramp-smb-send-command vec "$rawui.BufferSize = $bufsize") + (tramp-smb-send-command vec "$rawui.WindowSize = $winsize")) + +(defun tramp-smb-shell-quote-argument (s) + "Similar to `shell-quote-argument', but uses windows cmd syntax." + (let ((system-type 'ms-dos)) + (shell-quote-argument s))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-smb 'force))) @@ -1404,12 +1806,9 @@ ;;; TODO: -;; * Error handling in case password is wrong. ;; * Return more comprehensive file permission string. ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. -;; * (RMS) Use unwind-protect to clean up the state so as to make the state -;; regular again. ;; * Ignore case in file names. ;;; tramp-smb.el ends here === modified file 'lisp/net/tramp.el' --- lisp/net/tramp.el 2012-06-01 13:23:26 +0000 +++ lisp/net/tramp.el 2012-06-11 10:30:07 +0000 @@ -57,6 +57,7 @@ ;;; Code: +(eval-when-compile (require 'cl)) ; ignore-errors (require 'tramp-compat) ;;; User Customizable Internal Variables: @@ -116,7 +117,7 @@ (eval-and-compile (when (featurep 'xemacs) (defcustom tramp-bkup-backup-directory-info nil - "*Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) + "Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) It has the same meaning like `bkup-backup-directory-info' from package `backup-dir'. If a Tramp file is backed up, and BACKUP-DIR is a local file name, the backup directory is prepended with Tramp file name prefix @@ -247,15 +248,6 @@ * `tramp-gw-args' As the attribute name says, additional arguments are specified here when a method is applied via a gateway. - * `tramp-password-end-of-line' - This specifies the string to use for terminating the line after - submitting the password. If this method parameter is nil, then the - value of the normal variable `tramp-default-password-end-of-line' - is used. This parameter is necessary because the \"plink\" program - requires any two characters after sending the password. These do - not have to be newline or carriage return characters. Other login - programs are happy with just one character, the newline character. - We use \"xy\" as the value for methods using \"plink\". * `tramp-tmpdir' A directory on the remote host for temporary files. If not specified, \"/tmp\" is taken as default. @@ -408,6 +400,11 @@ (choice :tag "User regexp" regexp sexp) (choice :tag " Proxy name" string (const nil))))) +(defcustom tramp-save-ad-hoc-proxies nil + "Whether to save ad-hoc proxies persistently." + :group 'tramp + :type 'boolean) + ;;;###tramp-autoload (defconst tramp-local-host-regexp (concat @@ -432,7 +429,7 @@ * `tramp-parse-hosts' for \"/etc/hosts\" like files, * `tramp-parse-passwd' for \"/etc/passwd\" like files. * `tramp-parse-netrc' for \"~/.netrc\" like files. - * `tramp-parse-putty' for PuTTY registry keys. + * `tramp-parse-putty' for PuTTY registered sessions. FUNCTION can also be a customer defined function. For more details see the info pages.") @@ -471,24 +468,7 @@ (defcustom tramp-rsh-end-of-line "\n" "String used for end of line in rsh connections. I don't think this ever needs to be changed, so please tell me about it -if you need to change this. -Also see the method parameter `tramp-password-end-of-line' and the normal -variable `tramp-default-password-end-of-line'." - :group 'tramp - :type 'string) - -(defcustom tramp-default-password-end-of-line - tramp-rsh-end-of-line - "String used for end of line after sending a password. -This variable provides the default value for the method parameter -`tramp-password-end-of-line', see `tramp-methods' for more details. - -It seems that people using plink under Windows need to send -\"\\r\\n\" (carriage-return, then newline) after a password, but just -\"\\n\" after all other lines. This variable can be used for the -password, see `tramp-rsh-end-of-line' for the other cases. - -The default value is to use the same value as `tramp-rsh-end-of-line'." +if you need to change this." :group 'tramp :type 'string) @@ -505,8 +485,10 @@ ;; Allow a prompt to start right after a ^M since it indeed would be ;; displayed at the beginning of the line (and Zsh uses it). This ;; regexp works only for GNU Emacs. + ;; Allow also [] style prompts. They can appear only during + ;; connection initialization; Tramp redefines the prompt afterwards. (concat (if (featurep 'xemacs) "" "\\(?:^\\|\r\\)") - "[^#$%>\n]*#?[#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") + "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' correctly, but sometimes it happens that you are connecting to a @@ -695,7 +677,7 @@ "Regexp matching delimiter between method and user or host names. Derived from `tramp-postfix-method-format'.") -(defconst tramp-user-regexp "[^:/ \t]+" +(defconst tramp-user-regexp "[^/|: \t]+" "Regexp matching user names.") ;;;###tramp-autoload @@ -783,6 +765,14 @@ "\\(" tramp-port-regexp "\\)") "Regexp matching host names with port numbers.") +(defconst tramp-postfix-hop-format "|" + "String matching delimiter after ad-hoc hop definitions.") + +(defconst tramp-postfix-hop-regexp + (regexp-quote tramp-postfix-hop-format) + "Regexp matching delimiter after ad-hoc hop definitions. +Derived from `tramp-postfix-hop-format'.") + (defconst tramp-postfix-host-format (cond ((equal tramp-syntax 'ftp) ":") ((equal tramp-syntax 'sep) "]") @@ -801,22 +791,26 @@ ;;; File name format: +(defconst tramp-remote-file-name-spec-regexp + (concat + "\\(?:" "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\)?" + "\\(?:" "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\)?" + "\\(" "\\(?:" tramp-host-regexp "\\|" + tramp-prefix-ipv6-regexp tramp-ipv6-regexp + tramp-postfix-ipv6-regexp "\\)" + "\\(?:" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?") +"Regular expression matching a Tramp file name between prefix and postfix.") + (defconst tramp-file-name-structure (list (concat tramp-prefix-regexp - "\\(" "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\)?" - "\\(" "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\)?" - "\\(" "\\(" tramp-host-regexp - "\\|" - tramp-prefix-ipv6-regexp tramp-ipv6-regexp - tramp-postfix-ipv6-regexp "\\)" - "\\(" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?" - tramp-postfix-host-regexp + "\\(" "\\(?:" tramp-remote-file-name-spec-regexp + tramp-postfix-hop-regexp "\\)+" "\\)?" + tramp-remote-file-name-spec-regexp tramp-postfix-host-regexp "\\(" tramp-localname-regexp "\\)") - 2 4 5 8) - - "List of five elements (REGEXP METHOD USER HOST FILE), detailing \ + 5 6 7 8 1) + "List of six elements (REGEXP METHOD USER HOST FILE HOP), detailing \ the Tramp file name structure. The first element REGEXP is a regular expression matching a Tramp file @@ -827,6 +821,9 @@ parentheses matches the method name. The third element USER is similar, but for the user name. The fourth element HOST is similar, but for the host name. The fifth element FILE is for the file name. +The last element HOP is the ad-hoc hop definition, which could be a +cascade of several hops. + These numbers are passed directly to `match-string', which see. That means the opening parentheses are counted to identify the pair. @@ -835,8 +832,8 @@ ;;;###autoload (defconst tramp-file-name-regexp-unified (if (memq system-type '(cygwin windows-nt)) - "\\`/\\([^[/:]\\{2,\\}\\|[^/]\\{2,\\}]\\):" - "\\`/\\([^[/:]+\\|[^/]+]\\):") + "\\`/\\([^[/|:]\\{2,\\}\\|[^/|]\\{2,\\}]\\):" + "\\`/\\([^[/|:]+\\|[^/|]+]\\):") "Value for `tramp-file-name-regexp' for unified remoting. Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and Tramp. See `tramp-file-name-structure' for more explanations. @@ -850,7 +847,7 @@ See `tramp-file-name-structure' for more explanations.") ;;;###autoload -(defconst tramp-file-name-regexp-url "\\`/[^/:]+://" +(defconst tramp-file-name-regexp-url "\\`/[^/|:]+://" "Value for `tramp-file-name-regexp' for URL-like remoting. See `tramp-file-name-structure' for more explanations.") @@ -1041,9 +1038,15 @@ ;; internal data structure. Convenience functions for internal ;; data structure. +(defun tramp-get-method-parameter (method param) + "Return the method parameter PARAM. +If the `tramp-methods' entry does not exist, return nil." + (let ((entry (assoc param (assoc method tramp-methods)))) + (when entry (cadr entry)))) + (defun tramp-file-name-p (vec) "Check, whether VEC is a Tramp object." - (and (vectorp vec) (= 4 (length vec)))) + (and (vectorp vec) (= 5 (length vec)))) (defun tramp-file-name-method (vec) "Return method component of VEC." @@ -1061,6 +1064,10 @@ "Return localname component of VEC." (and (tramp-file-name-p vec) (aref vec 3))) +(defun tramp-file-name-hop (vec) + "Return hop component of VEC." + (and (tramp-file-name-p vec) (aref vec 4))) + ;; The user part of a Tramp file name vector can be of kind ;; "user%domain". Sometimes, we must extract these parts. (defun tramp-file-name-real-user (vec) @@ -1157,19 +1164,20 @@ (let ((method (match-string (nth 1 tramp-file-name-structure) name)) (user (match-string (nth 2 tramp-file-name-structure) name)) (host (match-string (nth 3 tramp-file-name-structure) name)) - (localname (match-string (nth 4 tramp-file-name-structure) name))) + (localname (match-string (nth 4 tramp-file-name-structure) name)) + (hop (match-string (nth 5 tramp-file-name-structure) name))) (when host (when (string-match tramp-prefix-ipv6-regexp host) (setq host (replace-match "" nil t host))) (when (string-match tramp-postfix-ipv6-regexp host) (setq host (replace-match "" nil t host)))) (if nodefault - (vector method user host localname) + (vector method user host localname hop) (vector (tramp-find-method method user host) (tramp-find-user method user host) (tramp-find-host method user host) - localname)))))) + localname hop)))))) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1183,9 +1191,10 @@ (format "*tramp/%s %s@%s*" method user host) (format "*tramp/%s %s*" method host)))) -(defun tramp-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME." - (concat tramp-prefix-format +(defun tramp-make-tramp-file-name (method user host localname &optional hop) + "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. +When not nil, an optional HOP is prepended." + (concat tramp-prefix-format hop (when (not (zerop (length method))) (concat method tramp-postfix-method-format)) (when (not (zerop (length user))) @@ -1357,6 +1366,10 @@ This variable is used to disable messages from `tramp-error'. The messages are visible anyway, because an error is raised.") +(defvar tramp-message-show-progress-reporter-message t + "Show Tramp progress reporter message in the minibuffer. +This variable is used to disable recurive progress reporter messages.") + (defsubst tramp-message (vec-or-proc level fmt-string &rest args) "Emit a message depending on verbosity level. VEC-OR-PROC identifies the Tramp buffer to use. It can be either a @@ -1422,13 +1435,14 @@ (unwind-protect (apply 'tramp-error vec-or-proc signal fmt-string args) (when (and vec-or-proc + tramp-message-show-message (not (zerop tramp-verbose)) (not (tramp-completion-mode-p))) (let ((enable-recursive-minibuffers t)) (pop-to-buffer (or (and (bufferp buffer) buffer) (and (processp vec-or-proc) (process-buffer vec-or-proc)) - (tramp-get-buffer vec-or-proc))) + (tramp-get-connection-buffer vec-or-proc))) (sit-for 30)))))) (defmacro with-parsed-tramp-file-name (filename var &rest body) @@ -1439,13 +1453,14 @@ the filename structure. It is also used as a prefix for the variables holding the components. For example, if VAR is the symbol `foo', then `foo' will be bound to the whole structure, `foo-method' will be bound to -the method component, and so on for `foo-user', `foo-host', `foo-localname'. +the method component, and so on for `foo-user', `foo-host', `foo-localname', +`foo-hop'. Remaining args are Lisp expressions to be evaluated (inside an implicit `progn'). If VAR is nil, then we bind `v' to the structure and `method', `user', -`host', `localname' to the components." +`host', `localname', `hop' to the components." `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) (,(if var (intern (concat (symbol-name var) "-method")) 'method) (tramp-file-name-method ,(or var 'v))) @@ -1454,7 +1469,9 @@ (,(if var (intern (concat (symbol-name var) "-host")) 'host) (tramp-file-name-host ,(or var 'v))) (,(if var (intern (concat (symbol-name var) "-localname")) 'localname) - (tramp-file-name-localname ,(or var 'v)))) + (tramp-file-name-localname ,(or var 'v))) + (,(if var (intern (concat (symbol-name var) "-hop")) 'hop) + (tramp-file-name-hop ,(or var 'v)))) ,@body)) (put 'with-parsed-tramp-file-name 'lisp-indent-function 2) @@ -1478,7 +1495,8 @@ (tramp-message ,vec ,level "%s..." ,message) ;; We start a pulsing progress reporter after 3 seconds. Feature ;; introduced in Emacs 24.1. - (when (and tramp-message-show-message + (when (and tramp-message-show-progress-reporter-message + tramp-message-show-message ;; Display only when there is a minimum level. (<= ,level (min tramp-verbose 3))) (ignore-errors @@ -1486,11 +1504,10 @@ tm (when pr (run-at-time 3 0.1 'tramp-progress-reporter-update pr))))) (unwind-protect - ;; Execute the body. Unset `tramp-message-show-message' when - ;; the timer object is created, in order to suppress - ;; concurrent timers. - (let ((tramp-message-show-message - (and tramp-message-show-message (not tm)))) + ;; Execute the body. Suppress concurrent progress reporter + ;; messages. + (let ((tramp-message-show-progress-reporter-message + (and tramp-message-show-progress-reporter-message (not tm)))) ,@body) ;; Stop progress reporter. (if tm (tramp-compat-funcall 'cancel-timer tm)) @@ -1514,6 +1531,19 @@ 'identity)) +(defun tramp-cleanup (vec) + "Cleanup connection VEC, but keep the debug buffer." + (with-current-buffer (tramp-get-debug-buffer vec) + ;; Keep the debug buffer. + (rename-buffer + (generate-new-buffer-name tramp-temp-buffer-name) 'unique) + (tramp-cleanup-connection vec) + (if (= (point-min) (point-max)) + (kill-buffer nil) + (rename-buffer (tramp-debug-buffer-name vec) 'unique)) + ;; We call `tramp-get-buffer' in order to keep the debug buffer. + (tramp-get-buffer vec))) + ;;; Config Manipulation Functions: ;;;###tramp-autoload @@ -1522,9 +1552,7 @@ FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). The FUNCTION is intended to parse FILE according its syntax. It might be a predefined FUNCTION, or a user defined FUNCTION. -Predefined FUNCTIONs are `tramp-parse-rhosts', `tramp-parse-shosts', -`tramp-parse-sconfig', `tramp-parse-hosts', `tramp-parse-passwd', -and `tramp-parse-netrc'. +For the list of predefined FUNCTIONs see `tramp-completion-function-alist'. Example: @@ -1617,7 +1645,9 @@ (ignore-errors (let ((end (or (tramp-compat-funcall 'overlay-end (symbol-value 'rfn-eshadow-overlay)) - (tramp-compat-funcall 'minibuffer-prompt-end)))) + (tramp-compat-funcall 'minibuffer-prompt-end))) + ;; We do not want to send any remote command. + (non-essential t)) (when (file-remote-p (tramp-compat-funcall @@ -1810,7 +1840,7 @@ ;; Emacs 23+ only. 'copy-directory ;; Emacs 24+ only. - 'file-equal-p 'file-in-directory-p + 'file-in-directory-p 'file-equal-p ;; XEmacs only. 'dired-make-relative-symlink 'vm-imap-move-mail 'vm-pop-move-mail 'vm-spool-move-mail)) @@ -1886,8 +1916,9 @@ (with-parsed-tramp-file-name filename nil ;; Call the backend function. (if foreign - (condition-case err - (let ((sf (symbol-function foreign))) + (tramp-compat-condition-case-unless-debug err + (let ((sf (symbol-function foreign)) + result) ;; Some packages set the default directory to a ;; remote path, before respective Tramp packages ;; are already loaded. This results in @@ -1897,7 +1928,22 @@ (let ((default-directory (tramp-compat-temporary-file-directory))) (load (cadr sf) 'noerror 'nomessage))) - (apply foreign operation args)) + ;; If Tramp detects that it shouldn't continue + ;; to work, it throws the `suppress' event. We + ;; try the default handler then. + ;; This could happen for example, when Tramp + ;; tries to open the same connection twice in a + ;; short time frame. + (setq result + (catch 'suppress (apply foreign operation args))) + (if (eq result 'suppress) + (let (tramp-message-show-message) + (tramp-message + v 1 "Suppress received in operation %s" + (append (list operation) args)) + (tramp-cleanup v) + (tramp-run-real-handler operation args)) + result)) ;; Trace that somebody has interrupted the operation. ((debug quit) @@ -1912,8 +1958,7 @@ ;; operations shall return at least a default value ;; in order to give the user a chance to correct the ;; file name in the minibuffer. - ;; We cannot use `debug' as error handler. In order - ;; to get a full backtrace, one could apply + ;; In order to get a full backtrace, one could apply ;; (setq debug-on-error t debug-on-signal t) (error (cond @@ -2124,18 +2169,27 @@ (defun tramp-completion-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for partial Tramp files." - (let* ((fullname (tramp-drop-volume-letter - (expand-file-name filename directory))) - ;; Possible completion structures. - (v (tramp-completion-dissect-file-name fullname)) - result result1) - - (while v - (let* ((car (car v)) - (method (tramp-file-name-method car)) - (user (tramp-file-name-user car)) - (host (tramp-file-name-host car)) - (localname (tramp-file-name-localname car)) + (let ((fullname + (tramp-drop-volume-letter (expand-file-name filename directory))) + hop result result1) + + ;; Suppress hop from completion. + (when (string-match + (concat + tramp-prefix-regexp + "\\(" "\\(" tramp-remote-file-name-spec-regexp + tramp-postfix-hop-regexp + "\\)+" "\\)") + fullname) + (setq hop (match-string 1 fullname) + fullname (replace-match "" nil nil fullname 1))) + + ;; Possible completion structures. + (dolist (elt (tramp-completion-dissect-file-name fullname)) + (let* ((method (tramp-file-name-method elt)) + (user (tramp-file-name-user elt)) + (host (tramp-file-name-host elt)) + (localname (tramp-file-name-localname elt)) (m (tramp-find-method method user host)) (tramp-current-user user) ; see `tramp-parse-passwd' all-user-hosts) @@ -2163,18 +2217,16 @@ ;; Possible methods. (setq result - (append result (tramp-get-completion-methods m))))) - - (setq v (cdr v)))) - - ;; Unify list, remove nil elements. - (while result - (let ((car (car result))) - (when car - (add-to-list - 'result1 - (substring car (length (tramp-drop-volume-letter directory))))) - (setq result (cdr result)))) + (append result (tramp-get-completion-methods m))))))) + + ;; Unify list, add hop, remove nil elements. + (dolist (elt result) + (when elt + (string-match tramp-prefix-regexp elt) + (setq elt (replace-match (concat tramp-prefix-format hop) nil nil elt)) + (add-to-list + 'result1 + (substring elt (length (tramp-drop-volume-letter directory)))))) ;; Complete local parts. (append @@ -2322,9 +2374,9 @@ (concat tramp-prefix-regexp "/$")) 1 nil 3 nil))) - (mapc (lambda (regexp) + (mapc (lambda (structure) (add-to-list 'result - (tramp-completion-dissect-file-name1 regexp name))) + (tramp-completion-dissect-file-name1 structure name))) (list tramp-completion-file-name-structure1 tramp-completion-file-name-structure2 @@ -2358,7 +2410,7 @@ (match-string (nth 3 structure) name))) (localname (and (nth 4 structure) (match-string (nth 4 structure) name)))) - (vector method user host localname))))) + (vector method user host localname nil))))) ;; This function returns all possible method completions, adding the ;; trailing method delimiter. @@ -2372,7 +2424,8 @@ (mapcar 'car tramp-methods))) ;; Compares partial user and host names with possible completions. -(defun tramp-get-completion-user-host (method partial-user partial-host user host) +(defun tramp-get-completion-user-host + (method partial-user partial-host user host) "Returns the most expanded string for user and host name completion. PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (cond @@ -2403,21 +2456,36 @@ (unless (zerop (+ (length user) (length host))) (tramp-completion-make-tramp-file-name method user host nil))) +;; Generic function. +(defun tramp-parse-group (regexp match-level skip-regexp) + "Return a (user host) tuple allowed to access. +User is always nil." + (let (result) + (when (re-search-forward regexp (point-at-eol) t) + (setq result (list nil (match-string match-level)))) + (or + (> (skip-chars-forward skip-regexp) 0) + (forward-line 1)) + result)) + +;; Generic function. +(defun tramp-parse-file (filename function) + "Return a list of (user host) tuples allowed to access. +User is always nil." + ;; On Windows, there are problems in completion when + ;; `default-directory' is remote. + (let ((default-directory (tramp-compat-temporary-file-directory))) + (when (file-readable-p filename) + (with-temp-buffer + (insert-file-contents filename) + (goto-char (point-min)) + (loop while (not (eobp)) collect (funcall function)))))) + ;;;###tramp-autoload (defun tramp-parse-rhosts (filename) "Return a list of (user host) tuples allowed to access. Either user or host may be nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (when (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-rhosts-group) res)))) - res)) + (tramp-parse-file filename 'tramp-parse-rhosts-group)) (defun tramp-parse-rhosts-group () "Return a (user host) tuple allowed to access. @@ -2427,10 +2495,8 @@ (concat "^\\(" tramp-host-regexp "\\)" "\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) + (when (re-search-forward regexp (point-at-eol) t) (setq result (append (list (match-string 3) (match-string 1))))) - (widen) (forward-line 1) result)) @@ -2438,124 +2504,63 @@ (defun tramp-parse-shosts (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (when (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-shosts-group) res)))) - res)) + (tramp-parse-file filename 'tramp-parse-shosts-group)) (defun tramp-parse-shosts-group () "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) - (regexp (concat "^\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) - (setq result (list nil (match-string 1)))) - (widen) - (or - (> (skip-chars-forward ",") 0) - (forward-line 1)) - result)) + (tramp-parse-group (concat "^\\(" tramp-host-regexp "\\)") 1 ",")) ;;;###tramp-autoload (defun tramp-parse-sconfig (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (when (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-sconfig-group) res)))) - res)) + (tramp-parse-file filename 'tramp-parse-sconfig-group)) (defun tramp-parse-sconfig-group () "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) - (regexp (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) - (setq result (list nil (match-string 1)))) - (widen) - (or - (> (skip-chars-forward ",") 0) - (forward-line 1)) - result)) + (tramp-parse-group + (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)") 1 ",")) + +;; Generic function. +(defun tramp-parse-shostkeys-sknownhosts (dirname regexp) + "Return a list of (user host) tuples allowed to access. +User is always nil." + ;; On Windows, there are problems in completion when + ;; `default-directory' is remote. + (let* ((default-directory (tramp-compat-temporary-file-directory)) + (files (and (file-directory-p dirname) (directory-files dirname)))) + (loop for f in files + when (and (not (string-match "^\\.\\.?$" f)) (string-match regexp f)) + collect (list nil (match-string 1 f))))) ;;;###tramp-autoload (defun tramp-parse-shostkeys (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let* ((default-directory (tramp-compat-temporary-file-directory)) - (regexp (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$")) - (files (when (file-directory-p dirname) (directory-files dirname))) - result) - (while files - (when (string-match regexp (car files)) - (push (list nil (match-string 1 (car files))) result)) - (setq files (cdr files))) - result)) + (tramp-parse-shostkeys-sknownhosts + dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) +;;;###tramp-autoload (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let* ((default-directory (tramp-compat-temporary-file-directory)) - (regexp (concat "^\\(" tramp-host-regexp - "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$")) - (files (when (file-directory-p dirname) (directory-files dirname))) - result) - (while files - (when (string-match regexp (car files)) - (push (list nil (match-string 1 (car files))) result)) - (setq files (cdr files))) - result)) + (tramp-parse-shostkeys-sknownhosts + dirname + (concat "^\\(" tramp-host-regexp "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$"))) ;;;###tramp-autoload (defun tramp-parse-hosts (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (when (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-hosts-group) res)))) - res)) + (tramp-parse-file filename 'tramp-parse-hosts-group)) (defun tramp-parse-hosts-group () "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) - (regexp - (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) - (setq result (list nil (match-string 1)))) - (widen) - (or - (> (skip-chars-forward " \t") 0) - (forward-line 1)) - result)) + (tramp-parse-group + (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)") 1 " \t")) ;; For su-alike methods it would be desirable to return "root@localhost" ;; as default. Unfortunately, we have no information whether any user name @@ -2565,29 +2570,17 @@ (defun tramp-parse-passwd (filename) "Return a list of (user host) tuples allowed to access. Host is always \"localhost\"." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (if (zerop (length tramp-current-user)) - '(("root" nil)) - (when (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-passwd-group) res)))) - res))) + (if (zerop (length tramp-current-user)) + '(("root" nil)) + (tramp-parse-file filename 'tramp-parse-passwd-group))) (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. Host is always \"localhost\"." (let ((result) (regexp (concat "^\\(" tramp-user-regexp "\\):"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) + (when (re-search-forward regexp (point-at-eol) t) (setq result (list (match-string 1) "localhost"))) - (widen) (forward-line 1) result)) @@ -2595,17 +2588,7 @@ (defun tramp-parse-netrc (filename) "Return a list of (user host) tuples allowed to access. User may be nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (when (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-netrc-group) res)))) - res)) + (tramp-parse-file filename 'tramp-parse-netrc-group)) (defun tramp-parse-netrc-group () "Return a (user host) tuple allowed to access. @@ -2615,37 +2598,33 @@ (concat "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) + (when (re-search-forward regexp (point-at-eol) t) (setq result (list (match-string 3) (match-string 1)))) - (widen) (forward-line 1) result)) ;;;###tramp-autoload -(defun tramp-parse-putty (registry) +(defun tramp-parse-putty (registry-or-dirname) "Return a list of (user host) tuples allowed to access. User is always nil." - ;; On Windows, there are problems in completion when - ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory)) - res) - (with-temp-buffer - (when (zerop (tramp-compat-call-process "reg" nil t nil "query" registry)) - (goto-char (point-min)) - (while (not (eobp)) - (push (tramp-parse-putty-group registry) res)))) - res)) + (if (memq system-type '(windows-nt)) + (with-temp-buffer + (when (zerop (tramp-compat-call-process + "reg" nil t nil "query" registry-or-dirname)) + (goto-char (point-min)) + (loop while (not (eobp)) collect + (tramp-parse-putty-group registry-or-dirname)))) + ;; UNIX case. + (tramp-parse-shostkeys-sknownhosts + registry-or-dirname (concat "^\\(" tramp-host-regexp "\\)$")))) (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." (let ((result) (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) - (narrow-to-region (point) (point-at-eol)) - (when (re-search-forward regexp nil t) + (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string 1)))) - (widen) (forward-line 1) result)) @@ -2855,78 +2834,80 @@ (setq filename (expand-file-name filename)) (let (result local-copy remote-copy) (with-parsed-tramp-file-name filename nil - (unwind-protect - (if (not (file-exists-p filename)) - ;; We don't raise a Tramp error, because it might be - ;; suppressed, like in `find-file-noselect-1'. - (signal 'file-error - (list "File not found on remote host" filename)) - - (if (and (tramp-local-host-p v) - (let (file-name-handler-alist) - (file-readable-p localname))) - ;; Short track: if we are on the local host, we can - ;; run directly. - (setq result - (tramp-run-real-handler - 'insert-file-contents - (list localname visit beg end replace))) - - ;; When we shall insert only a part of the file, we copy - ;; this part. - (when (or beg end) - (setq remote-copy (tramp-make-tramp-temp-file v)) - ;; This is defined in tramp-sh.el. Let's assume this - ;; is loaded already. - (tramp-compat-funcall 'tramp-send-command - v - (cond - ((and beg end) - (format "dd bs=1 skip=%d if=%s count=%d of=%s" - beg (tramp-shell-quote-argument localname) - (- end beg) remote-copy)) - (beg - (format "dd bs=1 skip=%d if=%s of=%s" - beg (tramp-shell-quote-argument localname) - remote-copy)) - (end - (format "dd bs=1 count=%d if=%s of=%s" - end (tramp-shell-quote-argument localname) - remote-copy))))) - - ;; `insert-file-contents-literally' takes care to avoid - ;; calling jka-compr. By let-binding - ;; `inhibit-file-name-operation', we propagate that care - ;; to the `file-local-copy' operation. - (setq local-copy - (let ((inhibit-file-name-operation - (when (eq inhibit-file-name-operation - 'insert-file-contents) - 'file-local-copy))) - (cond - ((stringp remote-copy) - (file-local-copy - (tramp-make-tramp-file-name - method user host remote-copy))) - ((stringp tramp-temp-buffer-file-name) - (copy-file filename tramp-temp-buffer-file-name 'ok) - tramp-temp-buffer-file-name) - (t (file-local-copy filename))))) - - ;; When the file is not readable for the owner, it - ;; cannot be inserted, even if it is readable for the - ;; group or for everybody. - (set-file-modes local-copy (tramp-compat-octal-to-decimal "0600")) - - (when (and (null remote-copy) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - ;; We keep the local file for performance reasons, - ;; useful for "rsync". - (setq tramp-temp-buffer-file-name local-copy)) - - (tramp-with-progress-reporter - v 3 (format "Inserting local temp file `%s'" local-copy) + (tramp-with-progress-reporter + v 3 (format "Inserting `%s'" filename) + (unwind-protect + (if (not (file-exists-p filename)) + ;; We don't raise a Tramp error, because it might be + ;; suppressed, like in `find-file-noselect-1'. + (signal 'file-error + (list "File not found on remote host" filename)) + + (if (and (tramp-local-host-p v) + (let (file-name-handler-alist) + (file-readable-p localname))) + ;; Short track: if we are on the local host, we can + ;; run directly. + (setq result + (tramp-run-real-handler + 'insert-file-contents + (list localname visit beg end replace))) + + ;; When we shall insert only a part of the file, we + ;; copy this part. + (when (or beg end) + (setq remote-copy (tramp-make-tramp-temp-file v)) + ;; This is defined in tramp-sh.el. Let's assume + ;; this is loaded already. + (tramp-compat-funcall + 'tramp-send-command + v + (cond + ((and beg end) + (format "dd bs=1 skip=%d if=%s count=%d of=%s" + beg (tramp-shell-quote-argument localname) + (- end beg) remote-copy)) + (beg + (format "dd bs=1 skip=%d if=%s of=%s" + beg (tramp-shell-quote-argument localname) + remote-copy)) + (end + (format "dd bs=1 count=%d if=%s of=%s" + end (tramp-shell-quote-argument localname) + remote-copy))))) + + ;; `insert-file-contents-literally' takes care to + ;; avoid calling jka-compr. By let-binding + ;; `inhibit-file-name-operation', we propagate that + ;; care to the `file-local-copy' operation. + (setq local-copy + (let ((inhibit-file-name-operation + (when (eq inhibit-file-name-operation + 'insert-file-contents) + 'file-local-copy))) + (cond + ((stringp remote-copy) + (file-local-copy + (tramp-make-tramp-file-name + method user host remote-copy))) + ((stringp tramp-temp-buffer-file-name) + (copy-file filename tramp-temp-buffer-file-name 'ok) + tramp-temp-buffer-file-name) + (t (file-local-copy filename))))) + + ;; When the file is not readable for the owner, it + ;; cannot be inserted, even if it is readable for the + ;; group or for everybody. + (set-file-modes + local-copy (tramp-compat-octal-to-decimal "0600")) + + (when (and (null remote-copy) + (tramp-get-method-parameter + method 'tramp-copy-keep-tmpfile)) + ;; We keep the local file for performance reasons, + ;; useful for "rsync". + (setq tramp-temp-buffer-file-name local-copy)) + ;; We must ensure that `file-coding-system-alist' ;; matches `local-copy'. (let ((file-coding-system-alist @@ -2934,21 +2915,21 @@ filename local-copy))) (setq result (insert-file-contents - local-copy nil nil nil replace)))))) + local-copy nil nil nil replace))))) - ;; Save exit. - (progn - (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (when (and (stringp local-copy) - (or remote-copy (null tramp-temp-buffer-file-name))) - (delete-file local-copy)) - (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name method user host remote-copy)))))) + ;; Save exit. + (progn + (when visit + (setq buffer-file-name filename) + (setq buffer-read-only (not (file-writable-p filename))) + (set-visited-file-modtime) + (set-buffer-modified-p nil)) + (when (and (stringp local-copy) + (or remote-copy (null tramp-temp-buffer-file-name))) + (delete-file local-copy)) + (when (stringp remote-copy) + (delete-file + (tramp-make-tramp-file-name method user host remote-copy))))))) ;; Result. (list (expand-file-name filename) @@ -3136,7 +3117,10 @@ (let ((enable-recursive-minibuffers t)) (tramp-check-for-regexp proc tramp-password-prompt-regexp) (tramp-message vec 3 "Sending %s" (match-string 1)) - (tramp-enter-password proc) + ;; We don't call `tramp-send-string' in order to hide the + ;; password from the debug buffer. + (process-send-string + proc (concat (tramp-read-passwd proc) tramp-local-end-of-line)) ;; Hide password prompt. (narrow-to-region (point-max) (point-max))))) @@ -3240,7 +3224,7 @@ connection buffer." ;; Preserve message for `progress-reporter'. (tramp-compat-with-temp-message "" - ;; Enable auth-source and password-cache. We must use + ;; Enable `auth-source' and `password-cache'. We must use ;; tramp-current-* variables in case we have several hops. (tramp-set-connection-property (tramp-dissect-file-name @@ -3315,14 +3299,12 @@ 'buffer-substring-no-properties 1 (min (1+ tramp-echo-mark-marker-length) (point-max)))))) ;; No echo to be handled, now we can look for the regexp. - ;; Sometimes, the buffer is much to huge, and we run into a - ;; "Stack overflow in regexp matcher". For example, directory - ;; listings with some thousand files. Therefore, we look from - ;; the end for the last line. We ignore also superlong lines, - ;; like created with "//DIRED//". + ;; Sometimes, lines are much to long, and we run into a "Stack + ;; overflow in regexp matcher". For example, //DIRED// lines of + ;; directory listings with some thousand files. Therefore, we + ;; look from the end. (goto-char (point-max)) - (unless (> (- (point) (point-at-bol)) 128) - (re-search-backward regexp (point-at-bol) t))))) + (ignore-errors (re-search-backward regexp nil t))))) (defun tramp-wait-for-regexp (proc timeout regexp) "Wait for a REGEXP to appear from process PROC within TIMEOUT seconds. @@ -3362,18 +3344,6 @@ (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) found))) -;; We don't call `tramp-send-string' in order to hide the password -;; from the debug buffer, and because end-of-line handling of the -;; string. -(defun tramp-enter-password (proc) - "Prompt for a password and send it to the remote end." - (process-send-string - proc (concat (tramp-read-passwd proc) - (or (tramp-get-method-parameter - tramp-current-method - 'tramp-password-end-of-line) - tramp-default-password-end-of-line)))) - ;; It seems that Tru64 Unix does not like it if long strings are sent ;; to it in one go. (This happens when sending the Perl ;; `file-attributes' implementation, for instance.) Therefore, we @@ -3446,12 +3416,7 @@ (stringp (file-remote-p file2)) (string-equal (file-remote-p file1) (file-remote-p file2)))) -(defun tramp-get-method-parameter (method param) - "Return the method parameter PARAM. -If the `tramp-methods' entry does not exist, return nil." - (let ((entry (assoc param (assoc method tramp-methods)))) - (when entry (cadr entry)))) - +;;;###tramp-autoload (defun tramp-mode-string-to-int (mode-string) "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." (let* (case-fold-search @@ -3523,6 +3488,7 @@ (t (error "Tenth char `%c' must be one of `xtT-'" other-execute-or-sticky))))))) +;;;###tramp-autoload (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise." ;; We cannot use `tramp-file-name-real-host'. A port is an @@ -3564,6 +3530,7 @@ dir (tramp-error vec 'file-error "Directory %s not accessible" dir))))) +;;;###tramp-autoload (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." @@ -3658,6 +3625,7 @@ ;;; Compatibility functions section: +;;;###tramp-autoload (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. @@ -3708,6 +3676,7 @@ (read-passwd pw-prompt)) (tramp-set-connection-property v "first-password-request" nil))))) +;;;###tramp-autoload (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (tramp-compat-funcall @@ -3730,6 +3699,7 @@ ("oct" . 10) ("nov" . 11) ("dec" . 12)) "Alist mapping month names to integers.") +;;;###tramp-autoload (defun tramp-time-less-p (t1 t2) "Say whether time value T1 is less than time value T2." (unless t1 (setq t1 '(0 0))) @@ -3747,6 +3717,7 @@ (list (- (car t1) (car t2) (if borrow 1 0)) (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) +;;;###tramp-autoload (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." @@ -3841,8 +3812,6 @@ ;; again. (Greg Stark) ;; * Username and hostname completion. ;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode-p'. -;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'. -;; Code is nearly identical. ;; * Make `tramp-default-user' obsolete. ;; * Implement a general server-local-variable mechanism, as there are ;; probably other variables that need different values for different === modified file 'lisp/net/trampver.el' --- lisp/net/trampver.el 2012-01-19 07:21:25 +0000 +++ lisp/net/trampver.el 2012-06-11 10:30:07 +0000 @@ -31,7 +31,7 @@ ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.2.3-24.1" +(defconst tramp-version "2.2.6-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -44,7 +44,7 @@ (= emacs-major-version 21) (>= emacs-minor-version 4))) "ok" - (format "Tramp 2.2.3-24.1 is not fit for %s" + (format "Tramp 2.2.6-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) ------------------------------------------------------------ revno: 108554 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-06-11 18:16:47 +0800 message: Give ImageMagick lowest priority in image-type-file-name-regexps. * lisp/image.el (imagemagick-register-types): Put the ImageMagick entry at the end of image-type-file-name-regexps. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 00:46:21 +0000 +++ lisp/ChangeLog 2012-06-11 10:16:47 +0000 @@ -1,3 +1,8 @@ +2012-06-11 Chong Yidong + + * image.el (imagemagick-register-types): Put the ImageMagick entry + at the end of image-type-file-name-regexps. + 2012-06-11 Johan Bockgård * emacs-lisp/pcase.el (pcase-UPAT, pcase-QPAT): New edebug specs. === modified file 'lisp/image.el' --- lisp/image.el 2012-06-04 13:02:23 +0000 +++ lisp/image.el 2012-06-11 10:16:47 +0000 @@ -747,7 +747,10 @@ (push (cons re 'image-mode) auto-mode-alist)) (if itfnr-elt (setcar itfnr-elt re) - (push (cons re 'imagemagick) image-type-file-name-regexps))) + ;; Append to `image-type-file-name-regexps', so that we + ;; preferentially use specialized image libraries. + (add-to-list 'image-type-file-name-regexps + (cons re 'imagemagick) t))) (setq imagemagick--file-regexp re)))) (defcustom imagemagick-types-inhibit ------------------------------------------------------------ revno: 108553 author: Johan Bockgård committer: Stefan Monnier branch nick: trunk timestamp: Sun 2012-06-10 20:46:21 -0400 message: * lisp/emacs-lisp/pcase.el (pcase-UPAT, pcase-QPAT): New edebug specs. (pcase, pcase-let*, pcase-dolist): Use them. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-11 00:33:33 +0000 +++ lisp/ChangeLog 2012-06-11 00:46:21 +0000 @@ -1,3 +1,8 @@ +2012-06-11 Johan Bockgård + + * emacs-lisp/pcase.el (pcase-UPAT, pcase-QPAT): New edebug specs. + (pcase, pcase-let*, pcase-dolist): Use them. + 2012-06-11 Stefan Monnier * emacs-lisp/pcase.el (pcase--let*): New function. === modified file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 2012-06-11 00:33:33 +0000 +++ lisp/emacs-lisp/pcase.el 2012-06-11 00:46:21 +0000 @@ -66,6 +66,27 @@ (defconst pcase--dontcare-upats '(t _ dontcare)) +(def-edebug-spec + pcase-UPAT + (&or symbolp + ("or" &rest pcase-UPAT) + ("and" &rest pcase-UPAT) + ("`" pcase-QPAT) + ("guard" form) + ("let" pcase-UPAT form) + ("pred" + &or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) + sexp) + sexp)) + +(def-edebug-spec + pcase-QPAT + (&or ("," pcase-UPAT) + (pcase-QPAT . pcase-QPAT) + sexp)) + ;;;###autoload (defmacro pcase (exp &rest cases) "Perform ML-style pattern matching on EXP. @@ -98,7 +119,7 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" - (declare (indent 1) (debug cl-case)) ;FIXME: edebug `guard' and vars. + (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time ;; we're called so it'll be immediately GC'd. So we use (car cases) as key @@ -144,7 +165,7 @@ BODY should be an expression, and BINDINGS should be a list of bindings of the form (UPAT EXP)." (declare (indent 1) - (debug ((&rest (sexp &optional form)) body))) + (debug ((&rest (pcase-UPAT &optional form)) body))) (let ((cached (gethash bindings pcase--memoize))) ;; cached = (BODY . EXPANSION) (if (equal (car cached) body) @@ -174,7 +195,7 @@ `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) (defmacro pcase-dolist (spec &rest body) - (declare (indent 1)) + (declare (indent 1) (debug ((pcase-UPAT form) body))) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) (let ((tmpvar (make-symbol "x")))