commit d282d6a59590c43d6c50c097c233325c17ea4f0c (HEAD, refs/remotes/origin/master) Author: Wilson Snyder Date: Mon Dec 8 23:14:30 2014 -0800 Sync with upstream verilog-mode revision aa4b777 * lisp/progmodes/verilog-mode.el (verilog-mode-version): Update. (verilog-auto-end-comment-lines-re, verilog-end-block-ordered-re) (verilog-set-auto-endcomments): Automatically comment property/ endproperty blocks to match other similar blocks like sequence/ endsequence, function/endfunction, etc. Reported by Alex Reed. (verilog-set-auto-endcomments): Fix end comments for functions of type void, etc. Detect the function- or task-name when auto-commenting blocks that lack an explicit portlist. Reported by Alex Reed. (verilog-nameable-item-re): Fix nameable items that can have an end-identifier to include endchecker, endgroup, endprogram, endproperty, and endsequence. Reported by Alex Reed. (verilog-preprocessor-re, verilog-beg-of-statement): Fix indentation of property/endproperty around pre-processor directives. Reported by Alex Reed. (verilog-label-be): When auto-commenting a buffer, consider auto-comments on all known keywords (not just a subset thereof). Reported by Alex Reed. (verilog-beg-of-statement): Fix labeling do-while blocks, bug842. Reported by Alex Reed. (verilog-beg-of-statement-1, verilog-at-constraint-p): Fix hanging with many curly-bracket pairs, bug663. (verilog-do-indent): Fix electric tab deleting form-feeds. Note caused by indent-line-to deleting tabls pre 24.5. (verilog-auto-output, verilog-auto-input, verilog-auto-inout) (verilog-auto-inout-module, verilog-auto-inout-in): Doc fixes. (verilog-read-always-signals, verilog-auto-sense-sigs) (verilog-auto-reset): Fix AUTORESET with always_comb and always_latch, bug844. Reported by Greg Hilton. Author: Alex Reed (tiny change) * lisp/progmodes/verilog-mode.el (verilog-no-indent-begin-re): Fix `verilog-indent-begin-after-if' nil not honoring 'forever', 'foreach', and 'do' keywords. (verilog-endcomment-reason-re, verilog-beg-of-statement): Fix labeling do-while blocks, bug842. (verilog-backward-token): Fix indenting sensitivity lists with named events, bug840. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 4fa27b6..81afe8a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,46 @@ +2014-12-09 Wilson Snyder + + Sync with upstream verilog-mode revision aa4b777. + * progmodes/verilog-mode.el (verilog-mode-version): Update. + (verilog-auto-end-comment-lines-re, verilog-end-block-ordered-re) + (verilog-set-auto-endcomments): Automatically comment property/ + endproperty blocks to match other similar blocks like sequence/ + endsequence, function/endfunction, etc. Reported by Alex Reed. + (verilog-set-auto-endcomments): Fix end comments for functions of + type void, etc. Detect the function- or task-name when + auto-commenting blocks that lack an explicit portlist. + Reported by Alex Reed. + (verilog-nameable-item-re): Fix nameable items that can have an + end-identifier to include endchecker, endgroup, endprogram, + endproperty, and endsequence. Reported by Alex Reed. + (verilog-preprocessor-re, verilog-beg-of-statement): + Fix indentation of property/endproperty around pre-processor + directives. Reported by Alex Reed. + (verilog-label-be): When auto-commenting a buffer, consider + auto-comments on all known keywords (not just a subset thereof). + Reported by Alex Reed. + (verilog-beg-of-statement): Fix labeling do-while blocks, bug842. + Reported by Alex Reed. + (verilog-beg-of-statement-1, verilog-at-constraint-p): + Fix hanging with many curly-bracket pairs, bug663. + (verilog-do-indent): Fix electric tab deleting form-feeds. + Note caused by indent-line-to deleting tabls pre 24.5. + (verilog-auto-output, verilog-auto-input, verilog-auto-inout) + (verilog-auto-inout-module, verilog-auto-inout-in): Doc fixes. + (verilog-read-always-signals, verilog-auto-sense-sigs) + (verilog-auto-reset): Fix AUTORESET with always_comb and always_latch, + bug844. Reported by Greg Hilton. + +2014-12-09 Alex Reed (tiny change) + + * progmodes/verilog-mode.el (verilog-no-indent-begin-re): + Fix `verilog-indent-begin-after-if' nil not honoring 'forever', + 'foreach', and 'do' keywords. + (verilog-endcomment-reason-re, verilog-beg-of-statement): + Fix labeling do-while blocks, bug842. + (verilog-backward-token): Fix indenting sensitivity lists with + named events, bug840. + 2014-12-09 Reto Zimmermann Sync with upstream vhdl mode v3.36.1. diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 71af582..a7d833c 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -123,7 +123,7 @@ ;;; Code: ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2014-10-03-c075a49-vpo" +(defconst verilog-mode-version "2014-11-12-aa4b777-vpo" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -2269,8 +2269,9 @@ find the errors." (defconst verilog-no-indent-begin-re (eval-when-compile (verilog-regexp-words - '( "if" "else" "while" "for" "repeat" "always" "always_comb" "always_ff" "always_latch" - "initial" "final")))) + '("always" "always_comb" "always_ff" "always_latch" "initial" "final" ;; procedural blocks + "if" "else" ;; conditional statements + "while" "for" "foreach" "repeat" "do" "forever" )))) ;; loop statements (defconst verilog-ends-re ;; Parenthesis indicate type of keyword found @@ -2328,6 +2329,7 @@ find the errors." "endinterface" "endpackage" "endsequence" + "endproperty" "endspecify" "endtable" "endtask" @@ -2360,6 +2362,7 @@ find the errors." "\\(program\\)\\|" ; 13 "\\(sequence\\)\\|" ; 14 "\\(clocking\\)\\|" ; 15 + "\\(property\\)\\|" ; 16 "\\)\\>\\)")) (defconst verilog-end-block-re (eval-when-compile @@ -2424,7 +2427,7 @@ find the errors." "\\(\\\\)\\|" "\\(\\\\)\\|" "\\(@\\)\\|" - "\\(\\\\)\\|" + "\\(\\\\)\\|\\(\\\\)\\|" "\\(\\\\)\\|" "\\(\\\\)\\|\\(\\\\)\\|" "#")) @@ -2518,15 +2521,20 @@ find the errors." "join" "join_any" "join_none" "end" "endcase" - "endconfig" + "endchecker" "endclass" "endclocking" + "endconfig" "endfunction" "endgenerate" + "endgroup" "endmodule" "endprimitive" "endinterface" "endpackage" + "endprogram" + "endproperty" + "endsequence" "endspecify" "endtable" "endtask" ) @@ -2756,10 +2764,45 @@ find the errors." "String used to mark end of excluded text.") (defconst verilog-preprocessor-re (eval-when-compile - (verilog-regexp-words - `( - "`define" "`include" "`ifdef" "`ifndef" "`if" "`endif" "`else" - )))) + (concat + ;; single words + "\\(?:" + (verilog-regexp-words + `("`__FILE__" + "`__LINE__" + "`celldefine" + "`else" + "`end_keywords" + "`endcelldefine" + "`endif" + "`nounconnected_drive" + "`resetall" + "`unconnected_drive" + "`undefineall")) + "\\)\\|\\(?:" + ;; two words: i.e. `ifdef DEFINE + "\\<\\(`elsif\\|`ifn?def\\|`undef\\|`default_nettype\\|`begin_keywords\\)\\>\\s-" + "\\)\\|\\(?:" + ;; `line number "filename" level + "\\<\\(`line\\)\\>\\s-+[0-9]+\\s-+\"[^\"]+\"\\s-+[012]" + "\\)\\|\\(?:" + ;;`include "file" or `include + "\\<\\(`include\\)\\>\\s-+\\(?:\"[^\"]+\"\\|<[^>]+>\\)" + "\\)\\|\\(?:" + ;; `pragma (no mention in IEEE 1800-2012 that pragma can span multiple lines + "\\<\\(`pragma\\)\\>\\s-+.+$" + "\\)\\|\\(?:" + ;; `timescale time_unit / time_precision + "\\<\\(`timescale\\)\\>\\s-+10\\{0,2\\}\\s-*[munpf]?s\\s-*\\/\\s-*10\\{0,2\\}\\s-*[munpf]?s" + "\\)\\|\\(?:" + ;; `define and `if can span multiple lines if line ends in '\'. NOTE: `if is not IEEE 1800-2012 + ;; from http://www.emacswiki.org/emacs/MultilineRegexp + (concat "\\<\\(`define\\|`if\\)\\>" ;; directive + "\\s-+" ;; separator + "\\(.*\\(?:\n.*\\)*?\\)" ;; definition: to tend of line, the maybe more lines (excludes any trailing \n) + "\\(?:\n\\s-*\n\\|\\'\\)") ;; blank line or EOF + "\\)" + ))) (defconst verilog-keywords '( "`case" "`default" "`define" "`else" "`endfor" "`endif" @@ -4126,9 +4169,7 @@ Uses `verilog-scan' cache." (while (and (> (marker-position e) (point)) (verilog-re-search-forward - (concat - "\\" - "\\|\\(`endif\\)\\|\\(`else\\)") + verilog-auto-end-comment-lines-re nil 'move)) (goto-char (match-beginning 0)) (let ((indent-str (verilog-indent-line))) @@ -4157,45 +4198,47 @@ Uses `verilog-scan' cache." ;; or the token before us unambiguously ends a statement, ;; then move back a token and test again. (not (or - ;; stop if beginning of buffer - (bolp) - ;; stop if we find a ; + ;; stop if beginning of buffer + (bobp) + ;; stop if we find a ; (= (preceding-char) ?\;) - ;; stop if we see a named coverpoint + ;; stop if we see a named coverpoint (looking-at "\\w+\\W*:\\W*\\(coverpoint\\|cross\\|constraint\\)") - ;; keep going if we are in the middle of a word + ;; keep going if we are in the middle of a word (not (or (looking-at "\\<") (forward-word -1))) - ;; stop if we see an assertion (perhaps labeled) + ;; stop if we see an assertion (perhaps labeled) (and (looking-at "\\(\\<\\(assert\\|assume\\|cover\\)\\>\\s-+\\\\)\\|\\(\\\\)") (progn - (setq h (point)) - (save-excursion - (verilog-backward-token) - (if (looking-at verilog-label-re) - (setq h (point)))) - (goto-char h))) - ;; stop if we see an extended complete reg, perhaps a complete one + (setq h (point)) + (save-excursion + (verilog-backward-token) + (if (looking-at verilog-label-re) + (setq h (point)))) + (goto-char h))) + ;; stop if we see an extended complete reg, perhaps a complete one (and - (looking-at verilog-complete-reg) - (let* ((p (point))) - (while (and (looking-at verilog-extended-complete-re) - (progn (setq p (point)) - (verilog-backward-token) - (/= p (point))))) - (goto-char p))) - ;; stop if we see a complete reg (previous found extended ones) + (looking-at verilog-complete-reg) + (let* ((p (point))) + (while (and (looking-at verilog-extended-complete-re) + (progn (setq p (point)) + (verilog-backward-token) + (/= p (point))))) + (goto-char p))) + ;; stop if we see a complete reg (previous found extended ones) (looking-at verilog-basic-complete-re) - ;; stop if previous token is an ender + ;; stop if previous token is an ender (save-excursion - (verilog-backward-token) - (or - (looking-at verilog-end-block-re) - (looking-at verilog-preprocessor-re))))) ;; end of test - (verilog-backward-syntactic-ws) - (verilog-backward-token)) + (verilog-backward-token) + (looking-at verilog-end-block-re)))) + (verilog-backward-syntactic-ws) + (verilog-backward-token)) ;; Now point is where the previous line ended. - (verilog-forward-syntactic-ws))) + (verilog-forward-syntactic-ws) + ;; Skip forward over any preprocessor directives, as they have wacky indentation + (if (looking-at verilog-preprocessor-re) + (progn (goto-char (match-end 0)) + (verilog-forward-syntactic-ws))))) (defun verilog-beg-of-statement-1 () "Move backward to beginning of statement." @@ -4209,13 +4252,12 @@ Uses `verilog-scan' cache." (verilog-backward-syntactic-ws) (if (or (bolp) (= (preceding-char) ?\;) - (save-excursion + (progn (verilog-backward-token) (looking-at verilog-ends-re))) (progn (goto-char pt) - (throw 'done t)) - (verilog-backward-token)))) + (throw 'done t))))) (verilog-forward-syntactic-ws))) ; ; (while (and @@ -4773,10 +4815,10 @@ primitive or interface named NAME." (cond ((match-end 5) ;; of verilog-end-block-ordered-re (setq reg "\\(\\\\)\\|\\(\\<\\(endfunction\\|task\\|\\(macro\\)?module\\|primitive\\)\\>\\)") - (setq name-re "\\w+\\s-*(")) + (setq name-re "\\w+\\(?:\n\\|\\s-\\)*[(;]")) ((match-end 6) ;; of verilog-end-block-ordered-re (setq reg "\\(\\\\)\\|\\(\\<\\(endtask\\|function\\|\\(macro\\)?module\\|primitive\\)\\>\\)") - (setq name-re "\\w+\\s-*(")) + (setq name-re "\\w+\\(?:\n\\|\\s-\\)*[(;]")) ((match-end 7) ;; of verilog-end-block-ordered-re (setq reg "\\(\\<\\(macro\\)?module\\>\\)\\|\\")) ((match-end 8) ;; of verilog-end-block-ordered-re @@ -4795,6 +4837,8 @@ primitive or interface named NAME." (setq reg "\\(\\<\\(rand\\)?sequence\\>\\)\\|\\(\\<\\(endsequence\\|primitive\\|interface\\|\\(macro\\)?module\\)\\>\\)")) ((match-end 15) ;; of verilog-end-block-ordered-re (setq reg "\\(\\\\)\\|\\")) + ((match-end 16) ;; of verilog-end-block-ordered-re + (setq reg "\\(\\\\)\\|\\")) (t (error "Problem in verilog-set-auto-endcomments"))) (let (b e) @@ -5849,7 +5893,9 @@ Set point to where line starts." (;-- any of begin|initial|while are complete statements; 'begin : foo' is also complete t (forward-word -1) - (while (= (preceding-char) ?\_) + (while (or (= (preceding-char) ?\_) + (= (preceding-char) ?\@) + (= (preceding-char) ?\.)) (forward-word -1)) (cond ((looking-at "\\") @@ -6103,14 +6149,18 @@ Return >0 for nested struct." (defun verilog-at-constraint-p () "If at the { of a constraint or coverpoint definition, return true, moving point to constraint." (if (save-excursion + (let ((p (point))) (and (equal (char-after) ?\{) (forward-list) (progn (backward-char 1) (verilog-backward-ws&directives) + (and (or (equal (char-before) ?\{) ;; empty case (equal (char-before) ?\;) - (equal (char-before) ?\}))))) + (equal (char-before) ?\})) + ;; skip what looks like bus repitition operator {#{ + (not (string-match "^{\\s-*[0-9]+\\s-*{" (buffer-substring p (point))))))))) (progn (let ( (pt (point)) (pass 0)) (verilog-backward-ws&directives) @@ -6429,6 +6479,9 @@ Only look at a few lines to determine indent level." (looking-at verilog-declaration-re)) (verilog-indent-declaration ind)) + (;-- form feeds - ignored as bug in indent-line-to in < 24.5 + (looking-at "\f")) + (;-- Everything else t (let ((val (eval (cdr (assoc type verilog-indent-alist))))) @@ -8894,7 +8947,6 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement." (save-excursion (let* (;;(dbg "") sigs-out-d sigs-out-i sigs-out-unk sigs-temp sigs-in) - (search-forward ")") (verilog-read-always-signals-recurse nil nil nil) (setq sigs-out-i (append sigs-out-i sigs-out-unk) sigs-out-unk nil) @@ -11731,6 +11783,9 @@ Limitations: Typedefs must match `verilog-typedef-regexp', which is disabled by default. + Types are added to declarations if an AUTOLOGIC or + `verilog-auto-wire-type' is set to logic. + Signals matching `verilog-auto-output-ignore-regexp' are not included. An example (see `verilog-auto-inst' for what else is going on here): @@ -11872,6 +11927,9 @@ Limitations: Typedefs must match `verilog-typedef-regexp', which is disabled by default. + Types are added to declarations if an AUTOLOGIC or + `verilog-auto-wire-type' is set to logic. + Signals matching `verilog-auto-input-ignore-regexp' are not included. An example (see `verilog-auto-inst' for what else is going on here): @@ -11952,6 +12010,9 @@ Limitations: Typedefs must match `verilog-typedef-regexp', which is disabled by default. + Types are added to declarations if an AUTOLOGIC or + `verilog-auto-wire-type' is set to logic. + Signals matching `verilog-auto-inout-ignore-regexp' are not included. An example (see `verilog-auto-inst' for what else is going on here): @@ -12068,13 +12129,14 @@ same expansion will result from only extracting signals starting with i: /*AUTOINOUTMODULE(\"ExampMain\",\"^i\")*/ -You may also provide an optional second regular expression, in -which case only signals which have that pin direction and data -type will be included. This matches against everything before -the signal name in the declaration, for example against -\"input\" (single bit), \"output logic\" (direction and type) or -\"output [1:0]\" (direction and implicit type). You also -probably want to skip spaces in your regexp. +You may also provide an optional third argument regular +expression, in which case only signals which have that pin +direction and data type matching that regular expression will be +included. This matches against everything before the signal name +in the declaration, for example against \"input\" (single bit), +\"output logic\" (direction and type) or \"output +[1:0]\" (direction and implicit type). You also probably want to +skip spaces in your regexp. For example, the below will result in matching the output \"o\" against the previous example's module: @@ -12193,7 +12255,21 @@ You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/" + /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/ + +You may also provide an optional third argument regular +expression, in which case only signals which have that pin +direction and data type matching that regular expression will be +included. This matches against everything before the signal name +in the declaration, for example against \"input\" (single bit), +\"output logic\" (direction and type) or \"output +[1:0]\" (direction and implicit type). You also probably want to +skip spaces in your regexp. + +For example, the below will result in matching the output \"o\" +against the previous example's module: + + /*AUTOINOUTCOMP(\"ExampMain\",\"\",\"^output.*\")*/" (verilog-auto-inout-module t nil)) (defun verilog-auto-inout-in () @@ -12244,7 +12320,7 @@ You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/" + /*AUTOINOUTIN(\"ExampMain\",\"^i\")*/" (verilog-auto-inout-module nil t)) (defun verilog-auto-inout-param () @@ -12516,7 +12592,9 @@ See `verilog-auto-insert-lisp' for examples." (defun verilog-auto-sense-sigs (moddecls presense-sigs) "Return list of signals for current AUTOSENSE block." - (let* ((sigss (verilog-read-always-signals)) + (let* ((sigss (save-excursion + (search-forward ")") + (verilog-read-always-signals))) (sig-list (verilog-signals-not-params (verilog-signals-not-in (verilog-alw-get-inputs sigss) (append (and (not verilog-auto-sense-include-inputs) @@ -12706,11 +12784,12 @@ Typing \\[verilog-auto] will make this into: (save-excursion (verilog-read-signals (save-excursion - (verilog-re-search-backward-quick "\\(@\\|\\\\|\\\\|\\\\)" nil t) + (verilog-re-search-backward-quick + "\\(@\\|\\<\\(begin\\|if\\|case\\|always\\(_latch\\|_ff\\|_comb\\)?\\)\\>\\)" nil t) (point)) (point))))) (save-excursion - (verilog-re-search-backward-quick "@" nil t) + (verilog-re-search-backward-quick "\\(@\\|\\<\\(always\\(_latch\\|_ff\\|_comb\\)?\\)\\>\\)" nil t) (setq sigss (verilog-read-always-signals))) (setq dly-list (verilog-alw-get-outputs-delayed sigss)) (setq sig-list (verilog-signals-not-in (append commit fb0fcda82081774aee9a8b25540947c029b23ffc Author: Reto Zimmermann Date: Mon Dec 8 22:34:12 2014 -0800 Sync with upstream vhdl mode v3.36.1 * lisp/progmodes/vhdl-mode.el (vhdl-version, vhdl-time-stamp): Update. (vhdl-compiler-alist): Anchor all error regexps. (vhdl-compile-use-local-error-regexp): Change default to nil. (vhdl-asort, vhdl-anot-head-p): Remove. (vhdl-aput, vhdl-adelete, vhdl-aget): Simplify. Remove optional argument of vhdl-aget and update all callers. (vhdl-import-project): Also set `vhdl-compiler'. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9c044c3..4fa27b6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,14 @@ +2014-12-09 Reto Zimmermann + + Sync with upstream vhdl mode v3.36.1. + * progmodes/vhdl-mode.el (vhdl-version, vhdl-time-stamp): Update. + (vhdl-compiler-alist): Anchor all error regexps. + (vhdl-compile-use-local-error-regexp): Change default to nil. + (vhdl-asort, vhdl-anot-head-p): Remove. + (vhdl-aput, vhdl-adelete, vhdl-aget): Simplify. + Remove optional argument of vhdl-aget and update all callers. + (vhdl-import-project): Also set `vhdl-compiler'. + 2014-12-09 Lars Magne Ingebrigtsen * files.el (find-files): New function. diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 9f54b24..4d6b3b2 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -13,10 +13,10 @@ ;; filed in the Emacs bug reporting system against this file, a copy ;; of the bug report be sent to the maintainer's email address. -(defconst vhdl-version "3.35.2" +(defconst vhdl-version "3.36.1" "VHDL Mode version number.") -(defconst vhdl-time-stamp "2014-03-28" +(defconst vhdl-time-stamp "2014-11-27" "VHDL Mode time stamp for last update.") ;; This file is part of GNU Emacs. @@ -215,20 +215,20 @@ Overrides local variable `indent-tabs-mode'." ;; [Error] Assignment error: variable is illegal target of signal assignment ("ADVance MS" "vacom" "-work \\1" "make" "-f \\1" nil "valib \\1; vamap \\2 \\1" "./" "work/" "Makefile" "adms" - ("^\\s-+\\([0-9]+\\):\\s-+" nil 1 nil) ("Compiling file \\(.+\\)" 1) + ("^\\s-+\\([0-9]+\\):\\s-+" nil 1 nil) ("^Compiling file \\(.+\\)" 1) ("ENTI/\\1.vif" "ARCH/\\1-\\2.vif" "CONF/\\1.vif" "PACK/\\1.vif" "BODY/\\1.vif" upcase)) ;; Aldec ;; COMP96 ERROR COMP96_0018: "Identifier expected." "test.vhd" 66 3 ("Aldec" "vcom" "-work \\1" "make" "-f \\1" nil "vlib \\1; vmap \\2 \\1" "./" "work/" "Makefile" "aldec" - (".* ERROR [^:]+: \".*\" \"\\([^ \\t\\n]+\\)\" \\([0-9]+\\) \\([0-9]+\\)" 1 2 3) ("" 0) + ("^.* ERROR [^:]+: \".*\" \"\\([^ \t\n]+\\)\" \\([0-9]+\\) \\([0-9]+\\)" 1 2 3) ("" 0) nil) ;; Cadence Leapfrog: cv -file test.vhd ;; duluth: *E,430 (test.vhd,13): identifier (POSITIV) is not declared ("Cadence Leapfrog" "cv" "-work \\1 -file" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "leapfrog" - ("duluth: \\*E,[0-9]+ (\\([^ \\t\\n]+\\),\\([0-9]+\\)):" 1 2 nil) ("" 0) + ("^duluth: \\*E,[0-9]+ (\\([^ \t\n]+\\),\\([0-9]+\\)):" 1 2 nil) ("" 0) ("\\1/entity" "\\2/\\1" "\\1/configuration" "\\1/package" "\\1/body" downcase)) ;; Cadence Affirma NC vhdl: ncvhdl test.vhd @@ -236,27 +236,29 @@ Overrides local variable `indent-tabs-mode'." ;; (PLL_400X_TOP) is not declared [10.3]. ("Cadence NC" "ncvhdl" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "ncvhdl" - ("ncvhdl_p: \\*E,\\w+ (\\([^ \\t\\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) + ("^ncvhdl_p: \\*E,\\w+ (\\([^ \t\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) ("\\1/entity/pc.db" "\\2/\\1/pc.db" "\\1/configuration/pc.db" "\\1/package/pc.db" "\\1/body/pc.db" downcase)) - ;; ghdl vhdl: ghdl test.vhd + ;; ghdl vhdl + ;; ghdl -a bad_counter.vhdl + ;; bad_counter.vhdl:13:14: operator "=" is overloaded ("GHDL" "ghdl" "-i --workdir=\\1 --ieee=synopsys -fexplicit " "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "ghdl" - ("ghdl_p: \\*E,\\w+ (\\([^ \\t\\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) + ("^ghdl_p: \\*E,\\w+ (\\([^ \t\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) ("\\1/entity" "\\2/\\1" "\\1/configuration" "\\1/package" "\\1/body" downcase)) ;; IBM Compiler ;; 00 COACHDL* | [CCHDL-1]: File: adder.vhd, line.column: 120.6 ("IBM Compiler" "g2tvc" "-src" "precomp" "\\1" nil "mkdir \\1" "./" "work/" "Makefile" "ibm" - ("[0-9]+ COACHDL.*: File: \\([^ \\t\\n]+\\), line.column: \\([0-9]+\\).\\([0-9]+\\)" 1 2 3) (" " 0) + ("^[0-9]+ COACHDL.*: File: \\([^ \t\n]+\\), *line.column: \\([0-9]+\\).\\([0-9]+\\)" 1 2 3) (" " 0) nil) ;; Ikos Voyager: analyze test.vhd ;; analyze test.vhd ;; E L4/C5: this library unit is inaccessible ("Ikos" "analyze" "-l \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "ikos" - ("E L\\([0-9]+\\)/C\\([0-9]+\\):" nil 1 2) + ("^E L\\([0-9]+\\)/C\\([0-9]+\\):" nil 1 2) ("^analyze +\\(.+ +\\)*\\(.+\\)$" 2) nil) ;; ModelSim, Model Technology: vcom test.vhd @@ -266,14 +268,14 @@ Overrides local variable `indent-tabs-mode'." ;; ** Error: adder.vhd(190): Unknown identifier: ctl_numb ("ModelSim" "vcom" "-93 -work \\1" "make" "-f \\1" nil "vlib \\1; vmap \\2 \\1" "./" "work/" "Makefile" "modelsim" - ("\\(ERROR\\|WARNING\\|\\*\\* Error\\|\\*\\* Warning\\)[^:]*:\\( *\[[0-9]+\]\\)? \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 3 4 nil) ("" 0) + ("^\\(ERROR\\|WARNING\\|\\*\\* Error\\|\\*\\* Warning\\)[^:]*:\\( *\[[0-9]+\]\\)? \\([^ \t\n]+\\)(\\([0-9]+\\)):" 3 4 nil) ("" 0) ("\\1/_primary.dat" "\\2/\\1.dat" "\\1/_primary.dat" "\\1/_primary.dat" "\\1/body.dat" downcase)) ;; ProVHDL, Synopsys LEDA: provhdl -w work -f test.vhd ;; test.vhd:34: error message ("LEDA ProVHDL" "provhdl" "-w \\1 -f" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "provhdl" - ("\\([^ \\t\\n]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) + ("^\\([^ \t\n:]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) ("ENTI/\\1.vif" "ARCH/\\1-\\2.vif" "CONF/\\1.vif" "PACK/\\1.vif" "BODY/BODY-\\1.vif" upcase)) ;; Quartus compiler @@ -284,21 +286,21 @@ Overrides local variable `indent-tabs-mode'." ;; Warning: VHDL Process Statement warning at dvi2sdi_tst.vhd(172): ... ("Quartus" "make" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "quartus" - ("\\(Error\\|Warning\\): .* \\([^ \\t\\n]+\\)(\\([0-9]+\\))" 2 3 nil) ("" 0) + ("^\\(Error\\|Warning\\): .* \\([^ \t\n]+\\)(\\([0-9]+\\))" 2 3 nil) ("" 0) nil) ;; QuickHDL, Mentor Graphics: qvhcom test.vhd ;; ERROR: test.vhd(24): near "dnd": expecting: END ;; WARNING[4]: test.vhd(30): A space is required between ... ("QuickHDL" "qvhcom" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "quickhdl" - ("\\(ERROR\\|WARNING\\)[^:]*: \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 2 3 nil) ("" 0) + ("^\\(ERROR\\|WARNING\\)[^:]*: \\([^ \t\n]+\\)(\\([0-9]+\\)):" 2 3 nil) ("" 0) ("\\1/_primary.dat" "\\2/\\1.dat" "\\1/_primary.dat" "\\1/_primary.dat" "\\1/body.dat" downcase)) ;; Savant: scram -publish-cc test.vhd ;; test.vhd:87: _set_passed_through_out_port(IIR_Boolean) not defined for ("Savant" "scram" "-publish-cc -design-library-name \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work._savant_lib/" "Makefile" "savant" - ("\\([^ \\t\\n]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) + ("^\\([^ \t\n:]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) ("\\1_entity.vhdl" "\\2_secondary_units._savant_lib/\\2_\\1.vhdl" "\\1_config.vhdl" "\\1_package.vhdl" "\\1_secondary_units._savant_lib/\\1_package_body.vhdl" downcase)) @@ -306,39 +308,39 @@ Overrides local variable `indent-tabs-mode'." ;; Error: CSVHDL0002: test.vhd: (line 97): Invalid prefix ("Simili" "vhdlp" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "simili" - ("\\(Error\\|Warning\\): \\w+: \\([^ \\t\\n]+\\): (line \\([0-9]+\\)): " 2 3 nil) ("" 0) + ("^\\(Error\\|Warning\\): \\w+: \\([^ \t\n]+\\): (line \\([0-9]+\\)): " 2 3 nil) ("" 0) ("\\1/prim.var" "\\2/_\\1.var" "\\1/prim.var" "\\1/prim.var" "\\1/_body.var" downcase)) ;; Speedwave (Innoveda): analyze -libfile vsslib.ini -src test.vhd ;; ERROR[11]::File test.vhd Line 100: Use of undeclared identifier ("Speedwave" "analyze" "-libfile vsslib.ini -src" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "speedwave" - ("^ *ERROR\[[0-9]+\]::File \\([^ \\t\\n]+\\) Line \\([0-9]+\\):" 1 2 nil) ("" 0) + ("^ *ERROR\[[0-9]+\]::File \\([^ \t\n]+\\) Line \\([0-9]+\\):" 1 2 nil) ("" 0) nil) ;; Synopsys, VHDL Analyzer (sim): vhdlan -nc test.vhd ;; **Error: vhdlan,703 test.vhd(22): OTHERS is not legal in this context. ("Synopsys" "vhdlan" "-nc -work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "synopsys" - ("\\*\\*Error: vhdlan,[0-9]+ \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) + ("^\\*\\*Error: vhdlan,[0-9]+ \\([^ \t\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) ("\\1.sim" "\\2__\\1.sim" "\\1.sim" "\\1.sim" "\\1__.sim" upcase)) ;; Synopsys, VHDL Analyzer (syn): vhdlan -nc -spc test.vhd ;; **Error: vhdlan,703 test.vhd(22): OTHERS is not legal in this context. ("Synopsys Design Compiler" "vhdlan" "-nc -spc -work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "synopsys_dc" - ("\\*\\*Error: vhdlan,[0-9]+ \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) + ("^\\*\\*Error: vhdlan,[0-9]+ \\([^ \t\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) ("\\1.syn" "\\2__\\1.syn" "\\1.syn" "\\1.syn" "\\1__.syn" upcase)) ;; Synplify: ;; @W:"test.vhd":57:8:57:9|Optimizing register bit count_x(5) to a constant 0 ("Synplify" "n/a" "n/a" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "synplify" - ("@[EWN]:\"\\([^ \\t\\n]+\\)\":\\([0-9]+\\):\\([0-9]+\\):" 1 2 3) ("" 0) + ("^@[EWN]:\"\\([^ \t\n]+\\)\":\\([0-9]+\\):\\([0-9]+\\):" 1 2 3) ("" 0) nil) ;; Vantage: analyze -libfile vsslib.ini -src test.vhd ;; Compiling "test.vhd" line 1... ;; **Error: LINE 49 *** No aggregate value is valid in this context. ("Vantage" "analyze" "-libfile vsslib.ini -src" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "vantage" - ("\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) + ("^\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) ("^ *Compiling \"\\(.+\\)\" " 1) nil) ;; VeriBest: vc vhdl test.vhd @@ -355,14 +357,14 @@ Overrides local variable `indent-tabs-mode'." ;; **Error: LINE 49 *** No aggregate value is valid in this context. ("Viewlogic" "analyze" "-libfile vsslib.ini -src" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "viewlogic" - ("\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) + ("^\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) ("^ *Compiling \"\\(.+\\)\" " 1) nil) ;; Xilinx XST: ;; ERROR:HDLParsers:164 - "test.vhd" Line 3. parse error ("Xilinx XST" "xflow" "" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "xilinx" - ("^ERROR:HDLParsers:[0-9]+ - \"\\([^ \\t\\n]+\\)\" Line \\([0-9]+\\)\." 1 2 nil) ("" 0) + ("^ERROR:HDLParsers:[0-9]+ - \"\\([^ \t\n]+\\)\" Line \\([0-9]+\\)\." 1 2 nil) ("" 0) nil) ) "List of available VHDL compilers and their properties. @@ -487,7 +489,7 @@ Select a compiler name from the ones defined in option `vhdl-compiler-alist'." (append '(choice) (nreverse list))) :group 'vhdl-compile) -(defcustom vhdl-compile-use-local-error-regexp t +(defcustom vhdl-compile-use-local-error-regexp nil "Non-nil means use buffer-local `compilation-error-regexp-alist'. In this case, only error message regexps for VHDL compilers are active if compilation is started from a VHDL buffer. Otherwise, the error message @@ -496,6 +498,7 @@ active all the time. Note that by doing that, the predefined global regexps might result in erroneous parsing of error messages for some VHDL compilers. NOTE: Activate the new setting by restarting Emacs." + :version "25.1" ; t -> nil :type 'boolean :group 'vhdl-compile) @@ -2137,73 +2140,36 @@ your style, only those that are different from the default.") (require 'ps-print) (require 'speedbar))) ; for speedbar-with-writable -;; functions from obsolete assoc.el package (obsoleted in GNU Emacs 24.3) -(defun vhdl-asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (symbol-value alist-symbol)) - (lambda (a _b) (equal (car a) key))))) - -(defun vhdl-anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (car (car alist)) key))) - (defun vhdl-aput (alist-symbol key &optional value) "Insert a key-value pair into an alist. The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (let ((elem (list (cons key value))) - alist) - (vhdl-asort alist-symbol key) - (setq alist (symbol-value alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((vhdl-anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem)) alist) - (t alist)))) +from KEY and VALUE. If the key-value pair referenced by KEY can be +found in the alist, the value of KEY will be set to VALUE. If the +key-value pair cannot be found in the alist, it will be inserted into +the head of the alist." + (let* ((alist (symbol-value alist-symbol)) + (elem (assoc key alist))) + (if elem + (setcdr elem value) + (set alist-symbol (cons (cons key value) alist))))) (defun vhdl-adelete (alist-symbol key) "Delete a key-value pair from the alist. Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (vhdl-asort alist-symbol key) - (let ((alist (symbol-value alist-symbol))) - (cond ((null alist) nil) - ((vhdl-anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - -(defun vhdl-aget (alist key &optional keynil-p) - "Return the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (let ((copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (vhdl-asort 'copy key) - (vhdl-anot-head-p copy key)) nil) - ((cdr (car copy))) - (keynil-p nil) - ((car (car copy))) - (t nil)))) - +is pair matching KEY." + (let ((alist (symbol-value alist-symbol)) alist-cdr) + (while (equal key (caar alist)) + (setq alist (cdr alist)) + (set alist-symbol alist)) + (while (setq alist-cdr (cdr alist)) + (if (equal key (caar alist-cdr)) + (setcdr alist (cdr alist-cdr)) + (setq alist alist-cdr))))) + +(defun vhdl-aget (alist key) + "Return the value in ALIST that is associated with KEY. If KEY is +not found, then nil is returned." + (cdr (assoc key alist))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compatibility @@ -12981,16 +12947,18 @@ File statistics: \"%s\"\n\ (condition-case () (let ((current-project vhdl-project)) (load-file file-name) - (when (/= (length (vhdl-aget vhdl-project-alist vhdl-project t)) 10) + (when (/= (length (vhdl-aget vhdl-project-alist vhdl-project)) 10) (vhdl-adelete 'vhdl-project-alist vhdl-project) (error "")) - (when not-make-current - (setq vhdl-project current-project)) + (if not-make-current + (setq vhdl-project current-project) + (setq vhdl-compiler + (caar (nth 4 (vhdl-aget vhdl-project-alist vhdl-project))))) (vhdl-update-mode-menu) (vhdl-speedbar-refresh) (unless not-make-current - (message "Current VHDL project: \"%s\"%s" - vhdl-project (if auto " (auto-loaded)" "")))) + (message "Current VHDL project: \"%s\"; compiler: \"%s\"%s" + vhdl-project vhdl-compiler (if auto " (auto-loaded)" "")))) (error (vhdl-warning (format "ERROR: Invalid project setup file: \"%s\"" file-name)))))) @@ -12998,7 +12966,7 @@ File statistics: \"%s\"\n\ "Duplicate setup of current project." (interactive) (let ((new-name (read-from-minibuffer "New project name: ")) - (project-entry (vhdl-aget vhdl-project-alist vhdl-project t))) + (project-entry (vhdl-aget vhdl-project-alist vhdl-project))) (setq vhdl-project-alist (append vhdl-project-alist (list (cons new-name project-entry)))) @@ -13746,11 +13714,11 @@ hierarchy otherwise.") ent-alist conf-alist pack-alist ent-inst-list file-alist tmp-list tmp-entry no-files files-exist big-files) (when (or project update) - (setq ent-alist (vhdl-aget vhdl-entity-alist key t) - conf-alist (vhdl-aget vhdl-config-alist key t) - pack-alist (vhdl-aget vhdl-package-alist key t) - ent-inst-list (car (vhdl-aget vhdl-ent-inst-alist key t)) - file-alist (vhdl-aget vhdl-file-alist key t))) + (setq ent-alist (vhdl-aget vhdl-entity-alist key) + conf-alist (vhdl-aget vhdl-config-alist key) + pack-alist (vhdl-aget vhdl-package-alist key) + ent-inst-list (car (vhdl-aget vhdl-ent-inst-alist key)) + file-alist (vhdl-aget vhdl-file-alist key))) (when (and (not is-directory) (null file-list)) (message "No such file: \"%s\"" name)) (setq files-exist file-list) @@ -13792,7 +13760,7 @@ hierarchy otherwise.") (while (re-search-forward "^[ \t]*entity[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t) (let* ((ent-name (match-string-no-properties 1)) (ent-key (downcase ent-name)) - (ent-entry (vhdl-aget ent-alist ent-key t)) + (ent-entry (vhdl-aget ent-alist ent-key)) (lib-alist (vhdl-scan-context-clause))) (if (nth 1 ent-entry) (vhdl-warning-when-idle @@ -13811,9 +13779,9 @@ hierarchy otherwise.") (arch-key (downcase arch-name)) (ent-name (match-string-no-properties 2)) (ent-key (downcase ent-name)) - (ent-entry (vhdl-aget ent-alist ent-key t)) + (ent-entry (vhdl-aget ent-alist ent-key)) (arch-alist (nth 3 ent-entry)) - (arch-entry (vhdl-aget arch-alist arch-key t)) + (arch-entry (vhdl-aget arch-alist arch-key)) (lib-arch-alist (vhdl-scan-context-clause))) (if arch-entry (vhdl-warning-when-idle @@ -13835,7 +13803,7 @@ hierarchy otherwise.") (while (re-search-forward "^[ \t]*configuration[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+of[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t) (let* ((conf-name (match-string-no-properties 1)) (conf-key (downcase conf-name)) - (conf-entry (vhdl-aget conf-alist conf-key t)) + (conf-entry (vhdl-aget conf-alist conf-key)) (ent-name (match-string-no-properties 2)) (ent-key (downcase ent-name)) (lib-alist (vhdl-scan-context-clause)) @@ -13885,7 +13853,7 @@ hierarchy otherwise.") (let* ((pack-name (match-string-no-properties 2)) (pack-key (downcase pack-name)) (is-body (match-string-no-properties 1)) - (pack-entry (vhdl-aget pack-alist pack-key t)) + (pack-entry (vhdl-aget pack-alist pack-key)) (pack-line (vhdl-current-line)) (end-of-unit (vhdl-get-end-of-unit)) comp-name func-name comp-alist func-alist lib-alist) @@ -13940,9 +13908,9 @@ hierarchy otherwise.") (ent-key (downcase ent-name)) (arch-name (match-string-no-properties 1)) (arch-key (downcase arch-name)) - (ent-entry (vhdl-aget ent-alist ent-key t)) + (ent-entry (vhdl-aget ent-alist ent-key)) (arch-alist (nth 3 ent-entry)) - (arch-entry (vhdl-aget arch-alist arch-key t)) + (arch-entry (vhdl-aget arch-alist arch-key)) (beg-of-unit (point)) (end-of-unit (vhdl-get-end-of-unit)) (inst-no 0) @@ -14077,8 +14045,8 @@ hierarchy otherwise.") ;; check whether configuration has a corresponding entity/architecture (setq tmp-list conf-alist) (while tmp-list - (if (setq tmp-entry (vhdl-aget ent-alist (nth 4 (car tmp-list)) t)) - (unless (vhdl-aget (nth 3 tmp-entry) (nth 5 (car tmp-list)) t) + (if (setq tmp-entry (vhdl-aget ent-alist (nth 4 (car tmp-list)))) + (unless (vhdl-aget (nth 3 tmp-entry) (nth 5 (car tmp-list))) (setq tmp-entry (car tmp-list)) (vhdl-warning-when-idle "Configuration of non-existing architecture: \"%s\" of \"%s(%s)\"\n in \"%s\" (line %d)" @@ -14205,15 +14173,15 @@ of PROJECT." (let* ((vhdl-project (nth 0 (car directory-alist))) (project (vhdl-project-p)) (ent-alist (vhdl-aget vhdl-entity-alist - (or project dir-name) t)) + (or project dir-name))) (conf-alist (vhdl-aget vhdl-config-alist - (or project dir-name) t)) + (or project dir-name))) (pack-alist (vhdl-aget vhdl-package-alist - (or project dir-name) t)) + (or project dir-name))) (ent-inst-list (car (vhdl-aget vhdl-ent-inst-alist - (or project dir-name) t))) - (file-alist (vhdl-aget vhdl-file-alist (or project dir-name) t)) - (file-entry (vhdl-aget file-alist file-name t)) + (or project dir-name)))) + (file-alist (vhdl-aget vhdl-file-alist (or project dir-name))) + (file-entry (vhdl-aget file-alist file-name)) (ent-list (nth 0 file-entry)) (arch-list (nth 1 file-entry)) (arch-ent-list (nth 2 file-entry)) @@ -14227,7 +14195,7 @@ of PROJECT." ;; entities (while ent-list (setq key (car ent-list) - entry (vhdl-aget ent-alist key t)) + entry (vhdl-aget ent-alist key)) (when (equal file-name (nth 1 entry)) (if (nth 3 entry) (vhdl-aput 'ent-alist key @@ -14238,9 +14206,9 @@ of PROJECT." (while arch-list (setq key (car arch-list) ent-key (car arch-ent-list) - entry (vhdl-aget ent-alist ent-key t) + entry (vhdl-aget ent-alist ent-key) arch-alist (nth 3 entry)) - (when (equal file-name (nth 1 (vhdl-aget arch-alist key t))) + (when (equal file-name (nth 1 (vhdl-aget arch-alist key))) (vhdl-adelete 'arch-alist key) (if (or (nth 1 entry) arch-alist) (vhdl-aput 'ent-alist ent-key @@ -14252,13 +14220,13 @@ of PROJECT." ;; configurations (while conf-list (setq key (car conf-list)) - (when (equal file-name (nth 1 (vhdl-aget conf-alist key t))) + (when (equal file-name (nth 1 (vhdl-aget conf-alist key))) (vhdl-adelete 'conf-alist key)) (setq conf-list (cdr conf-list))) ;; package declarations (while pack-list (setq key (car pack-list) - entry (vhdl-aget pack-alist key t)) + entry (vhdl-aget pack-alist key)) (when (equal file-name (nth 1 entry)) (if (nth 6 entry) (vhdl-aput 'pack-alist key @@ -14270,7 +14238,7 @@ of PROJECT." ;; package bodies (while pack-body-list (setq key (car pack-body-list) - entry (vhdl-aget pack-alist key t)) + entry (vhdl-aget pack-alist key)) (when (equal file-name (nth 6 entry)) (if (nth 1 entry) (vhdl-aput 'pack-alist key @@ -14321,8 +14289,8 @@ of PROJECT." &optional include-top ent-hier) "Get instantiation hierarchy beginning in architecture ARCH-KEY of entity ENT-KEY." - (let* ((ent-entry (vhdl-aget ent-alist ent-key t)) - (arch-entry (if arch-key (vhdl-aget (nth 3 ent-entry) arch-key t) + (let* ((ent-entry (vhdl-aget ent-alist ent-key)) + (arch-entry (if arch-key (vhdl-aget (nth 3 ent-entry) arch-key) (cdar (last (nth 3 ent-entry))))) (inst-alist (nth 3 arch-entry)) inst-entry inst-ent-entry inst-arch-entry inst-conf-entry comp-entry @@ -14348,17 +14316,17 @@ entity ENT-KEY." (downcase (or inst-comp-name "")))))) (setq tmp-list (cdr tmp-list))) (setq inst-conf-key (or (nth 4 (car tmp-list)) inst-conf-key)) - (setq inst-conf-entry (vhdl-aget conf-alist inst-conf-key t)) + (setq inst-conf-entry (vhdl-aget conf-alist inst-conf-key)) (when (and inst-conf-key (not inst-conf-entry)) (vhdl-warning-when-idle "Configuration not found: \"%s\"" inst-conf-key)) ;; determine entity (setq inst-ent-key (or (nth 2 (car tmp-list)) ; from configuration (nth 3 inst-conf-entry) ; from subconfiguration - (nth 3 (vhdl-aget conf-alist (nth 7 inst-entry) t)) + (nth 3 (vhdl-aget conf-alist (nth 7 inst-entry))) ; from configuration spec. (nth 5 inst-entry))) ; from direct instantiation - (setq inst-ent-entry (vhdl-aget ent-alist inst-ent-key t)) + (setq inst-ent-entry (vhdl-aget ent-alist inst-ent-key)) ;; determine architecture (setq inst-arch-key (or (nth 3 (car tmp-list)) ; from configuration @@ -14368,7 +14336,7 @@ entity ENT-KEY." ; from configuration spec. (nth 4 inst-ent-entry) ; MRA (caar (nth 3 inst-ent-entry)))) ; first alphabetically - (setq inst-arch-entry (vhdl-aget (nth 3 inst-ent-entry) inst-arch-key t)) + (setq inst-arch-entry (vhdl-aget (nth 3 inst-ent-entry) inst-arch-key)) ;; set library (setq inst-lib-key (or (nth 5 (car tmp-list)) ; from configuration @@ -14408,7 +14376,7 @@ entity ENT-KEY." (defun vhdl-get-instantiations (ent-key indent) "Get all instantiations of entity ENT-KEY." (let ((ent-alist (vhdl-aget vhdl-entity-alist - (vhdl-speedbar-line-key indent) t)) + (vhdl-speedbar-line-key indent))) arch-alist inst-alist ent-inst-list ent-entry arch-entry inst-entry) (while ent-alist @@ -14495,28 +14463,28 @@ entity ENT-KEY." (when (member 'hierarchy vhdl-speedbar-save-cache) (insert "\n;; entity and architecture cache\n" "(vhdl-aput 'vhdl-entity-alist " key " '") - (print (vhdl-aget vhdl-entity-alist cache-key t) (current-buffer)) + (print (vhdl-aget vhdl-entity-alist cache-key) (current-buffer)) (insert ")\n\n;; configuration cache\n" "(vhdl-aput 'vhdl-config-alist " key " '") - (print (vhdl-aget vhdl-config-alist cache-key t) (current-buffer)) + (print (vhdl-aget vhdl-config-alist cache-key) (current-buffer)) (insert ")\n\n;; package cache\n" "(vhdl-aput 'vhdl-package-alist " key " '") - (print (vhdl-aget vhdl-package-alist cache-key t) (current-buffer)) + (print (vhdl-aget vhdl-package-alist cache-key) (current-buffer)) (insert ")\n\n;; instantiated entities cache\n" "(vhdl-aput 'vhdl-ent-inst-alist " key " '") - (print (vhdl-aget vhdl-ent-inst-alist cache-key t) (current-buffer)) + (print (vhdl-aget vhdl-ent-inst-alist cache-key) (current-buffer)) (insert ")\n\n;; design units per file cache\n" "(vhdl-aput 'vhdl-file-alist " key " '") - (print (vhdl-aget vhdl-file-alist cache-key t) (current-buffer)) + (print (vhdl-aget vhdl-file-alist cache-key) (current-buffer)) (when project (insert ")\n\n;; source directories in project cache\n" "(vhdl-aput 'vhdl-directory-alist " key " '") - (print (vhdl-aget vhdl-directory-alist cache-key t) (current-buffer))) + (print (vhdl-aget vhdl-directory-alist cache-key) (current-buffer))) (insert ")\n")) (when (member 'display vhdl-speedbar-save-cache) (insert "\n;; shown design units cache\n" "(vhdl-aput 'vhdl-speedbar-shown-unit-alist " key " '") - (print (vhdl-aget vhdl-speedbar-shown-unit-alist cache-key t) + (print (vhdl-aget vhdl-speedbar-shown-unit-alist cache-key) (current-buffer)) (insert ")\n")) (setq vhdl-updated-project-list @@ -14784,10 +14752,10 @@ otherwise use cached data." (vhdl-scan-project-contents project)) ;; insert design hierarchy (vhdl-speedbar-insert-hierarchy - (vhdl-aget vhdl-entity-alist project t) - (vhdl-aget vhdl-config-alist project t) - (vhdl-aget vhdl-package-alist project t) - (car (vhdl-aget vhdl-ent-inst-alist project t)) indent) + (vhdl-aget vhdl-entity-alist project) + (vhdl-aget vhdl-config-alist project) + (vhdl-aget vhdl-package-alist project) + (car (vhdl-aget vhdl-ent-inst-alist project)) indent) (insert (int-to-string indent) ":\n") (put-text-property (- (point) 3) (1- (point)) 'invisible t) (put-text-property (1- (point)) (point) 'invisible nil) @@ -14802,10 +14770,10 @@ otherwise use cached data." (vhdl-scan-directory-contents directory)) ;; insert design hierarchy (vhdl-speedbar-insert-hierarchy - (vhdl-aget vhdl-entity-alist directory t) - (vhdl-aget vhdl-config-alist directory t) - (vhdl-aget vhdl-package-alist directory t) - (car (vhdl-aget vhdl-ent-inst-alist directory t)) depth) + (vhdl-aget vhdl-entity-alist directory) + (vhdl-aget vhdl-config-alist directory) + (vhdl-aget vhdl-package-alist directory) + (car (vhdl-aget vhdl-ent-inst-alist directory)) depth) ;; expand design units (vhdl-speedbar-expand-units directory) (vhdl-aput 'vhdl-directory-alist directory (list (list directory)))) @@ -14896,7 +14864,7 @@ otherwise use cached data." (defun vhdl-speedbar-expand-units (key) "Expand design units in directory/project KEY according to `vhdl-speedbar-shown-unit-alist'." - (let ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t)) + (let ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key)) (vhdl-speedbar-update-current-unit nil) vhdl-updated-project-list) (vhdl-adelete 'vhdl-speedbar-shown-unit-alist key) @@ -14958,9 +14926,9 @@ otherwise use cached data." "Expand all design units in current directory/project." (interactive) (let* ((key (vhdl-speedbar-line-key)) - (ent-alist (vhdl-aget vhdl-entity-alist key t)) - (conf-alist (vhdl-aget vhdl-config-alist key t)) - (pack-alist (vhdl-aget vhdl-package-alist key t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) + (conf-alist (vhdl-aget vhdl-config-alist key)) + (pack-alist (vhdl-aget vhdl-package-alist key)) arch-alist unit-alist subunit-alist) (add-to-list 'vhdl-speedbar-shown-project-list key) (while ent-alist @@ -15012,8 +14980,8 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand entity (let* ((key (vhdl-speedbar-line-key indent)) - (ent-alist (vhdl-aget vhdl-entity-alist key t)) - (ent-entry (vhdl-aget ent-alist token t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) + (ent-entry (vhdl-aget ent-alist token)) (arch-alist (nth 3 ent-entry)) (inst-alist (vhdl-get-instantiations token indent)) (subpack-alist (nth 5 ent-entry)) @@ -15023,7 +14991,7 @@ otherwise use cached data." (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add entity to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t))) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) (vhdl-aput 'unit-alist token nil) (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable @@ -15064,7 +15032,7 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove entity from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key indent)) - (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t))) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) (vhdl-adelete 'unit-alist token) (if unit-alist (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) @@ -15081,21 +15049,21 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand architecture (let* ((key (vhdl-speedbar-line-key (1- indent))) - (ent-alist (vhdl-aget vhdl-entity-alist key t)) - (conf-alist (vhdl-aget vhdl-config-alist key t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) + (conf-alist (vhdl-aget vhdl-config-alist key)) (hier-alist (vhdl-get-hierarchy ent-alist conf-alist (car token) (cdr token) nil nil 0 (1- indent))) - (ent-entry (vhdl-aget ent-alist (car token) t)) - (arch-entry (vhdl-aget (nth 3 ent-entry) (cdr token) t)) + (ent-entry (vhdl-aget ent-alist (car token))) + (arch-entry (vhdl-aget (nth 3 ent-entry) (cdr token))) (subpack-alist (nth 4 arch-entry)) entry) (if (not (or hier-alist subpack-alist)) (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add architecture to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t)) - (arch-alist (nth 0 (vhdl-aget unit-alist (car token) t)))) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key)) + (arch-alist (nth 0 (vhdl-aget unit-alist (car token))))) (vhdl-aput 'unit-alist (car token) (list (cons (cdr token) arch-alist))) (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) @@ -15125,8 +15093,8 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove architecture from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key (1- indent))) - (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t)) - (arch-alist (nth 0 (vhdl-aget unit-alist (car token) t)))) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key)) + (arch-alist (nth 0 (vhdl-aget unit-alist (car token))))) (vhdl-aput 'unit-alist (car token) (list (delete (cdr token) arch-alist))) (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) (speedbar-delete-subblock indent) @@ -15141,9 +15109,9 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand configuration (let* ((key (vhdl-speedbar-line-key indent)) - (conf-alist (vhdl-aget vhdl-config-alist key t)) + (conf-alist (vhdl-aget vhdl-config-alist key)) (conf-entry (vhdl-aget conf-alist token)) - (ent-alist (vhdl-aget vhdl-entity-alist key t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) (hier-alist (vhdl-get-hierarchy ent-alist conf-alist (nth 3 conf-entry) (nth 4 conf-entry) token (nth 5 conf-entry) @@ -15154,7 +15122,7 @@ otherwise use cached data." (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add configuration to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t))) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) (vhdl-aput 'unit-alist token nil) (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable @@ -15182,7 +15150,7 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove configuration from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key indent)) - (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t))) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) (vhdl-adelete 'unit-alist token) (if unit-alist (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) @@ -15199,8 +15167,8 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand package (let* ((key (vhdl-speedbar-line-key indent)) - (pack-alist (vhdl-aget vhdl-package-alist key t)) - (pack-entry (vhdl-aget pack-alist token t)) + (pack-alist (vhdl-aget vhdl-package-alist key)) + (pack-entry (vhdl-aget pack-alist token)) (comp-alist (nth 3 pack-entry)) (func-alist (nth 4 pack-entry)) (func-body-alist (nth 8 pack-entry)) @@ -15210,7 +15178,7 @@ otherwise use cached data." (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add package to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t))) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) (vhdl-aput 'unit-alist token nil) (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable @@ -15234,7 +15202,7 @@ otherwise use cached data." (while func-alist (setq func-entry (car func-alist) func-body-entry (vhdl-aget func-body-alist - (car func-entry) t)) + (car func-entry))) (when (nth 2 func-entry) (vhdl-speedbar-make-subprogram-line (nth 1 func-entry) @@ -15252,7 +15220,7 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove package from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key indent)) - (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key t))) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) (vhdl-adelete 'unit-alist token) (if unit-alist (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) @@ -15267,14 +15235,14 @@ otherwise use cached data." (defun vhdl-speedbar-insert-subpackages (subpack-alist indent dir-indent) "Insert required packages." (let* ((pack-alist (vhdl-aget vhdl-package-alist - (vhdl-speedbar-line-key dir-indent) t)) + (vhdl-speedbar-line-key dir-indent))) pack-key lib-name pack-entry) (when subpack-alist (vhdl-speedbar-make-title-line "Packages Used:" indent)) (while subpack-alist (setq pack-key (cdar subpack-alist) lib-name (caar subpack-alist)) - (setq pack-entry (vhdl-aget pack-alist pack-key t)) + (setq pack-entry (vhdl-aget pack-alist pack-key)) (vhdl-speedbar-make-subpack-line (or (nth 0 pack-entry) pack-key) lib-name (cons (nth 1 pack-entry) (nth 2 pack-entry)) @@ -15334,11 +15302,11 @@ NO-POSITION non-nil means do not re-position cursor." (while project-list (setq file-alist (append file-alist (vhdl-aget vhdl-file-alist - (car project-list) t))) + (car project-list)))) (setq project-list (cdr project-list))) (setq file-alist (vhdl-aget vhdl-file-alist - (abbreviate-file-name default-directory) t))) + (abbreviate-file-name default-directory)))) (select-frame speedbar-frame) (set-buffer speedbar-buffer) (speedbar-with-writable @@ -15346,7 +15314,7 @@ NO-POSITION non-nil means do not re-position cursor." (save-excursion ;; unhighlight last units (let* ((file-entry (vhdl-aget file-alist - speedbar-last-selected-file t))) + speedbar-last-selected-file))) (vhdl-speedbar-update-units "\\[.\\] " (nth 0 file-entry) speedbar-last-selected-file 'vhdl-speedbar-entity-face) @@ -15366,7 +15334,7 @@ NO-POSITION non-nil means do not re-position cursor." "> " (nth 6 file-entry) speedbar-last-selected-file 'vhdl-speedbar-instantiation-face)) ;; highlight current units - (let* ((file-entry (vhdl-aget file-alist file-name t))) + (let* ((file-entry (vhdl-aget file-alist file-name))) (setq pos (vhdl-speedbar-update-units "\\[.\\] " (nth 0 file-entry) @@ -15862,8 +15830,8 @@ is already shown in a buffer." (ent-alist (vhdl-aget vhdl-entity-alist (or (vhdl-project-p) - (abbreviate-file-name default-directory)) t)) - (ent-entry (vhdl-aget ent-alist ent-key t))) + (abbreviate-file-name default-directory)))) + (ent-entry (vhdl-aget ent-alist ent-key))) (setcar (cddr (cddr ent-entry)) arch-key) ; (nth 4 ent-entry) (speedbar-refresh)))) @@ -16272,7 +16240,7 @@ component instantiation." (setq constant-entry (cons constant-name (if (match-string 1) - (or (vhdl-aget generic-alist (match-string 2) t) + (or (vhdl-aget generic-alist (match-string 2)) (error "ERROR: Formal generic \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name)) (cdar generic-alist)))) (push constant-entry constant-alist) @@ -16293,7 +16261,7 @@ component instantiation." (setq signal-entry (cons signal-name (if (match-string 1) - (or (vhdl-aget port-alist (match-string 2) t) + (or (vhdl-aget port-alist (match-string 2)) (error "ERROR: Formal port \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name)) (cdar port-alist)))) (push signal-entry signal-alist) @@ -16536,7 +16504,7 @@ current project/directory." "." (file-name-extension (buffer-file-name)))) (ent-alist (vhdl-aget vhdl-entity-alist (or project - (abbreviate-file-name default-directory)) t)) + (abbreviate-file-name default-directory)))) (lazy-lock-minimum-size 0) clause-pos component-pos) (message "Generating components package \"%s\"..." pack-name) @@ -16639,7 +16607,7 @@ current project/directory." (when (equal (nth 5 inst-entry) (nth 4 (car tmp-alist))) (setq conf-key (nth 0 (car tmp-alist)))) (setq tmp-alist (cdr tmp-alist))) - (setq conf-entry (vhdl-aget conf-alist conf-key t)) + (setq conf-entry (vhdl-aget conf-alist conf-key)) ;; insert binding indication ... ;; ... with subconfiguration (if exists) (if (and vhdl-compose-configuration-use-subconfiguration conf-entry) @@ -16649,7 +16617,7 @@ current project/directory." (insert (vhdl-work-library) "." (nth 0 conf-entry)) (insert ";\n")) ;; ... with entity (if exists) - (setq ent-entry (vhdl-aget ent-alist (nth 5 inst-entry) t)) + (setq ent-entry (vhdl-aget ent-alist (nth 5 inst-entry))) (when ent-entry (indent-to (+ margin vhdl-basic-offset)) (vhdl-insert-keyword "USE ENTITY ") @@ -16661,7 +16629,7 @@ current project/directory." ;; b) from mra, or c) from first architecture (or (nth 0 (vhdl-aget (nth 3 ent-entry) (or (nth 6 inst-entry) - (nth 4 ent-entry)) t)) + (nth 4 ent-entry)))) (nth 1 (car (nth 3 ent-entry))))) (insert "(" arch-name ")")) (insert ";\n") @@ -16671,7 +16639,7 @@ current project/directory." (indent-to (+ margin vhdl-basic-offset)) (vhdl-compose-configuration-architecture (nth 0 ent-entry) arch-name ent-alist conf-alist - (nth 3 (vhdl-aget (nth 3 ent-entry) (downcase arch-name) t)))))) + (nth 3 (vhdl-aget (nth 3 ent-entry) (downcase arch-name))))))) ;; insert component configuration end (indent-to margin) (vhdl-insert-keyword "END FOR;\n") @@ -16695,10 +16663,10 @@ current project/directory." (vhdl-require-hierarchy-info) (let ((ent-alist (vhdl-aget vhdl-entity-alist (or (vhdl-project-p) - (abbreviate-file-name default-directory)) t)) + (abbreviate-file-name default-directory)))) (conf-alist (vhdl-aget vhdl-config-alist (or (vhdl-project-p) - (abbreviate-file-name default-directory)) t)) + (abbreviate-file-name default-directory)))) (from-speedbar ent-name) inst-alist conf-name conf-file-name pos) (vhdl-prepare-search-2 @@ -16714,8 +16682,8 @@ current project/directory." vhdl-compose-configuration-name (concat ent-name " " arch-name))) (setq inst-alist - (nth 3 (vhdl-aget (nth 3 (vhdl-aget ent-alist (downcase ent-name) t)) - (downcase arch-name) t)))) + (nth 3 (vhdl-aget (nth 3 (vhdl-aget ent-alist (downcase ent-name))) + (downcase arch-name))))) (message "Generating configuration \"%s\"..." conf-name) (if vhdl-compose-configuration-create-file ;; open configuration file @@ -16930,7 +16898,7 @@ do not print any file names." (interactive) (vhdl-compile-init) (let* ((project (vhdl-aget vhdl-project-alist vhdl-project)) - (compiler (or (vhdl-aget vhdl-compiler-alist vhdl-compiler nil) + (compiler (or (vhdl-aget vhdl-compiler-alist vhdl-compiler) (error "ERROR: No such compiler: \"%s\"" vhdl-compiler))) (command (nth 0 compiler)) (default-directory (vhdl-compile-directory)) @@ -17065,9 +17033,9 @@ specified by a target." (vhdl-scan-directory-contents directory)))) (let* ((directory (abbreviate-file-name (vhdl-default-directory))) (project (vhdl-project-p)) - (ent-alist (vhdl-aget vhdl-entity-alist (or project directory) t)) - (conf-alist (vhdl-aget vhdl-config-alist (or project directory) t)) - (pack-alist (vhdl-aget vhdl-package-alist (or project directory) t)) + (ent-alist (vhdl-aget vhdl-entity-alist (or project directory))) + (conf-alist (vhdl-aget vhdl-config-alist (or project directory))) + (pack-alist (vhdl-aget vhdl-package-alist (or project directory))) (regexp-list (or (nth 12 (vhdl-aget vhdl-compiler-alist vhdl-compiler)) '("\\1.vhd" "\\2_\\1.vhd" "\\1.vhd" "\\1.vhd" "\\1_body.vhd" identity))) @@ -17397,9 +17365,9 @@ specified by a target." (setq subcomp-list (sort (vhdl-uniquify (nth 2 (car prim-list))) 'string<)) (setq unit-key (caar prim-list) - unit-name (or (nth 0 (vhdl-aget ent-alist unit-key t)) - (nth 0 (vhdl-aget conf-alist unit-key t)) - (nth 0 (vhdl-aget pack-alist unit-key t)))) + unit-name (or (nth 0 (vhdl-aget ent-alist unit-key)) + (nth 0 (vhdl-aget conf-alist unit-key)) + (nth 0 (vhdl-aget pack-alist unit-key)))) (insert "\n" unit-key) (unless (equal unit-key unit-name) (insert " \\\n" unit-name)) commit 11cf3e90c62e197c600a32f9c226294255abd7a5 Author: Lars Magne Ingebrigtsen Date: Tue Dec 9 07:20:53 2014 +0100 Implement a new function directory-files-recursively * doc/lispref/files.texi (Contents of Directories): Document directory-files-recursively. * etc/NEWS: Mention directory-files-recursively. * lisp/files.el (find-files): New function. diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index d8215be..e7b5606 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,8 @@ +2014-12-09 Lars Magne Ingebrigtsen + + * files.texi (Contents of Directories): Document + directory-files-recursively. + 2014-12-04 Eli Zaretskii * display.texi (Bidirectional Display): Document diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index ac77b94..92bb718 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2605,6 +2605,14 @@ An error is signaled if @var{directory} is not the name of a directory that can be read. @end defun +@defun directory-files-recursively directory match &optional include-directories +Return all files under @var{directory} whose file names match +@var{match} recursively. The file names are returned ``depth first'', +meaning that contents of sub-directories are returned before contents +of the directories. If @var{include-directories} is non-@code{nil}, +also return directory names that have matching names. +@end defun + @defun directory-files-and-attributes directory &optional full-name match-regexp nosort id-format This is similar to @code{directory-files} in deciding which files to report on and how to report their names. However, instead diff --git a/etc/ChangeLog b/etc/ChangeLog index 309c01f..9ac0d00 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2014-12-09 Lars Magne Ingebrigtsen + + * NEWS: Mention directory-files-recursively. + 2014-12-08 Lars Magne Ingebrigtsen * NEWS: Mention the new eww `S' command. diff --git a/etc/NEWS b/etc/NEWS index 4bca9e9..58a5836 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -137,6 +137,9 @@ buffers to allow certain parts of the text to be writable. to all the files and subdirectories of a directory, similarly to the C library function `ftw'. +** A new function `directory-files-recursively' returns all matching +files (recursively) under a directory. + * Editing Changes in Emacs 25.1 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cadb209..9c044c3 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2014-12-09 Lars Magne Ingebrigtsen + * files.el (find-files): New function. + * net/shr.el (shr-dom-print): Don't print comments. (shr-tag-svg): Give inline SVG images the right type. diff --git a/lisp/files.el b/lisp/files.el index 0f54a22..5127519 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -762,6 +762,27 @@ prevented. Directory entries are sorted with string-lessp." (file-name-nondirectory dir) args)))) +(defun directory-files-recursively (dir match &optional include-directories) + "Return all files under DIR that have file names matching MATCH (a regexp). +This function works recursively. Files are returned in \"depth first\" +and alphabetical order. +If INCLUDE-DIRECTORIES, also include directories that have matching names." + (let ((result nil) + (files nil)) + (dolist (file (directory-files dir t)) + (let ((leaf (file-name-nondirectory file))) + (unless (member leaf '("." "..")) + (if (file-directory-p file) + (progn + (when (and include-directories + (string-match match leaf)) + (push file files)) + (setq result (nconc result (directory-files-recursively + file match include-directories)))) + (when (string-match match leaf) + (push file files)))))) + (nconc result (nreverse files)))) + (defun load-file (file) "Load the Lisp file named FILE." ;; This is a case where .elc makes a lot of sense. commit 931f6fb6f5928f5c2fa7ec2b1984590095dfc1c7 Author: Glenn Morris Date: Mon Dec 8 21:20:10 2014 -0800 Correct ChangeLog attribution Ref thread: http://lists.gnu.org/archive/html/emacs-devel/2014-12/msg00306.html diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 54ada6e..cadb209 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -257,7 +257,7 @@ * progmodes/elisp-mode.el (elisp--local-variables): Don't burp on incorrect lexical elements (bug#19250). -2014-12-03 Eric S. Raymond +2014-12-03 A. N. Other * files.el (file-tree-walk): Lisp translation of ANSI ftw(3). commit d790c4de3bfab465b34c011d7a29e725b7c261d5 Author: Glenn Morris Date: Mon Dec 8 20:46:38 2014 -0800 biditest: Change maintainer to emacs-devel rather than FSF. The same thing was done for other files a while ago. diff --git a/test/biditest.el b/test/biditest.el index 4dd3a8c..53820bb 100644 --- a/test/biditest.el +++ b/test/biditest.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2013-2014 Free Software Foundation, Inc. ;; Author: Eli Zaretskii -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Package: emacs ;; This program is free software: you can redistribute it and/or modify commit c3ea511964facdd86cc41c15f352e995a8061820 Author: Lars Magne Ingebrigtsen Date: Tue Dec 9 05:18:12 2014 +0100 Make inline SVGs work in shr again * net/shr.el (shr-dom-print): Don't print comments. (shr-tag-svg): Give inline SVG images the right type. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e2dbe92..54ada6e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2014-12-09 Lars Magne Ingebrigtsen + * net/shr.el (shr-dom-print): Don't print comments. + (shr-tag-svg): Give inline SVG images the right type. + * net/eww.el (eww-update-header-line-format): Mark valid/invalid certificates in the header line. (eww-invalid-certificate, eww-valid-certificate): New faces. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e23fd0b..186c9f5 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1019,6 +1019,8 @@ ones, in case fg and bg are nil." (cond ((stringp elem) (insert elem)) + ((eq (dom-tag elem) 'comment) + ) ((or (not (eq (dom-tag elem) 'image)) ;; Filter out blocked elements inside the SVG image. (not (setq url (dom-attr elem ':xlink:href))) @@ -1031,7 +1033,8 @@ ones, in case fg and bg are nil." (defun shr-tag-svg (dom) (when (and (image-type-available-p 'svg) (not shr-inhibit-images)) - (funcall shr-put-image-function (shr-dom-to-xml dom) "SVG Image"))) + (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml) + "SVG Image"))) (defun shr-tag-sup (dom) (let ((start (point))) commit a005f610188cb025216b101f06b66fae026053d8 Author: Lars Magne Ingebrigtsen Date: Tue Dec 9 04:21:57 2014 +0100 Make eww mark valid/invalid https pages * lisp/net/eww.el (eww-update-header-line-format): Mark valid/invalid certificates in the header line. (eww-invalid-certificate, eww-valid-certificate): New faces. diff --git a/etc/NEWS b/etc/NEWS index 2b40777..4bca9e9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -228,6 +228,10 @@ details. *** The new `S' command will list all eww buffers, and allow managing them. +--- +*** https pages with valid certificates have headers marked in green, while +invalid certificates are marked in red. + ** Message mode *** text/html messages that contain inline image parts will be diff --git a/lisp/ChangeLog b/lisp/ChangeLog index df057ac..e2dbe92 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2014-12-09 Lars Magne Ingebrigtsen + + * net/eww.el (eww-update-header-line-format): Mark valid/invalid + certificates in the header line. + (eww-invalid-certificate, eww-valid-certificate): New faces. + 2014-12-09 Fabián Ezequiel Gallina * progmodes/python.el (inferior-python-mode): Set diff --git a/lisp/net/eww.el b/lisp/net/eww.el index ed88c00..c6d3bbc 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -199,6 +199,20 @@ See also `eww-form-checkbox-selected-symbol'." :version "24.4" :group 'eww) +(defface eww-invalid-certificate + '((default :weight bold) + (((class color)) :foreground "red")) + "Face for web pages with invalid certificates." + :version "25.1" + :group 'eww) + +(defface eww-valid-certificate + '((default :weight bold) + (((class color)) :foreground "ForestGreen")) + "Face for web pages with valid certificates." + :version "25.1" + :group 'eww) + (defvar eww-data nil) (defvar eww-history nil) (defvar eww-history-position 0) @@ -300,6 +314,9 @@ See the `eww-search-prefix' variable for the search engine used." "text/html")) "utf-8")))) (data-buffer (current-buffer))) + ;; Save the https peer status. + (with-current-buffer buffer + (plist-put eww-data :peer (plist-get status :peer))) (unwind-protect (progn (cond @@ -444,16 +461,25 @@ See the `eww-search-prefix' variable for the search engine used." (put-text-property start (point) 'keymap eww-link-keymap))) (defun eww-update-header-line-format () - (if eww-header-line-format - (setq header-line-format - (replace-regexp-in-string - "%" "%%" - ;; FIXME? Title can be blank. Default to, eg, last component - ;; of url? - (format-spec eww-header-line-format - `((?u . ,(or (plist-get eww-data :url) "")) - (?t . ,(or (plist-get eww-data :title) "")))))) - (setq header-line-format nil))) + (setq header-line-format + (and eww-header-line-format + (let ((title (plist-get eww-data :title)) + (peer (plist-get eww-data :peer))) + (when (zerop (length title)) + (setq title "[untitled]")) + ;; This connection has is https. + (when peer + (setq title + (propertize title 'face + (if (plist-get peer :warnings) + 'eww-invalid-certificate + 'eww-valid-certificate)))) + (replace-regexp-in-string + "%" "%%" + (format-spec + eww-header-line-format + `((?u . ,(or (plist-get eww-data :url) "")) + (?t . ,title)))))))) (defun eww-tag-title (dom) (plist-put eww-data :title commit 0cc8da5cd8f3a4d7c19501a018cf2a38f86c509b Author: Lars Magne Ingebrigtsen Date: Tue Dec 9 04:21:12 2014 +0100 Make the https logic in url-http work on redirects (url-http-parse-headers): When being redirected, make sure we flush the previous certificate. diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index d544cf0..690f699 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -2,6 +2,8 @@ * url-http.el (url-http-parse-headers): Pass the GnuTLS status of the connection to the caller. + (url-http-parse-headers): When being redirected, make sure we + flush the previous certificate. 2014-12-08 Stefan Monnier diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index f5a214a..34d325a 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -494,12 +494,14 @@ should be shown to the user." (url-http-mark-connection-as-free (url-host url-current-object) (url-port url-current-object) url-http-process) - ;; Pass the certificate on to the caller. + ;; Pass the https certificate on to the caller. (when (gnutls-available-p) - (when-let (status (gnutls-peer-status url-http-process)) - (setcar url-callback-arguments - (plist-put (car url-callback-arguments) - :peer status)))) + (let ((status (gnutls-peer-status url-http-process))) + (when (or status + (plist-get (car url-callback-arguments) :peer)) + (setcar url-callback-arguments + (plist-put (car url-callback-arguments) + :peer status))))) (if (or (not (boundp 'url-http-end-of-headers)) (not url-http-end-of-headers)) (error "Trying to parse headers in odd buffer: %s" (buffer-name))) commit d7e5255013e0d784865e03a1acb6d663c30f0907 Author: Lars Magne Ingebrigtsen Date: Tue Dec 9 03:59:48 2014 +0100 Make URL pass the TLS peer status to the caller * lisp/url/url-http.el (url-http-parse-headers): Pass the GnuTLS status of the connection to the caller. diff --git a/etc/NEWS b/etc/NEWS index 56036f8..2b40777 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -328,6 +328,10 @@ a function. to specify that we're running in a noninteractive context, and that we should not be queried about things like TLS certificate validity. +*** If URL is used with a https connection, the first callback argument +plist will contain a :peer element that has the output of +`gnutls-peer-status' (if Emacs is built with GnuTLS support). + ** Tramp *** New connection method "nc", which allows to access dumb busyboxes. diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index b39c67e..d544cf0 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,8 @@ +2014-12-09 Lars Magne Ingebrigtsen + + * url-http.el (url-http-parse-headers): Pass the GnuTLS status of + the connection to the caller. + 2014-12-08 Stefan Monnier * url-http.el (url-http-activate-callback): Make debug more verbose. diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 3d5b6be..f5a214a 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -25,7 +25,9 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) (defvar url-callback-arguments) (defvar url-callback-function) @@ -492,7 +494,12 @@ should be shown to the user." (url-http-mark-connection-as-free (url-host url-current-object) (url-port url-current-object) url-http-process) - + ;; Pass the certificate on to the caller. + (when (gnutls-available-p) + (when-let (status (gnutls-peer-status url-http-process)) + (setcar url-callback-arguments + (plist-put (car url-callback-arguments) + :peer status)))) (if (or (not (boundp 'url-http-end-of-headers)) (not url-http-end-of-headers)) (error "Trying to parse headers in odd buffer: %s" (buffer-name))) commit afa1d80fe03b8ca9af62158b563d6429b51b7ee1 Author: Fabián Ezequiel Gallina Date: Mon Dec 8 22:19:37 2014 -0300 python.el: Don't change `comint-prompt-read-only' globally Fixes: debbugs:19288 * lisp/progmodes/python.el (inferior-python-mode): Set `comint-prompt-read-only` to `t` only locally. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2669e07..df057ac 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2014-12-09 Fabián Ezequiel Gallina + + * progmodes/python.el (inferior-python-mode): Set + `comint-prompt-read-only` to `t` only locally. + 2014-12-08 Lars Magne Ingebrigtsen * net/nsm.el (nsm-check-protocol): Test for RC4 on `high'. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 33c822a..63597d5 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -2441,8 +2441,8 @@ variable. (set (make-local-variable 'python-shell--prompt-calculated-input-regexp) nil) (set (make-local-variable 'python-shell--prompt-calculated-output-regexp) nil) (python-shell-prompt-set-calculated-regexps) - (setq comint-prompt-regexp python-shell--prompt-calculated-input-regexp - comint-prompt-read-only t) + (setq comint-prompt-regexp python-shell--prompt-calculated-input-regexp) + (set (make-local-variable 'comint-prompt-read-only) t) (setq mode-line-process '(":%s")) (set (make-local-variable 'comint-output-filter-functions) '(ansi-color-process-output commit 09ef13993b7a650039eb884c694660b17e61bb5c Author: Matt Curtis Date: Tue Dec 9 00:57:12 2014 +0100 (pulse-momentary-highlight-one-line): Respect POINT Fixes: debbugs:17260 * lisp/cedet/pulse.el (pulse-momentary-highlight-one-line): Respect the POINT argument. diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index d797132..c132a42 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Matt Curtis (tiny change) + + * pulse.el (pulse-momentary-highlight-one-line): Respect the POINT + argument (bug#17260). + 2014-11-09 Eric Ludlam * semantic.el (semantic-mode): Add/remove 3 diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index e2a48a4..10ede62 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -227,13 +227,15 @@ Optional argument FACE specifies the face to do the highlighting." (defun pulse-momentary-highlight-one-line (point &optional face) "Highlight the line around POINT, unhighlighting before next command. Optional argument FACE specifies the face to do the highlighting." - (let ((start (point-at-bol)) - (end (save-excursion - (end-of-line) - (when (not (eobp)) - (forward-char 1)) - (point)))) - (pulse-momentary-highlight-region start end face))) + (save-excursion + (goto-char point) + (let ((start (point-at-bol)) + (end (save-excursion + (end-of-line) + (when (not (eobp)) + (forward-char 1)) + (point)))) + (pulse-momentary-highlight-region start end face)))) (defun pulse-momentary-highlight-region (start end &optional face) "Highlight between START and END, unhighlighting before next command. commit e9aaf969661d134fa7e1548817fc9a05fa6b1bfb Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 22:51:54 2014 +0100 Make NSM warn on `high' for older protocols, and document * doc/emacs/misc.texi (Network Security): Mention the new protocol-level `high' NSM checks. (nsm-check-protocol): Also warn if using SSL3 or older. diff --git a/doc/emacs/ChangeLog b/doc/emacs/ChangeLog index 458a478..d969b8e 100644 --- a/doc/emacs/ChangeLog +++ b/doc/emacs/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * misc.texi (Network Security): Mention the new protocol-level + `high' NSM checks. + 2014-12-08 Eric S. Raymond * maintaining.texi: Suopport fo Arch has been moved to obolte, diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 39632cb..3943305 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -329,6 +329,20 @@ to be concerned about. However, if you are worried that your network connections are being hijacked by agencies who have access to pliable Certificate Authorities which issue new certificates for third-party services, you may want to keep track of these changes. + +@item Diffie-Hellman low prime bits +When doing the public key exchange, the number of ``prime bits'' +should be high to ensure that the channel can't be eavesdropped on by +third parties. If this number is too low, you will be warned. + +@item @acronym{RC4} stream cipher +The @acronym{RC4} stream cipher is believed to be of low quality and +may allow eavesdropping by third parties. + +@item @acronym{SSL1}, @acronym{SSL2} and @acronym{SSL3} +The protocols older than @acronym{TLS1.0} are believed to be +vulnerable to a variety of attacks, and you may want to avoid using +these if what you're doing requires higher security. @end table Finally, if @code{network-security-level} is @code{paranoid}, you will diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c109bc7..2669e07 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -3,6 +3,7 @@ * net/nsm.el (nsm-check-protocol): Test for RC4 on `high'. (nsm-format-certificate): Include more data about the connection. (nsm-query): Fill the text to that it looks nicer. + (nsm-check-protocol): Also warn if using SSL3 or older. 2014-12-08 Stefan Monnier diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index d1de128..2306894 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -181,7 +181,8 @@ unencrypted." (encryption (format "%s-%s-%s" (plist-get status :key-exchange) (plist-get status :cipher) - (plist-get status :mac)))) + (plist-get status :mac))) + (protocol (plist-get status :protocol))) (cond ((and prime-bits (< prime-bits 1024) @@ -203,6 +204,16 @@ unencrypted." host port encryption))) (delete-process process) nil) + ((and protocol + (string-match "SSL" protocol) + (not (memq :ssl (plist-get settings :conditions))) + (not + (nsm-query + host port status :ssl + "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." + host port protocol))) + (delete-process process) + nil) (t process)))) commit be6767d59b9f984ee28d444aada0ecdd0245ec6e Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 22:40:57 2014 +0100 Make the NSM prompting have more data (nsm-format-certificate): Include more data about the connection. (nsm-query): Fill the text to that it looks nicer. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 696a42b..c109bc7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,6 +1,8 @@ 2014-12-08 Lars Magne Ingebrigtsen * net/nsm.el (nsm-check-protocol): Test for RC4 on `high'. + (nsm-format-certificate): Include more data about the connection. + (nsm-query): Fill the text to that it looks nicer. 2014-12-08 Stefan Monnier diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 16e07ff..d1de128 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -164,7 +164,7 @@ unencrypted." (if (and (not (nsm-warnings-ok-p status settings)) (not (nsm-query host port status 'conditions - "The TLS connection to %s:%s is insecure\nfor the following reason%s:\n\n%s" + "The TLS connection to %s:%s is insecure for the following reason%s:\n\n%s" host port (if (> (length warnings) 1) "s" "") @@ -190,7 +190,7 @@ unencrypted." (not (nsm-query host port status :diffie-hellman-prime-bits - "The Diffie-Hellman prime bits (%s) used for this connection to\n%s:%s\nis less than what is considered safe (%s)." + "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." prime-bits host port 1024))) (delete-process process) nil) @@ -200,7 +200,9 @@ unencrypted." (nsm-query host port status :rc4 "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." - host port encryption)))) + host port encryption))) + (delete-process process) + nil) (t process)))) @@ -217,7 +219,7 @@ unencrypted." (setq did-query (nsm-query host port status 'fingerprint - "The fingerprint for the connection to %s:%s has changed from\n%s to\n%s" + "The fingerprint for the connection to %s:%s has changed from %s to %s" host port (plist-get settings :fingerprint) (nsm-fingerprint status))))) @@ -232,7 +234,7 @@ unencrypted." (defun nsm-new-fingerprint-ok-p (host port status) (nsm-query host port status 'fingerprint - "The fingerprint for the connection to %s:%s is new:\n%s" + "The fingerprint for the connection to %s:%s is new: %s" host port (nsm-fingerprint status))) @@ -246,7 +248,7 @@ unencrypted." (not (nsm-query host port nil 'conditions - "The connection to %s:%s used to be an encrypted\nconnection, but is now unencrypted. This might mean that there's a\nman-in-the-middle tapping this connection." + "The connection to %s:%s used to be an encrypted connection, but is now unencrypted. This might mean that there's a man-in-the-middle tapping this connection." host port))) (delete-process process) nil) @@ -285,7 +287,12 @@ unencrypted." (erase-buffer) (when (> (length cert) 0) (insert cert "\n")) - (insert (apply 'format message args)))) + (let ((start (point))) + (insert (apply 'format message args)) + (goto-char start) + ;; Fill the first line of the message, which usually + ;; contains lots of explanatory text. + (fill-region (point) (line-end-position))))) (let ((responses '((?n . no) (?s . session) (?a . always))) @@ -418,6 +425,15 @@ unencrypted." (insert "Public key:" (plist-get cert :public-key-algorithm) ", signature: " (plist-get cert :signature-algorithm) "\n")) + (when (and (plist-get status :key-exchange) + (plist-get status :cipher) + (plist-get status :mac) + (plist-get status :protocol)) + (insert + "Protocol:" (plist-get status :protocol) + ", key: " (plist-get status :key-exchange) + ", cipher: " (plist-get status :cipher) + ", mac: " (plist-get status :mac) "\n")) (when (plist-get cert :certificate-security-level) (insert "Security level:" commit 7befee11a8f114c43614ad20c3d470e202deb8dc Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 22:23:41 2014 +0100 * lisp/net/nsm.el (nsm-check-protocol): Test for RC4 on `high'. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 62a603b..696a42b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * net/nsm.el (nsm-check-protocol): Test for RC4 on `high'. + 2014-12-08 Stefan Monnier * progmodes/gud.el (gud-gdb-completions): Remove unused var `start'. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 659f969..16e07ff 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -177,7 +177,11 @@ unencrypted." process)))))) (defun nsm-check-protocol (process host port status settings) - (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))) + (let ((prime-bits (plist-get status :diffie-hellman-prime-bits)) + (encryption (format "%s-%s-%s" + (plist-get status :key-exchange) + (plist-get status :cipher) + (plist-get status :mac)))) (cond ((and prime-bits (< prime-bits 1024) @@ -186,10 +190,17 @@ unencrypted." (not (nsm-query host port status :diffie-hellman-prime-bits - "The Diffie-Hellman prime bits (%s) used for this connection to\n%s:%s\nis less than what is considerer safe (%s)." + "The Diffie-Hellman prime bits (%s) used for this connection to\n%s:%s\nis less than what is considered safe (%s)." prime-bits host port 1024))) (delete-process process) nil) + ((and (string-match "\\bRC4\\b" encryption) + (not (memq :rc4 (plist-get settings :conditions))) + (not + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." + host port encryption)))) (t process)))) commit ad67503f50b8d2c443e63cb16863b39ad8345567 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 22:18:59 2014 +0100 Make gnutls-peer-status return even more data * src/gnutls.c (Fgnutls_peer_status): Return the key exchange, cipher and MAC algorithms. diff --git a/src/ChangeLog b/src/ChangeLog index 8a5f677..b65fbb5 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * gnutls.c (Fgnutls_peer_status): Return the key exchange, cipher + and MAC algorithms. + 2014-12-08 Stefan Monnier * process.c: Whitespace and line-break nitpicks. diff --git a/src/gnutls.c b/src/gnutls.c index ca82c7a..46ef211 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -186,11 +186,22 @@ DEF_GNUTLS_FN (int, gnutls_x509_crt_get_key_id, (gnutls_x509_crt_t, unsigned int, unsigned char *, size_t *_size)); DEF_GNUTLS_FN (const char*, gnutls_sec_param_get_name, (gnutls_sec_param_t)); -DEF_GNUTLS_FN (const char*, gnutls_sign_get_name, - (gnutls_sign_algorithm_t)); +DEF_GNUTLS_FN (const char*, gnutls_sign_get_name, (gnutls_sign_algorithm_t)); DEF_GNUTLS_FN (int, gnutls_server_name_set, (gnutls_session_t, gnutls_server_name_type_t, const void *, size_t)); +DEF_GNUTLS_FN (gnutls_kx_algorithm_t, gnutls_kx_get, (gnutls_session_t)); +DEF_GNUTLS_FN (const char*, gnutls_kx_get_name, (gnutls_kx_algorithm_t)); +DEF_GNUTLS_FN (gnutls_protocol_t, gnutls_protocol_get_version, + (gnutls_session_t)); +DEF_GNUTLS_FN (const char*, gnutls_protocol_get_version, (gnutls_protocol_t)); +DEF_GNUTLS_FN (gnutls_cipher_algorithm_t, gnutls_cipher_get, + (gnutls_session_t)); +DEF_GNUTLS_FN (const char*, gnutls_cipher_get_name, + (gnutls_cipher_algorithm_t)); +DEF_GNUTLS_FN (gnutls_mac_algorithm_t, gnutls_mac_get, (gnutls_session_t)); +DEF_GNUTLS_FN (const char*, gnutls_mac_get_name, (gnutls_mac_algorithm_t)); + static bool init_gnutls_functions (void) @@ -269,6 +280,14 @@ init_gnutls_functions (void) LOAD_GNUTLS_FN (library, gnutls_sec_param_get_name); LOAD_GNUTLS_FN (library, gnutls_sign_get_name); LOAD_GNUTLS_FN (library, gnutls_server_name_set); + LOAD_GNUTLS_FN (library, gnutls_kx_get); + LOAD_GNUTLS_FN (library, gnutls_kx_get_name); + LOAD_GNUTLS_FN (library, gnutls_protocol_get_version); + LOAD_GNUTLS_FN (library, gnutls_protocol_get_name); + LOAD_GNUTLS_FN (library, gnutls_cipher_get); + LOAD_GNUTLS_FN (library, gnutls_cipher_get_name); + LOAD_GNUTLS_FN (library, gnutls_mac_get); + LOAD_GNUTLS_FN (library, gnutls_mac_get_name); max_log_level = global_gnutls_log_level; @@ -342,7 +361,15 @@ init_gnutls_functions (void) #define fn_gnutls_x509_crt_get_key_id gnutls_x509_crt_get_key_id #define fn_gnutls_sec_param_get_name gnutls_sec_param_get_name #define fn_gnutls_sign_get_name gnutls_sign_get_name -#define fn_gnutls_server_name_set gnutls_server_name_set +#define fn_gnutls_server_name_set gnutls_server_name_set +#define fn_gnutls_kx_get gnutls_kx_get +#define fn_gnutls_kx_get_name gnutls_kx_get_name +#define fn_gnutls_protocol_get_version gnutls_protocol_get_version +#define fn_gnutls_protocol_get_name gnutls_protocol_get_name +#define fn_gnutls_cipher_get gnutls_cipher_get +#define fn_gnutls_cipher_get_name gnutls_cipher_get_name +#define fn_gnutls_mac_get gnutls_mac_get +#define fn_gnutls_mac_get_name gnutls_mac_get_name #endif /* !WINDOWSNT */ @@ -998,6 +1025,7 @@ The return value is a property list with top-level keys :warnings and { Lisp_Object warnings = Qnil, result = Qnil; unsigned int verification; + gnutls_session_t state; CHECK_PROCESS (proc); @@ -1042,15 +1070,41 @@ The return value is a property list with top-level keys :warnings and (intern (":certificate"), gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate))); + state = XPROCESS (proc)->gnutls_state; + /* Diffie-Hellman prime bits. */ { - int bits = fn_gnutls_dh_get_prime_bits (XPROCESS (proc)->gnutls_state); + int bits = fn_gnutls_dh_get_prime_bits (state); if (bits > 0) - result = nconc2 (result, list2 - (intern (":diffie-hellman-prime-bits"), - make_number (bits))); + result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"), + make_number (bits))); } + /* Key exchange. */ + result = nconc2 + (result, list2 (intern (":key-exchange"), + build_string (fn_gnutls_kx_get_name + (fn_gnutls_kx_get (state))))); + + /* Protocol name. */ + result = nconc2 + (result, list2 (intern (":protocol"), + build_string (fn_gnutls_protocol_get_name + (fn_gnutls_protocol_get_version (state))))); + + /* Cipler name. */ + result = nconc2 + (result, list2 (intern (":cipher"), + build_string (fn_gnutls_cipher_get_name + (fn_gnutls_cipher_get (state))))); + + /* MAC name. */ + result = nconc2 + (result, list2 (intern (":mac"), + build_string (fn_gnutls_mac_get_name + (fn_gnutls_mac_get (state))))); + + return result; } commit 8665a748f946dc9a49bb2753373bb39ac72a6bc2 Author: Eric S. Raymond Date: Mon Dec 8 15:30:49 2014 -0500 maintaining.texi: Suopport fo Arch has been moved to obolte. Remove references that imply otherwise. diff --git a/doc/emacs/ChangeLog b/doc/emacs/ChangeLog index bc81e17..458a478 100644 --- a/doc/emacs/ChangeLog +++ b/doc/emacs/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Eric S. Raymond + + * maintaining.texi: Suopport fo Arch has been moved to obolte, + remove references that imply otherwise. + 2014-11-29 Paul Eggert Lessen focus on ChangeLog files, as opposed to change log entries. diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 8a06439..5fb1551 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -31,11 +31,11 @@ versions of a source file, storing information such as the creation time of each version, who made it, and a description of what was changed. - The Emacs version control interface is called @dfn{VC}@. VC commands -work with several different version control systems; currently, it -supports GNU Arch, Bazaar, CVS, Git, Mercurial, Monotone, RCS, + The Emacs version control interface is called @dfn{VC}@. VC +commands work with several different version control systems; +currently, it supports Bazaar, CVS, Git, Mercurial, Monotone, RCS, SCCS/CSSC, and Subversion. Of these, the GNU project distributes CVS, -Arch, RCS, and Bazaar. +RCS, and Bazaar. VC is enabled automatically whenever you visit a file governed by a version control system. To disable VC entirely, set the customizable @@ -163,14 +163,6 @@ similar to CVS but without its problems (e.g., it supports atomic commits of filesets, and versioning of directories, symbolic links, meta-data, renames, copies, and deletes). -@cindex GNU Arch -@cindex Arch -@item -GNU Arch is one of the earliest @dfn{decentralized} version control -systems (the other being Monotone). @xref{VCS Concepts}, for a -description of decentralized version control systems. It is no longer -under active development, and has been deprecated in favor of Bazaar. - @cindex git @item Git is a decentralized version control system originally invented by @@ -280,8 +272,8 @@ number and severity of conflicts that actually occur. SCCS always uses locking. RCS is lock-based by default but can be told to operate in a merging style. CVS and Subversion are merge-based by default but can be told to operate in a locking mode. -Decentralized version control systems, such as GNU Arch, Git, and -Mercurial, are exclusively merging-based. +Decentralized version control systems, such as Git and Mercurial, are +exclusively merging-based. VC mode supports both locking and merging version control. The terms ``commit'' and ``update'' are used in newer version control commit d81562f58302d7214910aacdfec2ee630a41c087 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 21:09:10 2014 +0100 (Fgnutls_error_fatalp): Doc fix (bug#18210) Fixes: debbugs:18210 diff --git a/src/ChangeLog b/src/ChangeLog index 6aec429..8a5f677 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -13,6 +13,7 @@ which was removed by mistake. (emacs_gnutls_handle_error): Fatal errors should be on level 1, so that they are not messaged by default (bug#16253). + (Fgnutls_error_fatalp): Doc fix (bug#18210). * gnutls.c: Add Windows specs for gnutls_dh_get_prime_bits. diff --git a/src/gnutls.c b/src/gnutls.c index 16f2f6c..ca82c7a 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -688,9 +688,9 @@ usage: (gnutls-errorp ERROR) */) } DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0, - doc: /* Check if ERROR is fatal. + doc: /* Return non-nil if ERROR is fatal. ERROR is an integer or a symbol with an integer `gnutls-code' property. -usage: (gnutls-error-fatalp ERROR) */) +Usage: (gnutls-error-fatalp ERROR) */) (Lisp_Object err) { Lisp_Object code; commit b76bea4c2639ee78b345d50a0f6ce5d10e2253ac Author: Stefan Monnier Date: Mon Dec 8 15:02:26 2014 -0500 Various minor details accumulated over time * lisp/info.el (Info-mode-map): Remove left-over binding. * lisp/net/tramp.el (tramp-handle-make-symbolic-link): Mark unused arg. * lisp/obsolete/gulp.el (gulp-create-m-p-alist): Remove unused var `mnt-tm'. * lisp/progmodes/gud.el (gud-gdb-completions): Remove unused var `start'. * lisp/url/url-http.el (url-http-activate-callback): Make debug more verbose. * src/process.c: Whitespace and line-break nitpicks. diff --git a/ChangeLog b/ChangeLog index 026ae89..88654dc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -8692,7 +8692,7 @@ * configure.in (HAVE_XIM): Define if XIM is available. -2003-07-29 Tim Van Holder (tiny change) +2003-07-29 Tim Van Holder * configure.in: The function gtk_window_set_icon_from_file was introduced in GTK+ 2.2, so check for that release. @@ -8926,7 +8926,7 @@ * configure.in (*-sunos5.8*, *-solaris2.8*): New configurations. -2002-11-11 Tim Van Holder (tiny change) +2002-11-11 Tim Van Holder * Makefile.in (install-arch-indep): Prepend $(srcdir)/ to lisp. diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog index 5260ed0..ab67538 100644 --- a/lib-src/ChangeLog +++ b/lib-src/ChangeLog @@ -3011,7 +3011,7 @@ filter), show help instead of blindingly dumping every single ChangeLog available. Doc fix. Update version. -2006-11-02 Tim Van Holder (tiny change) +2006-11-02 Tim Van Holder * emacsclient.c [WINDOWSNT]: Define HAVE_INET_SOCKETS. [!WINDOWSNT]: Include if available. @@ -3036,7 +3036,7 @@ (set_tcp_socket): Prefer O_NONBLOCK, then O_NDELAY, then FIONBIO to set the socket in non-blocking mode. -2006-10-31 Tim Van Holder (tiny change) +2006-10-31 Tim Van Holder * emacsclient.c [!WINDOWSNT]: Include and . (INVALID_SOCKET): Define. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ec0a8c4..62a603b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,13 @@ 2014-12-08 Stefan Monnier + * progmodes/gud.el (gud-gdb-completions): Remove unused var `start'. + + * obsolete/gulp.el (gulp-create-m-p-alist): Remove unused var `mnt-tm'. + + * net/tramp.el (tramp-handle-make-symbolic-link): Mark unused arg. + + * info.el (Info-mode-map): Remove left-over binding. + * emacs-lisp/avl-tree.el: Use lexical-binding and cl-lib. (avl-tree--root): Remove redundant defsetf. diff --git a/lisp/ChangeLog.10 b/lisp/ChangeLog.10 index bcd2dac..6e65e4c 100644 --- a/lisp/ChangeLog.10 +++ b/lisp/ChangeLog.10 @@ -8452,7 +8452,7 @@ * vc-sccs.el (vc-sccs-registered): Improve comment. -2002-11-13 Tim Van Holder (tiny change) +2002-11-13 Tim Van Holder * progmodes/compile.el (compilation-error-regexp-alist): Don't include colon and space after a file name as part of the name. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 84d92c2..f22ca69 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -472,6 +472,11 @@ maintainer-clean: distclean bootstrap-clean check-declare: $(emacs) -l check-declare --eval '(check-declare-directory "$(lisp)")' +check-defun-dups: + sed -n -e '/^(defun /s/\(.\)(.*/\1/p' \ + $$(find . -name '*.el' -print | grep -v 'loaddefs\.el') \ + | sort | uniq -d + # Dependencies ## None of the following matters for bootstrap, which is the only way diff --git a/lisp/info.el b/lisp/info.el index 2a8ba90..7c4d7f3 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4013,7 +4013,6 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "," 'Info-index-next) (define-key map "\177" 'Info-scroll-down) (define-key map [mouse-2] 'Info-mouse-follow-nearest-node) - (define-key map [down-mouse-2] 'ignore) ;Override potential global binding. (define-key map [follow-link] 'mouse-face) (define-key map [XF86Back] 'Info-history-back) (define-key map [XF86Forward] 'Info-history-forward) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index fc9950d..2cf9d45 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3226,7 +3226,7 @@ User is always nil." t))) (defun tramp-handle-make-symbolic-link - (filename linkname &optional ok-if-already-exists) + (filename linkname &optional _ok-if-already-exists) "Like `make-symbolic-link' for Tramp files." (with-parsed-tramp-file-name (if (tramp-tramp-file-p filename) filename linkname) nil diff --git a/lisp/obsolete/gulp.el b/lisp/obsolete/gulp.el index 00cb896..66394b4 100644 --- a/lisp/obsolete/gulp.el +++ b/lisp/obsolete/gulp.el @@ -137,7 +137,7 @@ is left in the `*gulp*' buffer at the end." "Create the maintainer/package alist for files in FLIST in DIR. That is a list of elements, each of the form (MAINTAINER PACKAGES...)." (save-excursion - (let (mplist filen node mnt-tm mnt tm fl-tm) + (let (mplist filen node mnt tm fl-tm) (get-buffer-create gulp-tmp-buffer) (set-buffer gulp-tmp-buffer) (setq buffer-undo-list t) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 24d5469..a12bdd9 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -803,8 +803,7 @@ directory and source-file directory for your debugger." "Completion table for GDB commands. COMMAND is the prefix for which we seek completion. CONTEXT is the text before COMMAND on the line." - (let* ((start (- (point) (field-beginning))) - (complete-list + (let* ((complete-list (gud-gdb-run-command-fetch-lines (concat "complete " context command) (current-buffer) ;; From string-match above. diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index 18fc2a1..b39c67e 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,7 @@ +2014-12-08 Stefan Monnier + + * url-http.el (url-http-activate-callback): Make debug more verbose. + 2014-12-05 Stefan Monnier * url-future.el (url-future-done-p, url-future-completed-p) @@ -21,8 +25,8 @@ 2014-11-05 Teodor Zlatanov * url-http.el (url-user-agent): New variable, can be function or - string. Suggested by Vibhav Pant . Add - :version. (Bug#16498) + string. Suggested by Vibhav Pant . + Add :version. (Bug#16498) (url-http-user-agent-string): Use it. diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 1001c4d..3d5b6be 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -892,7 +892,8 @@ should be shown to the user." (url-http-mark-connection-as-free (url-host url-current-object) (url-port url-current-object) url-http-process) - (url-http-debug "Activating callback in buffer (%s)" (buffer-name)) + (url-http-debug "Activating callback in buffer (%s): %S %S" + (buffer-name) url-callback-function url-callback-arguments) (apply url-callback-function url-callback-arguments)) ;; ) diff --git a/src/ChangeLog b/src/ChangeLog index 314c653..6aec429 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2014-12-08 Stefan Monnier + + * process.c: Whitespace and line-break nitpicks. + 2014-12-08 Lars Magne Ingebrigtsen * gnutls.c (gnutls_certificate_details): The :signature isn't diff --git a/src/process.c b/src/process.c index 6eae516..7283df4 100644 --- a/src/process.c +++ b/src/process.c @@ -326,10 +326,10 @@ static int max_process_desc; /* The largest descriptor currently in use for input; -1 if none. */ static int max_input_desc; -/* Indexed by descriptor, gives the process (if any) for that descriptor */ +/* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; -/* Alist of elements (NAME . PROCESS) */ +/* Alist of elements (NAME . PROCESS). */ static Lisp_Object Vprocess_alist; /* Buffered-ahead input char from process, indexed by channel. @@ -456,7 +456,7 @@ static struct fd_callback_data void *data; #define FOR_READ 1 #define FOR_WRITE 2 - int condition; /* mask of the defines above. */ + int condition; /* Mask of the defines above. */ } fd_callback_info[FD_SETSIZE]; @@ -691,8 +691,8 @@ allocate_pty (char pty_name[PTY_NAME_SIZE]) have a race condition between the PTY_OPEN and here. */ fcntl (fd, F_SETFD, FD_CLOEXEC); #endif - /* check to make certain that both sides are available - this avoids a nasty yet stupid bug in rlogins */ + /* Check to make certain that both sides are available + this avoids a nasty yet stupid bug in rlogins. */ #ifdef PTY_TTY_NAME_SPRINTF PTY_TTY_NAME_SPRINTF #else @@ -1343,7 +1343,7 @@ Returns nil if format of ADDRESS is invalid. */) && XINT (p->contents[i]) > 255) return Qnil; - args[i+1] = p->contents[i]; + args[i + 1] = p->contents[i]; } return Fformat (nargs + 1, args); @@ -1723,7 +1723,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) if (inchannel > max_process_desc) max_process_desc = inchannel; - /* This may signal an error. */ + /* This may signal an error. */ setup_process_coding_systems (process); block_input (); @@ -1996,7 +1996,7 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, int len) { struct sockaddr_in6 *sin6 = (struct sockaddr_in6 *) sa; uint16_t *ip6 = (uint16_t *) &sin6->sin6_addr; - len = sizeof (sin6->sin6_addr)/2 + 1; + len = sizeof (sin6->sin6_addr) / 2 + 1; address = Fmake_vector (make_number (len), Qnil); p = XVECTOR (address); p->contents[--len] = make_number (ntohs (sin6->sin6_port)); @@ -2207,14 +2207,14 @@ Returns nil upon error setting address, ADDRESS otherwise. */) static const struct socket_options { /* The name of this option. Should be lowercase version of option - name without SO_ prefix. */ + name without SO_ prefix. */ const char *name; - /* Option level SOL_... */ + /* Option level SOL_... */ int optlevel; - /* Option number SO_... */ + /* Option number SO_... */ int optnum; enum { SOPT_UNKNOWN, SOPT_BOOL, SOPT_INT, SOPT_IFNAME, SOPT_LINGER } opttype; - enum { OPIX_NONE=0, OPIX_MISC=1, OPIX_REUSEADDR=2 } optbit; + enum { OPIX_NONE = 0, OPIX_MISC = 1, OPIX_REUSEADDR = 2 } optbit; } socket_options[] = { #ifdef SO_BINDTODEVICE @@ -2290,7 +2290,7 @@ set_socket_option (int s, Lisp_Object opt, Lisp_Object val) #ifdef SO_BINDTODEVICE case SOPT_IFNAME: { - char devname[IFNAMSIZ+1]; + char devname[IFNAMSIZ + 1]; /* This is broken, at least in the Linux 2.4 kernel. To unbind, the arg must be a zero integer, not the empty string. @@ -2667,7 +2667,7 @@ usage: (make-serial-process &rest ARGS) */) exactly like a normal process when reading and writing. Primary differences are in status display and process deletion. A network connection has no PID; you cannot signal it. All you can do is - stop/continue it and deactivate/close it via delete-process */ + stop/continue it and deactivate/close it via delete-process. */ DEFUN ("make-network-process", Fmake_network_process, Smake_network_process, 0, MANY, 0, @@ -2871,7 +2871,7 @@ usage: (make-network-process &rest ARGS) */) GCPRO1 (contact); #ifdef WINDOWSNT - /* Ensure socket support is loaded if available. */ + /* Ensure socket support is loaded if available. */ init_winsock (TRUE); #endif @@ -2978,7 +2978,7 @@ usage: (make-network-process &rest ARGS) */) { if (EQ (host, Qlocal)) /* Depending on setup, "localhost" may map to different IPv4 and/or - IPv6 addresses, so it's better to be explicit. (Bug#6781) */ + IPv6 addresses, so it's better to be explicit (Bug#6781). */ host = build_string ("127.0.0.1"); CHECK_STRING (host); } @@ -3110,7 +3110,7 @@ usage: (make-network-process &rest ARGS) */) address_in.sin_family = family; } else - /* Attempt to interpret host as numeric inet address */ + /* Attempt to interpret host as numeric inet address. */ { unsigned long numeric_addr; numeric_addr = inet_addr (SSDATA (host)); @@ -3176,8 +3176,8 @@ usage: (make-network-process &rest ARGS) */) /* Parse network options in the arg list. We simply ignore anything which isn't a known option (including other keywords). An error is signaled if setting a known option fails. */ - for (optn = optbits = 0; optn < nargs-1; optn += 2) - optbits |= set_socket_option (s, args[optn], args[optn+1]); + for (optn = optbits = 0; optn < nargs - 1; optn += 2) + optbits |= set_socket_option (s, args[optn], args[optn + 1]); if (is_server) { @@ -3248,7 +3248,7 @@ usage: (make-network-process &rest ARGS) */) { /* Unlike most other syscalls connect() cannot be called again. (That would return EALREADY.) The proper way to - wait for completion is pselect(). */ + wait for completion is pselect(). */ int sc; socklen_t len; fd_set fdset; @@ -3626,7 +3626,7 @@ static const struct ifflag_def ifflag_table[] = { #endif #ifdef IFF_NOTRAILERS #ifdef NS_IMPL_COCOA - /* Really means smart, notrailers is obsolete */ + /* Really means smart, notrailers is obsolete. */ { IFF_NOTRAILERS, "smart" }, #else { IFF_NOTRAILERS, "notrailers" }, @@ -3654,19 +3654,19 @@ static const struct ifflag_def ifflag_table[] = { { IFF_DYNAMIC, "dynamic" }, #endif #ifdef IFF_OACTIVE - { IFF_OACTIVE, "oactive" }, /* OpenBSD: transmission in progress */ + { IFF_OACTIVE, "oactive" }, /* OpenBSD: transmission in progress. */ #endif #ifdef IFF_SIMPLEX - { IFF_SIMPLEX, "simplex" }, /* OpenBSD: can't hear own transmissions */ + { IFF_SIMPLEX, "simplex" }, /* OpenBSD: can't hear own transmissions. */ #endif #ifdef IFF_LINK0 - { IFF_LINK0, "link0" }, /* OpenBSD: per link layer defined bit */ + { IFF_LINK0, "link0" }, /* OpenBSD: per link layer defined bit. */ #endif #ifdef IFF_LINK1 - { IFF_LINK1, "link1" }, /* OpenBSD: per link layer defined bit */ + { IFF_LINK1, "link1" }, /* OpenBSD: per link layer defined bit. */ #endif #ifdef IFF_LINK2 - { IFF_LINK2, "link2" }, /* OpenBSD: per link layer defined bit */ + { IFF_LINK2, "link2" }, /* OpenBSD: per link layer defined bit. */ #endif { 0, 0 } }; @@ -3882,7 +3882,7 @@ deactivate_process (Lisp_Object proc) } #endif - /* Beware SIGCHLD hereabouts. */ + /* Beware SIGCHLD hereabouts. */ for (i = 0; i < PROCESS_OPEN_FDS; i++) close_process_fd (&p->open_fd[i]); @@ -3997,10 +3997,10 @@ is nil, from any process) before the timeout expired. */) return ((wait_reading_process_output (secs, nsecs, 0, 0, - Qnil, - !NILP (process) ? XPROCESS (process) : NULL, - NILP (just_this_one) ? 0 : - !INTEGERP (just_this_one) ? 1 : -1) + Qnil, + !NILP (process) ? XPROCESS (process) : NULL, + (NILP (just_this_one) ? 0 + : !INTEGERP (just_this_one) ? 1 : -1)) <= 0) ? Qnil : Qt); } @@ -4014,7 +4014,7 @@ server_accept_connection (Lisp_Object server, int channel) { Lisp_Object proc, caller, name, buffer; Lisp_Object contact, host, service; - struct Lisp_Process *ps= XPROCESS (server); + struct Lisp_Process *ps = XPROCESS (server); struct Lisp_Process *p; int s; union u_sockaddr { @@ -4347,7 +4347,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, { /* A negative timeout means gobble output available now - but don't wait at all. */ + but don't wait at all. */ timeout = make_timespec (0, 0); } @@ -4506,11 +4506,11 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, break; } - /* Wait till there is something to do */ + /* Wait till there is something to do. */ if (wait_proc && just_wait_proc) { - if (wait_proc->infd < 0) /* Terminated */ + if (wait_proc->infd < 0) /* Terminated. */ break; FD_SET (wait_proc->infd, &Available); check_delay = 0; @@ -4641,7 +4641,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else { - /* Check this specific channel. */ + /* Check this specific channel. */ if (wait_proc->gnutls_p /* Check for valid process. */ && wait_proc->gnutls_state /* Do we have pending data? */ @@ -4661,7 +4661,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, xerrno = errno; - /* Make C-g and alarm signals set flags again */ + /* Make C-g and alarm signals set flags again. */ clear_waiting_for_input (); /* If we woke up due to SIGWINCH, actually change size now. */ @@ -4680,9 +4680,9 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, report_file_errno ("Failed select", Qnil, xerrno); } - /* Check for keyboard input */ + /* Check for keyboard input. */ /* If there is any, return immediately - to give it higher priority than subprocesses */ + to give it higher priority than subprocesses. */ if (read_kbd != 0) { @@ -5691,7 +5691,7 @@ return t unconditionally. */) return Qt; } -/* send a signal number SIGNO to PROCESS. +/* Send a signal number SIGNO to PROCESS. If CURRENT_GROUP is t, that means send to the process group that currently owns the terminal being used to communicate with PROCESS. This is used for various commands in shell mode. @@ -5794,11 +5794,11 @@ process_send_signal (Lisp_Object process, int signo, Lisp_Object current_group, Or perhaps this is vestigial. */ if (gid == -1) no_pgrp = 1; -#else /* ! defined (TIOCGPGRP ) */ +#else /* ! defined (TIOCGPGRP) */ /* Can't select pgrps on this system, so we know that the child itself heads the pgrp. */ gid = p->pid; -#endif /* ! defined (TIOCGPGRP ) */ +#endif /* ! defined (TIOCGPGRP) */ /* If current_group is lambda, and the shell owns the terminal, don't send any signal. */ @@ -5980,8 +5980,8 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) Lisp_Object tem = Fget_process (process); if (NILP (tem)) { - Lisp_Object process_number = - string_to_number (SSDATA (process), 10, 1); + Lisp_Object process_number + = string_to_number (SSDATA (process), 10, 1); if (INTEGERP (process_number) || FLOATP (process_number)) tem = process_number; } @@ -6164,7 +6164,7 @@ static signal_handler_t volatile lib_child_handler; Inc. ** Malloc WARNING: This should never call malloc either directly or - indirectly; if it does, that is a bug */ + indirectly; if it does, that is a bug. */ static void handle_child_signal (int sig) @@ -6237,7 +6237,7 @@ handle_child_signal (int sig) #ifdef NS_IMPL_GNUSTEP /* NSTask in GNUstep sets its child handler each time it is called. So we must re-set ours. */ - catch_child_signal(); + catch_child_signal (); #endif } @@ -6769,7 +6769,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, xerrno = errno; - /* Make C-g and alarm signals set flags again */ + /* Make C-g and alarm signals set flags again. */ clear_waiting_for_input (); /* If we woke up due to SIGWINCH, actually change size now. */ @@ -6789,7 +6789,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, report_file_errno ("Failed select", Qnil, xerrno); } - /* Check for keyboard input */ + /* Check for keyboard input. */ if (read_kbd && detect_input_pending_run_timers (do_display)) @@ -6858,7 +6858,7 @@ add_timer_wait_descriptor (int fd) void add_keyboard_wait_descriptor (int desc) { -#ifdef subprocesses /* actually means "not MSDOS" */ +#ifdef subprocesses /* Actually means "not MSDOS". */ FD_SET (desc, &input_wait_mask); FD_SET (desc, &non_process_wait_mask); if (desc > max_input_desc) @@ -6949,7 +6949,7 @@ the process output. */) } /* Kill all processes associated with `buffer'. - If `buffer' is nil, kill all processes */ + If `buffer' is nil, kill all processes. */ void kill_buffer_processes (Lisp_Object buffer) commit e0e2f363e86f8581191640324296fdebd2520d7c Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 20:57:40 2014 +0100 Fatal GnuTLS errors are now silent by default Fixes: debbugs:16253 (emacs_gnutls_handle_error): Fatal errors should be on level 1, so that they are not messaged by default. diff --git a/etc/NEWS b/etc/NEWS index 2cd41df..56036f8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -310,6 +310,10 @@ plain text parts, if display of HTML email is possible; customize the ** In sh-mode, you can now use `sh-shell' as a file-local variable to specify the type of shell in use (bash, csh, etc). +** TLS +--- +*** Fatal TLS errors are now silent by default. + ** URL *** The URL package accepts now the protocols "ssh", "scp" and "rsync". diff --git a/src/ChangeLog b/src/ChangeLog index 64d8052..314c653 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -7,6 +7,8 @@ the connection. (gnutls_certificate_details): Put :signature-algorithm back again, which was removed by mistake. + (emacs_gnutls_handle_error): Fatal errors should be on level 1, so + that they are not messaged by default (bug#16253). * gnutls.c: Add Windows specs for gnutls_dh_get_prime_bits. diff --git a/src/gnutls.c b/src/gnutls.c index 9ddc8e1..16f2f6c 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -571,7 +571,7 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err) if (fn_gnutls_error_is_fatal (err)) { ret = 0; - GNUTLS_LOG2 (0, max_log_level, "fatal error:", str); + GNUTLS_LOG2 (1, max_log_level, "fatal error:", str); } else { commit 28057ef3b598529cb15afcee57ef16ef6aa3bf2f Author: Stefan Monnier Date: Mon Dec 8 14:49:17 2014 -0500 * lisp/emacs-lisp/avl-tree.el: Use lexical-binding and cl-lib. (avl-tree--root): Remove redundant defsetf. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b9903ac..ec0a8c4 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Stefan Monnier + + * emacs-lisp/avl-tree.el: Use lexical-binding and cl-lib. + (avl-tree--root): Remove redundant defsetf. + 2014-12-08 Lars Magne Ingebrigtsen * net/nsm.el (network-security-level): Remove the detailed @@ -10,8 +15,8 @@ * net/eww.el (eww-buffers-mode): New major mode. (eww-list-buffers, eww-buffer-select, eww-buffer-show-next) - (eww-buffer-show-previous, eww-buffer-kill, eww-buffer-show): New - commands/functions (bug#19131). + (eww-buffer-show-previous, eww-buffer-kill, eww-buffer-show): + New commands/functions (bug#19131). 2014-12-08 Lars Magne Ingebrigtsen @@ -38,7 +43,7 @@ 2014-12-07 Ivan Shmakov - * net/eww.el (eww): Moved history recording here... + * net/eww.el (eww): Move history recording here... (eww-browse-url): ... from here (bug#19253). * net/eww.el (eww-browse-url): Use generate-new-buffer (was: diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 813576e..4348480 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,4 +1,4 @@ -;;; avl-tree.el --- balanced binary trees, AVL-trees +;;; avl-tree.el --- balanced binary trees, AVL-trees -*- lexical-binding:t -*- ;; Copyright (C) 1995, 2007-2014 Free Software Foundation, Inc. @@ -27,23 +27,23 @@ ;;; Commentary: -;; An AVL tree is a self-balancing binary tree. As such, inserting, +;; An AVL tree is a self-balancing binary tree. As such, inserting, ;; deleting, and retrieving data from an AVL tree containing n elements -;; is O(log n). It is somewhat more rigidly balanced than other +;; is O(log n). It is somewhat more rigidly balanced than other ;; self-balancing binary trees (such as red-black trees and AA trees), ;; making insertion slightly slower, deletion somewhat slower, and ;; retrieval somewhat faster (the asymptotic scaling is of course the -;; same for all types). Thus it may be a good choice when the tree will +;; same for all types). Thus it may be a good choice when the tree will ;; be relatively static, i.e. data will be retrieved more often than ;; they are modified. ;; ;; Internally, a tree consists of two elements, the root node and the -;; comparison function. The actual tree has a dummy node as its root +;; comparison function. The actual tree has a dummy node as its root ;; with the real root in the left pointer, which allows the root node to ;; be treated on a par with all other nodes. ;; ;; Each node of the tree consists of one data element, one left -;; sub-tree, one right sub-tree, and a balance count. The latter is the +;; sub-tree, one right sub-tree, and a balance count. The latter is the ;; difference in depth of the left and right sub-trees. ;; ;; The functions with names of the form "avl-tree--" are intended for @@ -51,7 +51,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) @@ -62,7 +62,7 @@ ;; ---------------------------------------------------------------- ;; Functions and macros handling an AVL tree. -(defstruct (avl-tree- +(cl-defstruct (avl-tree- ;; A tagged list is the pre-defstruct representation. ;; (:type list) :named @@ -77,15 +77,10 @@ ;; Return the root node for an AVL tree. INTERNAL USE ONLY. `(avl-tree--node-left (avl-tree--dummyroot ,tree))) -(defsetf avl-tree--root (tree) (node) - `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) - - - ;; ---------------------------------------------------------------- ;; Functions and macros handling an AVL tree node. -(defstruct (avl-tree--node +(cl-defstruct (avl-tree--node ;; We force a representation without tag so it matches the ;; pre-defstruct representation. Also we use the underlying ;; representation in the implementation of @@ -97,7 +92,7 @@ left right data balance) -(defalias 'avl-tree--node-branch 'aref +(defalias 'avl-tree--node-branch #'aref ;; This implementation is efficient but breaks the defstruct ;; abstraction. An alternative could be (funcall (aref [avl-tree-left ;; avl-tree-right avl-tree-data] branch) node) @@ -109,7 +104,7 @@ NODE is the node, and BRANCH is the branch. ;; The funcall/aref trick wouldn't work for the setf method, unless we ;; tried to access the underlying setter function, but this wouldn't be ;; portable either. -(defsetf avl-tree--node-branch aset) +(gv-define-simple-setter avl-tree--node-branch aset) @@ -297,7 +292,8 @@ Return t if the height of the tree has grown." (if (< (* sgn b2) 0) sgn 0) (avl-tree--node-branch node branch) p2)) (setf (avl-tree--node-balance - (avl-tree--node-branch node branch)) 0) + (avl-tree--node-branch node branch)) + 0) nil)))) (defun avl-tree--do-enter (cmpfun root branch data &optional updatefun) @@ -346,7 +342,7 @@ inserted data." (if (null node) 0 (let ((dl (avl-tree--check-node (avl-tree--node-left node))) (dr (avl-tree--check-node (avl-tree--node-right node)))) - (assert (= (- dr dl) (avl-tree--node-balance node))) + (cl-assert (= (- dr dl) (avl-tree--node-balance node))) (1+ (max dl dr))))) ;; ---------------------------------------------------------------- @@ -391,7 +387,7 @@ itself." (avl-tree--node-data root) (avl-tree--node-balance root)))) -(defstruct (avl-tree--stack +(cl-defstruct (avl-tree--stack (:constructor nil) (:constructor avl-tree--stack-create (tree &optional reverse @@ -403,7 +399,7 @@ itself." (:copier nil)) reverse store) -(defalias 'avl-tree-stack-p 'avl-tree--stack-p +(defalias 'avl-tree-stack-p #'avl-tree--stack-p "Return t if argument is an avl-tree-stack, nil otherwise.") (defun avl-tree--stack-repopulate (stack) @@ -420,12 +416,12 @@ itself." ;;; The public functions which operate on AVL trees. ;; define public alias for constructors so that we can set docstring -(defalias 'avl-tree-create 'avl-tree--create +(defalias 'avl-tree-create #'avl-tree--create "Create an empty AVL tree. COMPARE-FUNCTION is a function which takes two arguments, A and B, and returns non-nil if A is less than B, and nil otherwise.") -(defalias 'avl-tree-compare-function 'avl-tree--cmpfun +(defalias 'avl-tree-compare-function #'avl-tree--cmpfun "Return the comparison function for the AVL tree TREE. \(fn TREE)") @@ -505,7 +501,7 @@ previously specified in `avl-tree-create' when TREE was created." (not (eq (avl-tree-member tree data flag) flag)))) -(defun avl-tree-map (__map-function__ tree &optional reverse) +(defun avl-tree-map (fun tree &optional reverse) "Modify all elements in the AVL tree TREE by applying FUNCTION. Each element is replaced by the return value of FUNCTION applied @@ -516,12 +512,12 @@ descending order if REVERSE is non-nil." (avl-tree--mapc (lambda (node) (setf (avl-tree--node-data node) - (funcall __map-function__ (avl-tree--node-data node)))) + (funcall fun (avl-tree--node-data node)))) (avl-tree--root tree) (if reverse 1 0))) -(defun avl-tree-mapc (__map-function__ tree &optional reverse) +(defun avl-tree-mapc (fun tree &optional reverse) "Apply FUNCTION to all elements in AVL tree TREE, for side-effect only. @@ -529,13 +525,13 @@ FUNCTION is applied to the elements in ascending order, or descending order if REVERSE is non-nil." (avl-tree--mapc (lambda (node) - (funcall __map-function__ (avl-tree--node-data node))) + (funcall fun (avl-tree--node-data node))) (avl-tree--root tree) (if reverse 1 0))) (defun avl-tree-mapf - (__map-function__ combinator tree &optional reverse) + (fun combinator tree &optional reverse) "Apply FUNCTION to all elements in AVL tree TREE, and combine the results using COMBINATOR. @@ -546,7 +542,7 @@ order, or descending order if REVERSE is non-nil." (lambda (node) (setq avl-tree-mapf--accumulate (funcall combinator - (funcall __map-function__ + (funcall fun (avl-tree--node-data node)) avl-tree-mapf--accumulate))) (avl-tree--root tree) @@ -554,7 +550,7 @@ order, or descending order if REVERSE is non-nil." (nreverse avl-tree-mapf--accumulate))) -(defun avl-tree-mapcar (__map-function__ tree &optional reverse) +(defun avl-tree-mapcar (fun tree &optional reverse) "Apply FUNCTION to all elements in AVL tree TREE, and make a list of the results. @@ -568,7 +564,7 @@ then (avl-tree-mapf function 'cons tree (not reverse)) is more efficient." - (nreverse (avl-tree-mapf __map-function__ 'cons tree reverse))) + (nreverse (avl-tree-mapf fun 'cons tree reverse))) (defun avl-tree-first (tree) @@ -605,7 +601,7 @@ is more efficient." "Return the number of elements in TREE." (let ((treesize 0)) (avl-tree--mapc - (lambda (data) (setq treesize (1+ treesize))) + (lambda (_) (setq treesize (1+ treesize))) (avl-tree--root tree) 0) treesize)) commit b7768d785f1fb8a93619b926ddb56d59ef8b81a0 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 20:41:05 2014 +0100 (nsm-check-protocol): Check for weak Diffie-Hellman prime bits. Fixes: debbugs:19153 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d40b56f..b9903ac 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -3,6 +3,8 @@ * net/nsm.el (network-security-level): Remove the detailed description, which was already outdated, and refer the users to the manual. + (nsm-check-protocol): Check for weak Diffie-Hellman prime bits + (bug#19153). 2014-12-06 Andrey Kotlarski diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 5bc32b4..659f969 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -115,6 +115,14 @@ unencrypted." process)))))) (defun nsm-check-tls-connection (process host port status settings) + (let ((process (nsm-check-certificate process host port status settings))) + (if (and process + (>= (nsm-level network-security-level) (nsm-level 'high))) + ;; Do further protocol-level checks if the security is high. + (nsm-check-protocol process host port status settings) + process))) + +(defun nsm-check-certificate (process host port status settings) (let ((warnings (plist-get status :warnings))) (cond @@ -168,6 +176,23 @@ unencrypted." nil) process)))))) +(defun nsm-check-protocol (process host port status settings) + (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))) + (cond + ((and prime-bits + (< prime-bits 1024) + (not (memq :diffie-hellman-prime-bits + (plist-get settings :conditions))) + (not + (nsm-query + host port status :diffie-hellman-prime-bits + "The Diffie-Hellman prime bits (%s) used for this connection to\n%s:%s\nis less than what is considerer safe (%s)." + prime-bits host port 1024))) + (delete-process process) + nil) + (t + process)))) + (defun nsm-fingerprint (status) (plist-get (plist-get status :certificate) :public-key-id)) @@ -284,14 +309,23 @@ unencrypted." (nconc saved (list :host (format "%s:%s" host port)))) ;; We either want to save/update the fingerprint or the conditions ;; of the certificate/unencrypted connection. - (when (eq what 'conditions) + (cond + ((eq what 'conditions) (nconc saved (list :host (format "%s:%s" host port))) (cond ((not status) - (nconc saved `(:conditions (:unencrypted)))) + (nconc saved '(:conditions (:unencrypted)))) ((plist-get status :warnings) (nconc saved - `(:conditions ,(plist-get status :warnings)))))) + (list :conditions (plist-get status :warnings)))))) + ((not (eq what 'fingerprint)) + ;; Store additional protocol settings. + (let ((settings (nsm-host-settings id))) + (when settings + (setq saved settings)) + (if (plist-get saved :conditions) + (nconc (plist-get saved :conditions) (list what)) + (nconc saved (list :conditions (list what))))))) (if (eq permanency 'always) (progn (nsm-remove-temporary-setting id) commit 7c6750264774350e6182aef39793554d4342d439 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 20:09:31 2014 +0100 * src/gnutls.c: Add Windows specs for gnutls_dh_get_prime_bits. diff --git a/src/ChangeLog b/src/ChangeLog index e4ba2c9..64d8052 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -8,6 +8,8 @@ (gnutls_certificate_details): Put :signature-algorithm back again, which was removed by mistake. + * gnutls.c: Add Windows specs for gnutls_dh_get_prime_bits. + 2014-12-07 Jan Djärv * nsimage.m (setPixmapData): Make bmRep local so class member is not diff --git a/src/gnutls.c b/src/gnutls.c index 3893f4d..9ddc8e1 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -115,6 +115,7 @@ DEF_GNUTLS_FN (int, gnutls_credentials_set, DEF_GNUTLS_FN (void, gnutls_deinit, (gnutls_session_t)); DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits, (gnutls_session_t, unsigned int)); +DEF_GNUTLS_FN (int, gnutls_dh_get_prime_bits, (gnutls_session_t)); DEF_GNUTLS_FN (int, gnutls_error_is_fatal, (int)); DEF_GNUTLS_FN (int, gnutls_global_init, (void)); DEF_GNUTLS_FN (void, gnutls_global_set_log_function, (gnutls_log_func)); @@ -221,6 +222,7 @@ init_gnutls_functions (void) LOAD_GNUTLS_FN (library, gnutls_credentials_set); LOAD_GNUTLS_FN (library, gnutls_deinit); LOAD_GNUTLS_FN (library, gnutls_dh_set_prime_bits); + LOAD_GNUTLS_FN (library, gnutls_dh_get_prime_bits); LOAD_GNUTLS_FN (library, gnutls_error_is_fatal); LOAD_GNUTLS_FN (library, gnutls_global_init); LOAD_GNUTLS_FN (library, gnutls_global_set_log_function); @@ -299,6 +301,7 @@ init_gnutls_functions (void) #define fn_gnutls_credentials_set gnutls_credentials_set #define fn_gnutls_deinit gnutls_deinit #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits +#define fn_gnutls_dh_get_prime_bits gnutls_dh_get_prime_bits #define fn_gnutls_error_is_fatal gnutls_error_is_fatal #define fn_gnutls_global_init gnutls_global_init #define fn_gnutls_global_set_log_function gnutls_global_set_log_function @@ -1041,7 +1044,7 @@ The return value is a property list with top-level keys :warnings and /* Diffie-Hellman prime bits. */ { - int bits = gnutls_dh_get_prime_bits (XPROCESS (proc)->gnutls_state); + int bits = fn_gnutls_dh_get_prime_bits (XPROCESS (proc)->gnutls_state); if (bits > 0) result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"), commit 6b1ab80ef9b65c08e53edc7fa8ec4418da296ca7 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 20:06:50 2014 +0100 `network-security-level' documentation simplification * lisp/net/nsm.el (network-security-level): Remove the detailed description, which was already outdated, and refer the users to the manual. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1ca7c87..d40b56f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * net/nsm.el (network-security-level): Remove the detailed + description, which was already outdated, and refer the users to + the manual. + 2014-12-06 Andrey Kotlarski * net/eww.el (eww-buffers-mode): New major mode. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 067de55..5bc32b4 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -43,22 +43,13 @@ connection should be handled. The following values are possible: `low': Absolutely no checks are performed. +`medium': This is the default level, should be reasonable for most usage. +`high': This warns about additional things that many people would +not find useful. +`paranoid': On this level, the user is queried for most new connections. -`medium': This is the default level, and the following things will -be prompted for. - -* invalid, self-signed or otherwise unverifiable certificates -* whether a previously accepted unverifiable certificate has changed -* when a connection that was previously protected by STARTTLS is - now unencrypted - -`high': In addition to the above. - -* any certificate that changes its public key - -`paranoid': In addition to the above. - -* any new certificate that you haven't seen before" +See the Emacs manual for a description of all things that are +checked and warned against." :version "25.1" :group 'nsm :type '(choice (const :tag "Low" low) commit ca7ad4271c3b01efdcf0a64ec1ec8b789ed026fd Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 19:58:39 2014 +0100 Put back :signature-algorithm into gnutls.c (gnutls_certificate_details): Put :signature-algorithm back again, which was removed by mistake. diff --git a/src/ChangeLog b/src/ChangeLog index b791d18..e4ba2c9 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -5,6 +5,8 @@ (gnutls_certificate_details): Clean up whitespace slightly. (Fgnutls_peer_status): Return the Diffie-Hellman prime bits for the connection. + (gnutls_certificate_details): Put :signature-algorithm back again, + which was removed by mistake. 2014-12-07 Jan Djärv diff --git a/src/gnutls.c b/src/gnutls.c index 2006bbc..3893f4d 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -910,6 +910,16 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) } #endif + /* Signature. */ + err = fn_gnutls_x509_crt_get_signature_algorithm (cert); + if (err >= GNUTLS_E_SUCCESS) + { + const char *name = fn_gnutls_sign_get_name (err); + if (name) + res = nconc2 (res, list2 (intern (":signature-algorithm"), + build_string (name))); + } + /* Public key ID. */ buf_size = 0; err = fn_gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size); commit a0fe9b0481eb85667e99b987070af13311a95e54 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 19:48:38 2014 +0100 (Fgnutls_peer_status): Return the DH prime bits for the connection diff --git a/src/ChangeLog b/src/ChangeLog index 70b1bb0..b791d18 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -3,6 +3,8 @@ * gnutls.c (gnutls_certificate_details): The :signature isn't that useful, so remove it. (gnutls_certificate_details): Clean up whitespace slightly. + (Fgnutls_peer_status): Return the Diffie-Hellman prime bits for + the connection. 2014-12-07 Jan Djärv diff --git a/src/gnutls.c b/src/gnutls.c index c4d85a2..2006bbc 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1029,6 +1029,15 @@ The return value is a property list with top-level keys :warnings and (intern (":certificate"), gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate))); + /* Diffie-Hellman prime bits. */ + { + int bits = gnutls_dh_get_prime_bits (XPROCESS (proc)->gnutls_state); + if (bits > 0) + result = nconc2 (result, list2 + (intern (":diffie-hellman-prime-bits"), + make_number (bits))); + } + return result; } commit c498441ee63747386e0055717d79b09f6d8a7209 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 19:40:50 2014 +0100 (gnutls_certificate_details): Clean up whitespace slightly. diff --git a/src/ChangeLog b/src/ChangeLog index 0ed30a8..70b1bb0 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -2,6 +2,7 @@ * gnutls.c (gnutls_certificate_details): The :signature isn't that useful, so remove it. + (gnutls_certificate_details): Clean up whitespace slightly. 2014-12-07 Jan Djärv diff --git a/src/gnutls.c b/src/gnutls.c index 13730bd..c4d85a2 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -797,6 +797,7 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) { Lisp_Object res = Qnil; int err; + size_t buf_size; /* Version. */ { @@ -807,37 +808,30 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) } /* Serial. */ - { - size_t serial_size = 0; - - err = fn_gnutls_x509_crt_get_serial (cert, NULL, &serial_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - char *serial = malloc (serial_size); - err = fn_gnutls_x509_crt_get_serial (cert, serial, &serial_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":serial-number"), - gnutls_hex_string (serial, serial_size, - ""))); - free (serial); - } - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_serial (cert, NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + char *serial = malloc (buf_size); + err = fn_gnutls_x509_crt_get_serial (cert, serial, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":serial-number"), + gnutls_hex_string (serial, buf_size, ""))); + free (serial); + } /* Issuer. */ - { - size_t dn_size = 0; - - err = fn_gnutls_x509_crt_get_issuer_dn (cert, NULL, &dn_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - char *dn = malloc (dn_size); - err = fn_gnutls_x509_crt_get_issuer_dn (cert, dn, &dn_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":issuer"), - make_string (dn, dn_size))); - free (dn); - } - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_issuer_dn (cert, NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + char *dn = malloc (buf_size); + err = fn_gnutls_x509_crt_get_issuer_dn (cert, dn, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":issuer"), + make_string (dn, buf_size))); + free (dn); + } /* Validity. */ { @@ -857,20 +851,17 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) } /* Subject. */ - { - size_t dn_size = 0; - - err = fn_gnutls_x509_crt_get_dn (cert, NULL, &dn_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - char *dn = malloc (dn_size); - err = fn_gnutls_x509_crt_get_dn (cert, dn, &dn_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":subject"), - make_string (dn, dn_size))); - free (dn); - } - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_dn (cert, NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + char *dn = malloc (buf_size); + err = fn_gnutls_x509_crt_get_dn (cert, dn, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":subject"), + make_string (dn, buf_size))); + free (dn); + } /* Versions older than 2.11 doesn't have these four functions. */ #if GNUTLS_VERSION_NUMBER >= 0x020b00 @@ -894,69 +885,60 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) } /* Unique IDs. */ - { - size_t buf_size = 0; - - err = fn_gnutls_x509_crt_get_issuer_unique_id (cert, NULL, &buf_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - char *buf = malloc (buf_size); - err = fn_gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":issuer-unique-id"), - make_string (buf, buf_size))); - free (buf); - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_issuer_unique_id (cert, NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + char *buf = malloc (buf_size); + err = fn_gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":issuer-unique-id"), + make_string (buf, buf_size))); + free (buf); + } - buf_size = 0; - err = fn_gnutls_x509_crt_get_subject_unique_id (cert, NULL, &buf_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - char *buf = malloc (buf_size); - err = fn_gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":subject-unique-id"), - make_string (buf, buf_size))); - free (buf); - } - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_subject_unique_id (cert, NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + char *buf = malloc (buf_size); + err = fn_gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":subject-unique-id"), + make_string (buf, buf_size))); + free (buf); + } #endif /* Public key ID. */ - { - size_t buf_size = 0; - - err = fn_gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - unsigned char *buf = malloc (buf_size); - err = fn_gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":public-key-id"), - gnutls_hex_string ((char *)buf, - buf_size, "sha1:"))); - free (buf); - } - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + unsigned char *buf = malloc (buf_size); + err = fn_gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":public-key-id"), + gnutls_hex_string ((char *)buf, + buf_size, "sha1:"))); + free (buf); + } /* Certificate fingerprint. */ - { - size_t buf_size = 0; - - err = fn_gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1, - NULL, &buf_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - unsigned char *buf = malloc (buf_size); - err = fn_gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1, - buf, &buf_size); - if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":certificate-id"), - gnutls_hex_string ((char *)buf, - buf_size, "sha1:"))); - free (buf); - } - } + buf_size = 0; + err = fn_gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1, + NULL, &buf_size); + if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) + { + unsigned char *buf = malloc (buf_size); + err = fn_gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1, + buf, &buf_size); + if (err >= GNUTLS_E_SUCCESS) + res = nconc2 (res, list2 (intern (":certificate-id"), + gnutls_hex_string ((char *)buf, + buf_size, "sha1:"))); + free (buf); + } return res; } commit 172bcf6f9f9ed99e59fba2c2e6c46f18a24d2ab4 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 19:35:57 2014 +0100 Remove unused data from gnutls_certificate_details * src/gnutls.c (gnutls_certificate_details): The :signature isn't that useful, so remove it. diff --git a/src/ChangeLog b/src/ChangeLog index 9cb9270..0ed30a8 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * gnutls.c (gnutls_certificate_details): The :signature isn't + that useful, so remove it. + 2014-12-07 Jan Djärv * nsimage.m (setPixmapData): Make bmRep local so class member is not diff --git a/src/gnutls.c b/src/gnutls.c index 7c61445..13730bd 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -922,32 +922,6 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) } #endif - /* Signature. */ - { - size_t buf_size = 0; - - err = fn_gnutls_x509_crt_get_signature_algorithm (cert); - if (err >= GNUTLS_E_SUCCESS) - { - const char *name = fn_gnutls_sign_get_name (err); - if (name) - res = nconc2 (res, list2 (intern (":signature-algorithm"), - build_string (name))); - - err = fn_gnutls_x509_crt_get_signature (cert, NULL, &buf_size); - if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) - { - char *buf = malloc (buf_size); - err = fn_gnutls_x509_crt_get_signature (cert, buf, &buf_size); - if (err >= GNUTLS_E_SUCCESS) { - res = nconc2 (res, list2 (intern (":signature"), - gnutls_hex_string (buf, buf_size, ""))); - } - free (buf); - } - } - } - /* Public key ID. */ { size_t buf_size = 0; commit 09e5e01605ea84b1086dc27520bd965d7fcdf518 Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 19:30:16 2014 +0100 * etc/NEWS: Mention the new eww `S' command. diff --git a/etc/ChangeLog b/etc/ChangeLog index 2ec0e5c..309c01f 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * NEWS: Mention the new eww `S' command. + 2014-12-05 Lars Magne Ingebrigtsen * NEWS: Add some doc markers to the eww stuff. diff --git a/etc/NEWS b/etc/NEWS index 514d423..2cd41df 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -224,6 +224,10 @@ details. +++ *** `mailcap-mime-data' is now consulted when displaying PDF files. ++++ +*** The new `S' command will list all eww buffers, and allow managing +them. + ** Message mode *** text/html messages that contain inline image parts will be commit e40e63033bf7b961938c54b330137bc6bab08efe Author: Andrey Kotlarski Date: Mon Dec 8 19:29:06 2014 +0100 Commands and mode for managing multiple eww buffers Fixes: debbugs:19131 * doc/misc/eww.texi (Basics): Document managing multiple eww buffers. * lisp/net/eww.el (eww-buffers-mode): New major mode. (eww-list-buffers, eww-buffer-select, eww-buffer-show-next) (eww-buffer-show-previous, eww-buffer-kill, eww-buffer-show): New commands/functions. diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index 4d8f690..45ab792 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@ -1,3 +1,7 @@ +2014-12-08 Andrey Kotlarski + + * eww.texi (Basics): Document managing multiple eww buffers. + 2014-12-05 Lars Magne Ingebrigtsen * eww.texi (Basics): Document eww PDF viewing. diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index dd460cc..e6221ce 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -152,6 +152,13 @@ You can view stored bookmarks with @kbd{B} (@code{eww-list-bookmarks}). This will open the bookmark buffer @file{*eww bookmarks*}. +@findex eww-list-buffers +@kindex S +@cindex Multiple Buffers + To get summary of currently opened EWW buffers, press @kbd{S} +(@code{eww-list-buffers}). The @file{*eww buffers*} buffer allows to +quickly kill, flip through and switch to specific EWW buffer. + @findex eww-browse-with-external-browser @vindex shr-external-browser @vindex eww-use-external-browser-for-content-type diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 91d2bba..1ca7c87 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2014-12-06 Andrey Kotlarski + + * net/eww.el (eww-buffers-mode): New major mode. + (eww-list-buffers, eww-buffer-select, eww-buffer-show-next) + (eww-buffer-show-previous, eww-buffer-kill, eww-buffer-show): New + commands/functions (bug#19131). + 2014-12-08 Lars Magne Ingebrigtsen * net/gnutls.el (gnutls-negotiate): Ignore files found via diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 58e0ff3..ed88c00 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -623,6 +623,7 @@ the like." (define-key map "R" 'eww-readable) (define-key map "H" 'eww-list-histories) (define-key map "E" 'eww-set-character-encoding) + (define-key map "S" 'eww-list-buffers) (define-key map "b" 'eww-add-bookmark) (define-key map "B" 'eww-list-bookmarks) @@ -643,6 +644,7 @@ the like." ["View page source" eww-view-source] ["Copy page URL" eww-copy-page-url t] ["List histories" eww-list-histories t] + ["List buffers" eww-list-buffers t] ["Add bookmark" eww-add-bookmark t] ["List bookmarks" eww-list-bookmarks t] ["List cookies" url-cookie-list t] @@ -1652,6 +1654,134 @@ Differences in #targets are ignored." (setq buffer-read-only t truncate-lines t)) +;;; eww buffers list + +(defun eww-list-buffers () + "Enlist eww buffers." + (interactive) + (let (buffers-info + (current (current-buffer))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'eww-mode) + (push (vector buffer (plist-get eww-data :title) + (plist-get eww-data :url)) + buffers-info)))) + (unless buffers-info + (error "No eww buffers")) + (setq buffers-info (nreverse buffers-info)) ;more recent on top + (set-buffer (get-buffer-create "*eww buffers*")) + (eww-buffers-mode) + (let ((inhibit-read-only t) + (domain-length 0) + (title-length 0) + url title format start) + (erase-buffer) + (dolist (buffer-info buffers-info) + (setq title-length (max title-length + (length (elt buffer-info 1))) + domain-length (max domain-length + (length (elt buffer-info 2))))) + (setq format (format "%%-%ds %%-%ds" title-length domain-length) + header-line-format + (concat " " (format format "Title" "URL"))) + (let ((line 0) + (current-buffer-line 1)) + (dolist (buffer-info buffers-info) + (setq start (point) + title (elt buffer-info 1) + url (elt buffer-info 2) + line (1+ line)) + (insert (format format title url)) + (insert "\n") + (let ((buffer (elt buffer-info 0))) + (put-text-property start (1+ start) 'eww-buffer + buffer) + (when (eq current buffer) + (setq current-buffer-line line)))) + (goto-char (point-min)) + (forward-line (1- current-buffer-line))))) + (pop-to-buffer "*eww buffers*")) + +(defun eww-buffer-select () + "Switch to eww buffer." + (interactive) + (let ((buffer (get-text-property (line-beginning-position) + 'eww-buffer))) + (unless buffer + (error "No buffer on current line")) + (quit-window) + (switch-to-buffer buffer))) + +(defun eww-buffer-show () + "Display buffer under point in eww buffer list." + (let ((buffer (get-text-property (line-beginning-position) + 'eww-buffer))) + (unless buffer + (error "No buffer on current line")) + (other-window -1) + (switch-to-buffer buffer) + (other-window 1))) + +(defun eww-buffer-show-next () + "Move to next eww buffer in the list and display it." + (interactive) + (forward-line) + (when (eobp) + (goto-char (point-min))) + (eww-buffer-show)) + +(defun eww-buffer-show-previous () + "Move to previous eww buffer in the list and display it." + (interactive) + (beginning-of-line) + (when (bobp) + (goto-char (point-max))) + (forward-line -1) + (eww-buffer-show)) + +(defun eww-buffer-kill () + "Kill buffer from eww list." + (interactive) + (let* ((start (line-beginning-position)) + (buffer (get-text-property start 'eww-buffer)) + (inhibit-read-only t)) + (unless buffer + (user-error "No buffer on the current line")) + (kill-buffer buffer) + (forward-line 1) + (delete-region start (point))) + (when (eobp) + (forward-line -1)) + (eww-buffer-show)) + +(defvar eww-buffers-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'quit-window) + (define-key map [(control k)] 'eww-buffer-kill) + (define-key map "\r" 'eww-buffer-select) + (define-key map "n" 'eww-buffer-show-next) + (define-key map "p" 'eww-buffer-show-previous) + + (easy-menu-define nil map + "Menu for `eww-buffers-mode-map'." + '("Eww Buffers" + ["Exit" quit-window t] + ["Select" eww-buffer-select + :active (get-text-property (line-beginning-position) 'eww-buffer)] + ["Kill" eww-buffer-kill + :active (get-text-property (line-beginning-position) 'eww-buffer)])) + map)) + +(define-derived-mode eww-buffers-mode nil "eww buffers" + "Mode for listing buffers. + +\\{eww-buffers-mode-map}" + (buffer-disable-undo) + (setq buffer-read-only t + truncate-lines t)) + ;;; Desktop support (defvar eww-desktop-data-save commit e63c720b728e627f86da825d42dc592186429cbc Author: Lars Magne Ingebrigtsen Date: Mon Dec 8 19:13:30 2014 +0100 Make gnutls-negotiate ignore specially handled files Fixes: debbugs:15866 * lisp/net/gnutls.el (gnutls-negotiate): Ignore files found via 'file-name-handler-alist' since the gnutls library can't use those. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 03ba24a..91d2bba 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2014-12-08 Lars Magne Ingebrigtsen + + * net/gnutls.el (gnutls-negotiate): Ignore files found via + 'file-name-handler-alist' since the gnutls library can't use those + (bug#15866). + 2014-12-08 Dmitry Gutov * vc/vc-hg.el (vc-hg-dir-status-files): Only include ignores files diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index cf8e6a4..200d355 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -189,6 +189,9 @@ here's a recent version of the list. It must be omitted, a number, or nil; if omitted or nil it defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." (let* ((type (or type 'gnutls-x509pki)) + ;; The gnutls library doesn't understand files delivered via + ;; the special handlers, so ignore all files found via those. + (file-name-handler-alist nil) (trustfiles (or trustfiles (delq nil (mapcar (lambda (f) (and f (file-exists-p f) f)) commit 2354db7f53c25cfdac1b9436bbc56a54f16253f0 Author: Eli Zaretskii Date: Mon Dec 8 19:10:38 2014 +0200 Fix merge glitches in 2 ChangeLog files. diff --git a/ChangeLog b/ChangeLog index 61cada9..026ae89 100644 --- a/ChangeLog +++ b/ChangeLog @@ -19,7 +19,6 @@ * .gitignore: Remove redundant pattern (subsumed by _*). Avoid "**", as it requires Git 1.8.2 or later. -2014-12-05 Paul Eggert 2014-12-05 Eli Zaretskii * .gitignore: Ignore test/biditest.txt. diff --git a/src/ChangeLog b/src/ChangeLog index 5caa073..9cb9270 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -21,7 +21,6 @@ at once, call ns_set_represented_filename instead. 2014-12-05 Eli Zaretskii -2014-12-05 Eli Zaretskii * dispextern.h (enum bidi_dir_t): Force NEUTRAL_DIR to be zero. (struct bidi_stack): Reduce size by using bit fields and by commit 5872f843ff45de150f4b35cbc9b11e9f63c96cf2 Author: Dmitry Gutov Date: Mon Dec 8 18:24:07 2014 +0200 Fix bug#19304 Fixes: debbugs:19304 * lisp/vc/vc-hg.el (vc-hg-dir-status-files): Only include ignores files when FILES is non-nil. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f03214e..03ba24a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2014-12-08 Dmitry Gutov + + * vc/vc-hg.el (vc-hg-dir-status-files): Only include ignores files + when FILES is non-nil (bug#19304). + 2014-12-08 Eric S. Raymond * vc/vc-arch.el: Moved to obsolete directory so a test framework diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 7099def..a56ed672 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -613,9 +613,11 @@ REV is the revision to check out into WORKFILE." (declare-function vc-set-async-update "vc-dispatcher" (process-buffer)) (defun vc-hg-dir-status-files (dir files update-function) - (apply 'vc-hg-command (current-buffer) 'async dir "status" "-mardui" "-C" files) + (apply 'vc-hg-command (current-buffer) 'async dir "status" + (concat "-mardu" (if files "i")) + "-C" files) (vc-run-delayed - (vc-hg-after-dir-status update-function))) + (vc-hg-after-dir-status update-function))) (defun vc-hg-dir-extra-header (name &rest commands) (concat (propertize name 'face 'font-lock-type-face) commit 7fb8fc35ebf980ed299ce9dfd1694fa0f1ea169b Author: Eric S. Raymond Date: Mon Dec 8 06:11:49 2014 -0500 vc/vc-arch.el: Moved to obsolete directory... ...so a test framework won't trip over bit-rot in it. There has been no Arch snapshot for nine years. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a1d60d1..f03214e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2014-12-08 Eric S. Raymond + + * vc/vc-arch.el: Moved to obsolete directory so a test framework + won't trip over bit-rot in it. There has been no Arch snapshot + for nine years. + 2014-12-07 Lars Magne Ingebrigtsen * net/eww.el (eww-follow-link): Revert prefix behaviour to diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el new file mode 100644 index 0000000..d1344f2 --- /dev/null +++ b/lisp/obsolete/vc-arch.el @@ -0,0 +1,644 @@ +;;; vc-arch.el --- VC backend for the Arch version-control system -*- lexical-binding: t -*- + +;; Copyright (C) 2004-2014 Free Software Foundation, Inc. + +;; Author: FSF (see vc.el for full credits) +;; Maintainer: Stefan Monnier +;; Package: vc + +;; 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: + +;; The home page of the Arch version control system is at +;; +;; http://www.gnuarch.org/ +;; +;; This is derived from vc-mcvs.el as follows: +;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET +;; +;; Then of course started the hacking. +;; +;; What has been partly tested: +;; - Open a file. +;; - C-x v = without any prefix arg. +;; - C-x v v to commit a change to a single file. + +;; Bugs: + +;; - *vc-log*'s initial content lacks the `Summary:' lines. +;; - All files under the tree are considered as "under Arch's control" +;; without regards to =tagging-method and such. +;; - Files are always considered as `edited'. +;; - C-x v l does not work. +;; - C-x v i does not work. +;; - C-x v ~ does not work. +;; - C-x v u does not work. +;; - C-x v s does not work. +;; - C-x v r does not work. +;; - VC directory listings do not work. +;; - And more... + +;;; Code: + +(eval-when-compile (require 'vc)) + +;;; Properties of the backend + +(defun vc-arch-revision-granularity () 'repository) +(defun vc-arch-checkout-model (_files) 'implicit) + +;;; +;;; Customization options +;;; + +(defgroup vc-arch nil + "VC Arch backend." + :version "24.1" + :group 'vc) + +;; It seems Arch diff does not accept many options, so this is not +;; very useful. It exists mainly so that the VC backends are all +;; consistent with regards to their treatment of diff switches. +(defcustom vc-arch-diff-switches t + "String or list of strings specifying switches for Arch diff under VC. +If nil, use the value of `vc-diff-switches'. If t, use no switches." + :type '(choice (const :tag "Unspecified" nil) + (const :tag "None" t) + (string :tag "Argument String") + (repeat :tag "Argument List" :value ("") string)) + :version "23.1" + :group 'vc-arch) + +(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1") + +(defcustom vc-arch-program + (let ((candidates '("tla" "baz"))) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) "tla")) + "Name of the Arch executable." + :type 'string + :group 'vc-arch) + +;; Clear up the cache to force vc-call to check again and discover +;; new functions when we reload this file. +(put 'Arch 'vc-functions nil) + +;;;###autoload (defun vc-arch-registered (file) +;;;###autoload (if (vc-find-root file "{arch}/=tagging-method") +;;;###autoload (progn +;;;###autoload (load "vc-arch" nil t) +;;;###autoload (vc-arch-registered file)))) + +(defun vc-arch-add-tagline () + "Add an `arch-tag' to the end of the current file." + (interactive) + (comment-normalize-vars) + (goto-char (point-max)) + (forward-comment -1) + (skip-chars-forward " \t\n") + (cond + ((not (bolp)) (insert "\n\n")) + ((not (eq ?\n (char-before (1- (point))))) (insert "\n"))) + (let ((beg (point)) + (idfile (and buffer-file-name + (expand-file-name + (concat ".arch-ids/" + (file-name-nondirectory buffer-file-name) + ".id") + (file-name-directory buffer-file-name))))) + (insert "arch-tag: ") + (if (and idfile (file-exists-p idfile)) + ;; If the file is unreadable, we do want to get an error here. + (progn + (insert-file-contents idfile) + (forward-line 1) + (delete-file idfile)) + (condition-case nil + (call-process "uuidgen" nil t) + (file-error (insert (format "%s <%s> %s" + (current-time-string) + user-mail-address + (+ (nth 2 (current-time)) + (buffer-size))))))) + (comment-region beg (point)))) + +(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)") + +(defmacro vc-with-current-file-buffer (file &rest body) + (declare (indent 2) (debug t)) + `(let ((-kill-buf- nil) + (-file- ,file)) + (with-current-buffer (or (find-buffer-visiting -file-) + (setq -kill-buf- (generate-new-buffer " temp"))) + ;; Avoid find-file-literally since it can do many undesirable extra + ;; things (among which, call us back into an infinite loop). + (if -kill-buf- (insert-file-contents -file-)) + (unwind-protect + (progn ,@body) + (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-)))))) + +(defun vc-arch-file-source-p (file) + "Can return nil, `maybe' or a non-nil value. +Only the value `maybe' can be trusted :-(." + ;; FIXME: Check the tag and name of parent dirs. + (unless (string-match "\\`[,+]" (file-name-nondirectory file)) + (or (string-match "\\`{arch}/" + (file-relative-name file (vc-arch-root file))) + (file-exists-p + ;; Check the presence of an ID file. + (expand-file-name + (concat ".arch-ids/" (file-name-nondirectory file) ".id") + (file-name-directory file))) + ;; Check the presence of a tagline. + (vc-with-current-file-buffer file + (save-excursion + (goto-char (point-max)) + (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t) + (progn + (goto-char (point-min)) + (re-search-forward vc-arch-tagline-re (+ (point) 1000) t))))) + ;; FIXME: check =tagging-method to see whether untagged files might + ;; be source or not. + (with-current-buffer + (find-file-noselect (expand-file-name "{arch}/=tagging-method" + (vc-arch-root file))) + (let ((untagged-source t)) ;Default is `names'. + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t) + (setq untagged-source (match-end 2))) + (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t) + (setq untagged-source (match-end 2)))) + (if untagged-source 'maybe)))))) + +(defun vc-arch-file-id (file) + ;; Don't include the kind of ID this is because it seems to be too messy. + (let ((idfile (expand-file-name + (concat ".arch-ids/" (file-name-nondirectory file) ".id") + (file-name-directory file)))) + (if (file-exists-p idfile) + (with-temp-buffer + (insert-file-contents idfile) + (looking-at ".*[^ \n\t]") + (match-string 0)) + (with-current-buffer (find-file-noselect file) + (save-excursion + (goto-char (point-max)) + (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t) + (progn + (goto-char (point-min)) + (re-search-forward vc-arch-tagline-re (+ (point) 1000) t))) + (match-string 1) + (concat "./" (file-relative-name file (vc-arch-root file))))))))) + +(defun vc-arch-tagging-method (file) + (with-current-buffer + (find-file-noselect + (expand-file-name "{arch}/=tagging-method" (vc-arch-root file))) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t) + (intern (match-string 1)) + 'names)))) + +(defun vc-arch-root (file) + "Return the root directory of an Arch project, if any." + (or (vc-file-getprop file 'arch-root) + ;; Check the =tagging-method, in case someone naively manually + ;; creates a {arch} directory somewhere. + (let ((root (vc-find-root file "{arch}/=tagging-method"))) + (when root + (vc-file-setprop + file 'arch-root root))))) + +(defun vc-arch-find-admin-dir (file) + "Return the administrative directory of FILE." + (expand-file-name "{arch}" (vc-arch-root file))) + +(defun vc-arch-register (files &optional _comment) + (dolist (file files) + (let ((tagmet (vc-arch-tagging-method file))) + (if (and (memq tagmet '(tagline implicit)) comment-start) + (with-current-buffer (find-file-noselect file) + (if (buffer-modified-p) + (error "Save %s first" (buffer-name))) + (vc-arch-add-tagline) + (save-buffer))))) + (vc-arch-command nil 0 files "add")) + +(defun vc-arch-registered (file) + ;; Don't seriously check whether it's source or not. Checking would + ;; require running TLA, so it's better to not do it, so it also works if + ;; TLA is not installed. + (and (vc-arch-root file) + (vc-arch-file-source-p file))) + +(defun vc-arch-default-version (file) + (or (vc-file-getprop (vc-arch-root file) 'arch-default-version) + (let* ((root (vc-arch-root file)) + (f (expand-file-name "{arch}/++default-version" root))) + (if (file-readable-p f) + (vc-file-setprop + root 'arch-default-version + (with-temp-buffer + (insert-file-contents f) + ;; Strip the terminating newline. + (buffer-substring (point-min) (1- (point-max))))))))) + +(defun vc-arch-state (file) + ;; There's no checkout operation and merging is not done from VC + ;; so the only operation that's state dependent that VC supports is commit + ;; which is only activated if the file is `edited'. + (let* ((root (vc-arch-root file)) + (ver (vc-arch-default-version file)) + (pat (concat "\\`" (subst-char-in-string ?/ ?% ver))) + (dir (expand-file-name ",,inode-sigs/" + (expand-file-name "{arch}" root))) + (sigfile nil)) + (dolist (f (if (file-directory-p dir) (directory-files dir t pat))) + (if (or (not sigfile) (file-newer-than-file-p f sigfile)) + (setq sigfile f))) + (if (not sigfile) + 'edited ;We know nothing. + (let ((id (vc-arch-file-id file))) + (setq id (replace-regexp-in-string "[ \t]" "_" id)) + (with-current-buffer (find-file-noselect sigfile) + (goto-char (point-min)) + (while (and (search-forward id nil 'move) + (save-excursion + (goto-char (- (match-beginning 0) 2)) + ;; For `names', the lines start with `?./foo/bar'. + ;; For others there's 2 chars before the ./foo/bar. + (or (not (or (bolp) (looking-at "\n?"))) + ;; Ignore E_ entries used for foo.id files. + (looking-at "E_"))))) + (if (eobp) + ;; ID not found. + (if (equal (file-name-nondirectory sigfile) + (subst-char-in-string + ?/ ?% (vc-arch-working-revision file))) + 'added + ;; Might be `added' or `up-to-date' as well. + ;; FIXME: Check in the patch logs to find out. + 'edited) + ;; Found the ID, let's check the inode. + (if (not (re-search-forward + "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)" + (line-end-position) t)) + ;; Buh? Unexpected format. + 'edited + (let ((ats (file-attributes file))) + (if (and (eq (nth 7 ats) (string-to-number (match-string 2))) + (equal (format-time-string "%s" (nth 5 ats)) + (match-string 1))) + 'up-to-date + 'edited))))))))) + +;; dir-status-files called from vc-dir, which loads vc, +;; which loads vc-dispatcher. +(declare-function vc-exec-after "vc-dispatcher" (code)) + +(defun vc-arch-dir-status-files (dir _files callback) + "Run 'tla inventory' for DIR and pass results to CALLBACK. +CALLBACK expects (ENTRIES &optional MORE-TO-COME); see +`vc-dir-refresh'." + (let ((default-directory dir)) + (vc-arch-command t 'async nil "changes")) + ;; The updating could be done asynchronously. + (vc-run-delayed + (vc-arch-after-dir-status callback))) + +(defun vc-arch-after-dir-status (callback) + (let* ((state-map '(("M " . edited) + ("Mb" . edited) ;binary + ("D " . removed) + ("D/" . removed) ;directory + ("A " . added) + ("A/" . added) ;directory + ("=>" . renamed) + ("/>" . renamed) ;directory + ("lf" . symlink-to-file) + ("fl" . file-to-symlink) + ("--" . permissions-changed) + ("-/" . permissions-changed) ;directory + )) + (state-map-regexp (regexp-opt (mapcar 'car state-map) t)) + (entry-regexp (concat "^" state-map-regexp " \\(.*\\)$")) + result) + (goto-char (point-min)) + ;;(message "Got %s" (buffer-string)) + (while (re-search-forward entry-regexp nil t) + (let* ((state-string (match-string 1)) + (state (cdr (assoc state-string state-map))) + (filename (match-string 2))) + (push (list filename state) result))) + + (funcall callback result nil))) + +(defun vc-arch-working-revision (file) + (let* ((root (expand-file-name "{arch}" (vc-arch-root file))) + (defbranch (vc-arch-default-version file))) + (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch)) + (let* ((archive (match-string 1 defbranch)) + (category (match-string 4 defbranch)) + (branch (match-string 3 defbranch)) + (version (match-string 2 defbranch)) + (sealed nil) (rev-nb 0) + (rev nil) + logdir tmp) + (setq logdir (expand-file-name category root)) + (setq logdir (expand-file-name branch logdir)) + (setq logdir (expand-file-name version logdir)) + (setq logdir (expand-file-name archive logdir)) + (setq logdir (expand-file-name "patch-log" logdir)) + (dolist (file (if (file-directory-p logdir) (directory-files logdir))) + ;; Revision names go: base-0, patch-N, version-0, versionfix-M. + (when (and (eq (aref file 0) ?v) (not sealed)) + (setq sealed t rev-nb 0)) + (if (and (string-match "-\\([0-9]+\\)\\'" file) + (setq tmp (string-to-number (match-string 1 file))) + (or (not sealed) (eq (aref file 0) ?v)) + (>= tmp rev-nb)) + (setq rev-nb tmp rev file))) + ;; Use "none-000" if the tree hasn't yet been committed on the + ;; default branch. We'll then get "Arch:000[branch]" on the mode-line. + (concat defbranch "--" (or rev "none-000")))))) + + +(defcustom vc-arch-mode-line-rewrite + '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]")) + "Rewrite rules to shorten Arch's revision names on the mode-line." + :type '(repeat (cons regexp string)) + :group 'vc-arch) + +(defun vc-arch-mode-line-string (file) + "Return a string for `vc-mode-line' to put in the mode line for FILE." + (let ((rev (vc-working-revision file))) + (dolist (rule vc-arch-mode-line-rewrite) + (if (string-match (car rule) rev) + (setq rev (replace-match (cdr rule) t nil rev)))) + (format "Arch%c%s" + (pcase (vc-state file) + ((or `up-to-date `needs-update) ?-) + (`added ?@) + (t ?:)) + rev))) + +(defun vc-arch-diff3-rej-p (rej) + (let ((attrs (file-attributes rej))) + (and attrs (< (nth 7 attrs) 60) + (with-temp-buffer + (insert-file-contents rej) + (goto-char (point-min)) + (looking-at "Conflicts occurred, diff3 conflict markers left in file\\."))))) + +(defun vc-arch-delete-rej-if-obsolete () + "For use in `after-save-hook'." + (save-excursion + (let ((rej (concat buffer-file-name ".rej"))) + (when (and buffer-file-name (vc-arch-diff3-rej-p rej)) + (unless (re-search-forward "^<<<<<<< " nil t) + ;; The .rej file is obsolete. + (condition-case nil (delete-file rej) (error nil)) + ;; Remove the hook so that it is not called multiple times. + (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t)))))) + +(defun vc-arch-find-file-hook () + (let ((rej (concat buffer-file-name ".rej"))) + (when (and buffer-file-name (file-exists-p rej)) + (if (vc-arch-diff3-rej-p rej) + (save-excursion + (goto-char (point-min)) + (if (not (re-search-forward "^<<<<<<< " nil t)) + ;; The .rej file is obsolete. + (condition-case nil (delete-file rej) (error nil)) + (smerge-mode 1) + (add-hook 'after-save-hook + 'vc-arch-delete-rej-if-obsolete nil t) + (message "There are unresolved conflicts in this file"))) + (message "There are unresolved conflicts in %s" + (file-name-nondirectory rej)))))) + +(autoload 'vc-switches "vc") + +(defun vc-arch-checkin (files comment) + ;; FIXME: This implementation probably only works for singleton filesets + (let ((summary (file-relative-name (car files) (vc-arch-root (car files))))) + ;; Extract a summary from the comment. + (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment) + (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment)) + (setq summary (match-string 1 comment)) + (setq comment (substring comment (match-end 0)))) + (vc-arch-command nil 0 files "commit" "-s" summary "-L" comment "--" + (vc-switches 'Arch 'checkin)))) + +(defun vc-arch-diff (files &optional async oldvers newvers buffer) + "Get a difference report using Arch between two versions of FILES." + ;; FIXME: This implementation only works for singleton filesets. To make + ;; it work for more cases, we have to either call `file-diffs' manually on + ;; each and every `file' in the fileset, or use `changes --diffs' (and + ;; variants) and maybe filter the output with `filterdiff' to only include + ;; the files in which we're interested. + (let ((file (car files))) + (if (and newvers + (vc-up-to-date-p file) + (equal newvers (vc-working-revision file))) + ;; Newvers is the base revision and the current file is unchanged, + ;; so we can diff with the current file. + (setq newvers nil)) + (if newvers + (error "Diffing specific revisions not implemented") + (let* (process-file-side-effects + ;; Run the command from the root dir. + (default-directory (vc-arch-root file)) + (status + (vc-arch-command + (or buffer "*vc-diff*") + (if async 'async 1) + nil "file-diffs" + (vc-switches 'Arch 'diff) + (file-relative-name file) + (if (equal oldvers (vc-working-revision file)) + nil + oldvers)))) + (if async 1 status))))) ; async diff, pessimistic assumption. + +(defun vc-arch-delete-file (file) + (vc-arch-command nil 0 file "rm")) + +(defun vc-arch-rename-file (old new) + (vc-arch-command nil 0 new "mv" (file-relative-name old))) + +(defalias 'vc-arch-responsible-p 'vc-arch-root) + +(defun vc-arch-command (buffer okstatus file &rest flags) + "A wrapper around `vc-do-command' for use in vc-arch.el." + (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags)) + +;;; Completion of versions and revisions. + +(defun vc-arch--version-completion-table (root string) + (delq nil + (mapcar + (lambda (d) + (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d) + (concat (match-string 2 d) "/" (match-string 1 d)))) + (let ((default-directory root)) + (file-expand-wildcards + (concat "*/*/" + (if (string-match "/" string) + (concat (substring string (match-end 0)) + "*/" (substring string 0 (match-beginning 0))) + (concat "*/" string)) + "*")))))) + +(defun vc-arch-revision-completion-table (files) + (lambda (string pred action) + ;; FIXME: complete revision patches as well. + (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files)))) + (table (vc-arch--version-completion-table root string))) + (complete-with-action action table string pred)))) + +;;; Trimming revision libraries. + +;; This code is not directly related to VC and there are many variants of +;; this functionality available as scripts, but I like this version better, +;; so maybe others will like it too. + +(defun vc-arch-trim-find-least-useful-rev (revs) + (let* ((first (pop revs)) + (second (pop revs)) + (third (pop revs)) + ;; We try to give more importance to recent revisions. The idea is + ;; that it's OK if checking out a revision 1000-patch-old is ten + ;; times slower than checking out a revision 100-patch-old. But at + ;; the same time a 2-patch-old rev isn't really ten times more + ;; important than a 20-patch-old, so we use an arbitrary constant + ;; "100" to reduce this effect for recent revisions. Making this + ;; constant a float has the side effect of causing the subsequent + ;; computations to be done as floats as well. + (max (+ 100.0 (car (or (car (last revs)) third)))) + (cost (lambda () (/ (- (car third) (car first)) (- max (car second))))) + (minrev second) + (mincost (funcall cost))) + (while revs + (setq first second) + (setq second third) + (setq third (pop revs)) + (when (< (funcall cost) mincost) + (setq minrev second) + (setq mincost (funcall cost)))) + minrev)) + +(defun vc-arch-trim-make-sentinel (revs) + (if (null revs) (lambda (_proc _msg) (message "VC-Arch trimming ... done")) + (lambda (_proc _msg) + (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs))) + (rename-file (car revs) (concat (car revs) "*rm*")) + (let ((proc (start-process "vc-arch-trim" nil + "rm" "-rf" (concat (car revs) "*rm*")))) + (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs))))))) + +(defun vc-arch-trim-one-revlib (dir) + "Delete half of the revisions in the revision library." + (interactive "Ddirectory: ") + (let ((garbage (directory-files dir 'full "\\`,," 'nosort))) + (when garbage + (funcall (vc-arch-trim-make-sentinel garbage) nil nil))) + (let ((revs + (sort (delq nil + (mapcar + (lambda (f) + (when (string-match "-\\([0-9]+\\)\\'" f) + (cons (string-to-number (match-string 1 f)) f))) + (directory-files dir nil nil 'nosort))) + 'car-less-than-car)) + (subdirs nil)) + (when (cddr revs) + (dotimes (_i (/ (length revs) 2)) + (let ((minrev (vc-arch-trim-find-least-useful-rev revs))) + (setq revs (delq minrev revs)) + (push minrev subdirs))) + (funcall (vc-arch-trim-make-sentinel + (mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs)) + nil nil)))) + +(defun vc-arch-trim-revlib () + "Delete half of the revisions in the revision library." + (interactive) + (let ((rl-dir (with-output-to-string + (call-process vc-arch-program nil standard-output nil + "my-revision-library")))) + (while (string-match "\\(.*\\)\n" rl-dir) + (let ((dir (match-string 1 rl-dir))) + (setq rl-dir + (if (and (file-directory-p dir) (file-writable-p dir)) + dir + (substring rl-dir (match-end 0)))))) + (unless (file-writable-p rl-dir) + (error "No writable revlib directory found")) + (message "Revlib at %s" rl-dir) + (let* ((archives (directory-files rl-dir 'full "[^.]\\|...")) + (categories + (apply 'append + (mapcar (lambda (dir) + (when (file-directory-p dir) + (directory-files dir 'full "[^.]\\|..."))) + archives))) + (branches + (apply 'append + (mapcar (lambda (dir) + (when (file-directory-p dir) + (directory-files dir 'full "[^.]\\|..."))) + categories))) + (versions + (apply 'append + (mapcar (lambda (dir) + (when (file-directory-p dir) + (directory-files dir 'full "--.*--"))) + branches)))) + (mapc 'vc-arch-trim-one-revlib versions)) + )) + +(defvar vc-arch-extra-menu-map + (let ((map (make-sparse-keymap))) + (define-key map [add-tagline] + '(menu-item "Add tagline" vc-arch-add-tagline)) + map)) + +(defun vc-arch-extra-menu () vc-arch-extra-menu-map) + + +;;; Less obvious implementations. + +(defun vc-arch-find-revision (file rev buffer) + (let ((out (make-temp-file "vc-out"))) + (unwind-protect + (progn + (with-temp-buffer + (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev) + (call-process-region (point-min) (point-max) + "patch" nil nil nil "-R" "-o" out file)) + (with-current-buffer buffer + (insert-file-contents out))) + (delete-file out)))) + +(provide 'vc-arch) + +;;; vc-arch.el ends here diff --git a/lisp/vc/vc-arch.el b/lisp/vc/vc-arch.el deleted file mode 100644 index d1344f2..0000000 --- a/lisp/vc/vc-arch.el +++ /dev/null @@ -1,644 +0,0 @@ -;;; vc-arch.el --- VC backend for the Arch version-control system -*- lexical-binding: t -*- - -;; Copyright (C) 2004-2014 Free Software Foundation, Inc. - -;; Author: FSF (see vc.el for full credits) -;; Maintainer: Stefan Monnier -;; Package: vc - -;; 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: - -;; The home page of the Arch version control system is at -;; -;; http://www.gnuarch.org/ -;; -;; This is derived from vc-mcvs.el as follows: -;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET -;; -;; Then of course started the hacking. -;; -;; What has been partly tested: -;; - Open a file. -;; - C-x v = without any prefix arg. -;; - C-x v v to commit a change to a single file. - -;; Bugs: - -;; - *vc-log*'s initial content lacks the `Summary:' lines. -;; - All files under the tree are considered as "under Arch's control" -;; without regards to =tagging-method and such. -;; - Files are always considered as `edited'. -;; - C-x v l does not work. -;; - C-x v i does not work. -;; - C-x v ~ does not work. -;; - C-x v u does not work. -;; - C-x v s does not work. -;; - C-x v r does not work. -;; - VC directory listings do not work. -;; - And more... - -;;; Code: - -(eval-when-compile (require 'vc)) - -;;; Properties of the backend - -(defun vc-arch-revision-granularity () 'repository) -(defun vc-arch-checkout-model (_files) 'implicit) - -;;; -;;; Customization options -;;; - -(defgroup vc-arch nil - "VC Arch backend." - :version "24.1" - :group 'vc) - -;; It seems Arch diff does not accept many options, so this is not -;; very useful. It exists mainly so that the VC backends are all -;; consistent with regards to their treatment of diff switches. -(defcustom vc-arch-diff-switches t - "String or list of strings specifying switches for Arch diff under VC. -If nil, use the value of `vc-diff-switches'. If t, use no switches." - :type '(choice (const :tag "Unspecified" nil) - (const :tag "None" t) - (string :tag "Argument String") - (repeat :tag "Argument List" :value ("") string)) - :version "23.1" - :group 'vc-arch) - -(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1") - -(defcustom vc-arch-program - (let ((candidates '("tla" "baz"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "tla")) - "Name of the Arch executable." - :type 'string - :group 'vc-arch) - -;; Clear up the cache to force vc-call to check again and discover -;; new functions when we reload this file. -(put 'Arch 'vc-functions nil) - -;;;###autoload (defun vc-arch-registered (file) -;;;###autoload (if (vc-find-root file "{arch}/=tagging-method") -;;;###autoload (progn -;;;###autoload (load "vc-arch" nil t) -;;;###autoload (vc-arch-registered file)))) - -(defun vc-arch-add-tagline () - "Add an `arch-tag' to the end of the current file." - (interactive) - (comment-normalize-vars) - (goto-char (point-max)) - (forward-comment -1) - (skip-chars-forward " \t\n") - (cond - ((not (bolp)) (insert "\n\n")) - ((not (eq ?\n (char-before (1- (point))))) (insert "\n"))) - (let ((beg (point)) - (idfile (and buffer-file-name - (expand-file-name - (concat ".arch-ids/" - (file-name-nondirectory buffer-file-name) - ".id") - (file-name-directory buffer-file-name))))) - (insert "arch-tag: ") - (if (and idfile (file-exists-p idfile)) - ;; If the file is unreadable, we do want to get an error here. - (progn - (insert-file-contents idfile) - (forward-line 1) - (delete-file idfile)) - (condition-case nil - (call-process "uuidgen" nil t) - (file-error (insert (format "%s <%s> %s" - (current-time-string) - user-mail-address - (+ (nth 2 (current-time)) - (buffer-size))))))) - (comment-region beg (point)))) - -(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)") - -(defmacro vc-with-current-file-buffer (file &rest body) - (declare (indent 2) (debug t)) - `(let ((-kill-buf- nil) - (-file- ,file)) - (with-current-buffer (or (find-buffer-visiting -file-) - (setq -kill-buf- (generate-new-buffer " temp"))) - ;; Avoid find-file-literally since it can do many undesirable extra - ;; things (among which, call us back into an infinite loop). - (if -kill-buf- (insert-file-contents -file-)) - (unwind-protect - (progn ,@body) - (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-)))))) - -(defun vc-arch-file-source-p (file) - "Can return nil, `maybe' or a non-nil value. -Only the value `maybe' can be trusted :-(." - ;; FIXME: Check the tag and name of parent dirs. - (unless (string-match "\\`[,+]" (file-name-nondirectory file)) - (or (string-match "\\`{arch}/" - (file-relative-name file (vc-arch-root file))) - (file-exists-p - ;; Check the presence of an ID file. - (expand-file-name - (concat ".arch-ids/" (file-name-nondirectory file) ".id") - (file-name-directory file))) - ;; Check the presence of a tagline. - (vc-with-current-file-buffer file - (save-excursion - (goto-char (point-max)) - (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t) - (progn - (goto-char (point-min)) - (re-search-forward vc-arch-tagline-re (+ (point) 1000) t))))) - ;; FIXME: check =tagging-method to see whether untagged files might - ;; be source or not. - (with-current-buffer - (find-file-noselect (expand-file-name "{arch}/=tagging-method" - (vc-arch-root file))) - (let ((untagged-source t)) ;Default is `names'. - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t) - (setq untagged-source (match-end 2))) - (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t) - (setq untagged-source (match-end 2)))) - (if untagged-source 'maybe)))))) - -(defun vc-arch-file-id (file) - ;; Don't include the kind of ID this is because it seems to be too messy. - (let ((idfile (expand-file-name - (concat ".arch-ids/" (file-name-nondirectory file) ".id") - (file-name-directory file)))) - (if (file-exists-p idfile) - (with-temp-buffer - (insert-file-contents idfile) - (looking-at ".*[^ \n\t]") - (match-string 0)) - (with-current-buffer (find-file-noselect file) - (save-excursion - (goto-char (point-max)) - (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t) - (progn - (goto-char (point-min)) - (re-search-forward vc-arch-tagline-re (+ (point) 1000) t))) - (match-string 1) - (concat "./" (file-relative-name file (vc-arch-root file))))))))) - -(defun vc-arch-tagging-method (file) - (with-current-buffer - (find-file-noselect - (expand-file-name "{arch}/=tagging-method" (vc-arch-root file))) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t) - (intern (match-string 1)) - 'names)))) - -(defun vc-arch-root (file) - "Return the root directory of an Arch project, if any." - (or (vc-file-getprop file 'arch-root) - ;; Check the =tagging-method, in case someone naively manually - ;; creates a {arch} directory somewhere. - (let ((root (vc-find-root file "{arch}/=tagging-method"))) - (when root - (vc-file-setprop - file 'arch-root root))))) - -(defun vc-arch-find-admin-dir (file) - "Return the administrative directory of FILE." - (expand-file-name "{arch}" (vc-arch-root file))) - -(defun vc-arch-register (files &optional _comment) - (dolist (file files) - (let ((tagmet (vc-arch-tagging-method file))) - (if (and (memq tagmet '(tagline implicit)) comment-start) - (with-current-buffer (find-file-noselect file) - (if (buffer-modified-p) - (error "Save %s first" (buffer-name))) - (vc-arch-add-tagline) - (save-buffer))))) - (vc-arch-command nil 0 files "add")) - -(defun vc-arch-registered (file) - ;; Don't seriously check whether it's source or not. Checking would - ;; require running TLA, so it's better to not do it, so it also works if - ;; TLA is not installed. - (and (vc-arch-root file) - (vc-arch-file-source-p file))) - -(defun vc-arch-default-version (file) - (or (vc-file-getprop (vc-arch-root file) 'arch-default-version) - (let* ((root (vc-arch-root file)) - (f (expand-file-name "{arch}/++default-version" root))) - (if (file-readable-p f) - (vc-file-setprop - root 'arch-default-version - (with-temp-buffer - (insert-file-contents f) - ;; Strip the terminating newline. - (buffer-substring (point-min) (1- (point-max))))))))) - -(defun vc-arch-state (file) - ;; There's no checkout operation and merging is not done from VC - ;; so the only operation that's state dependent that VC supports is commit - ;; which is only activated if the file is `edited'. - (let* ((root (vc-arch-root file)) - (ver (vc-arch-default-version file)) - (pat (concat "\\`" (subst-char-in-string ?/ ?% ver))) - (dir (expand-file-name ",,inode-sigs/" - (expand-file-name "{arch}" root))) - (sigfile nil)) - (dolist (f (if (file-directory-p dir) (directory-files dir t pat))) - (if (or (not sigfile) (file-newer-than-file-p f sigfile)) - (setq sigfile f))) - (if (not sigfile) - 'edited ;We know nothing. - (let ((id (vc-arch-file-id file))) - (setq id (replace-regexp-in-string "[ \t]" "_" id)) - (with-current-buffer (find-file-noselect sigfile) - (goto-char (point-min)) - (while (and (search-forward id nil 'move) - (save-excursion - (goto-char (- (match-beginning 0) 2)) - ;; For `names', the lines start with `?./foo/bar'. - ;; For others there's 2 chars before the ./foo/bar. - (or (not (or (bolp) (looking-at "\n?"))) - ;; Ignore E_ entries used for foo.id files. - (looking-at "E_"))))) - (if (eobp) - ;; ID not found. - (if (equal (file-name-nondirectory sigfile) - (subst-char-in-string - ?/ ?% (vc-arch-working-revision file))) - 'added - ;; Might be `added' or `up-to-date' as well. - ;; FIXME: Check in the patch logs to find out. - 'edited) - ;; Found the ID, let's check the inode. - (if (not (re-search-forward - "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)" - (line-end-position) t)) - ;; Buh? Unexpected format. - 'edited - (let ((ats (file-attributes file))) - (if (and (eq (nth 7 ats) (string-to-number (match-string 2))) - (equal (format-time-string "%s" (nth 5 ats)) - (match-string 1))) - 'up-to-date - 'edited))))))))) - -;; dir-status-files called from vc-dir, which loads vc, -;; which loads vc-dispatcher. -(declare-function vc-exec-after "vc-dispatcher" (code)) - -(defun vc-arch-dir-status-files (dir _files callback) - "Run 'tla inventory' for DIR and pass results to CALLBACK. -CALLBACK expects (ENTRIES &optional MORE-TO-COME); see -`vc-dir-refresh'." - (let ((default-directory dir)) - (vc-arch-command t 'async nil "changes")) - ;; The updating could be done asynchronously. - (vc-run-delayed - (vc-arch-after-dir-status callback))) - -(defun vc-arch-after-dir-status (callback) - (let* ((state-map '(("M " . edited) - ("Mb" . edited) ;binary - ("D " . removed) - ("D/" . removed) ;directory - ("A " . added) - ("A/" . added) ;directory - ("=>" . renamed) - ("/>" . renamed) ;directory - ("lf" . symlink-to-file) - ("fl" . file-to-symlink) - ("--" . permissions-changed) - ("-/" . permissions-changed) ;directory - )) - (state-map-regexp (regexp-opt (mapcar 'car state-map) t)) - (entry-regexp (concat "^" state-map-regexp " \\(.*\\)$")) - result) - (goto-char (point-min)) - ;;(message "Got %s" (buffer-string)) - (while (re-search-forward entry-regexp nil t) - (let* ((state-string (match-string 1)) - (state (cdr (assoc state-string state-map))) - (filename (match-string 2))) - (push (list filename state) result))) - - (funcall callback result nil))) - -(defun vc-arch-working-revision (file) - (let* ((root (expand-file-name "{arch}" (vc-arch-root file))) - (defbranch (vc-arch-default-version file))) - (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch)) - (let* ((archive (match-string 1 defbranch)) - (category (match-string 4 defbranch)) - (branch (match-string 3 defbranch)) - (version (match-string 2 defbranch)) - (sealed nil) (rev-nb 0) - (rev nil) - logdir tmp) - (setq logdir (expand-file-name category root)) - (setq logdir (expand-file-name branch logdir)) - (setq logdir (expand-file-name version logdir)) - (setq logdir (expand-file-name archive logdir)) - (setq logdir (expand-file-name "patch-log" logdir)) - (dolist (file (if (file-directory-p logdir) (directory-files logdir))) - ;; Revision names go: base-0, patch-N, version-0, versionfix-M. - (when (and (eq (aref file 0) ?v) (not sealed)) - (setq sealed t rev-nb 0)) - (if (and (string-match "-\\([0-9]+\\)\\'" file) - (setq tmp (string-to-number (match-string 1 file))) - (or (not sealed) (eq (aref file 0) ?v)) - (>= tmp rev-nb)) - (setq rev-nb tmp rev file))) - ;; Use "none-000" if the tree hasn't yet been committed on the - ;; default branch. We'll then get "Arch:000[branch]" on the mode-line. - (concat defbranch "--" (or rev "none-000")))))) - - -(defcustom vc-arch-mode-line-rewrite - '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]")) - "Rewrite rules to shorten Arch's revision names on the mode-line." - :type '(repeat (cons regexp string)) - :group 'vc-arch) - -(defun vc-arch-mode-line-string (file) - "Return a string for `vc-mode-line' to put in the mode line for FILE." - (let ((rev (vc-working-revision file))) - (dolist (rule vc-arch-mode-line-rewrite) - (if (string-match (car rule) rev) - (setq rev (replace-match (cdr rule) t nil rev)))) - (format "Arch%c%s" - (pcase (vc-state file) - ((or `up-to-date `needs-update) ?-) - (`added ?@) - (t ?:)) - rev))) - -(defun vc-arch-diff3-rej-p (rej) - (let ((attrs (file-attributes rej))) - (and attrs (< (nth 7 attrs) 60) - (with-temp-buffer - (insert-file-contents rej) - (goto-char (point-min)) - (looking-at "Conflicts occurred, diff3 conflict markers left in file\\."))))) - -(defun vc-arch-delete-rej-if-obsolete () - "For use in `after-save-hook'." - (save-excursion - (let ((rej (concat buffer-file-name ".rej"))) - (when (and buffer-file-name (vc-arch-diff3-rej-p rej)) - (unless (re-search-forward "^<<<<<<< " nil t) - ;; The .rej file is obsolete. - (condition-case nil (delete-file rej) (error nil)) - ;; Remove the hook so that it is not called multiple times. - (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t)))))) - -(defun vc-arch-find-file-hook () - (let ((rej (concat buffer-file-name ".rej"))) - (when (and buffer-file-name (file-exists-p rej)) - (if (vc-arch-diff3-rej-p rej) - (save-excursion - (goto-char (point-min)) - (if (not (re-search-forward "^<<<<<<< " nil t)) - ;; The .rej file is obsolete. - (condition-case nil (delete-file rej) (error nil)) - (smerge-mode 1) - (add-hook 'after-save-hook - 'vc-arch-delete-rej-if-obsolete nil t) - (message "There are unresolved conflicts in this file"))) - (message "There are unresolved conflicts in %s" - (file-name-nondirectory rej)))))) - -(autoload 'vc-switches "vc") - -(defun vc-arch-checkin (files comment) - ;; FIXME: This implementation probably only works for singleton filesets - (let ((summary (file-relative-name (car files) (vc-arch-root (car files))))) - ;; Extract a summary from the comment. - (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment) - (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment)) - (setq summary (match-string 1 comment)) - (setq comment (substring comment (match-end 0)))) - (vc-arch-command nil 0 files "commit" "-s" summary "-L" comment "--" - (vc-switches 'Arch 'checkin)))) - -(defun vc-arch-diff (files &optional async oldvers newvers buffer) - "Get a difference report using Arch between two versions of FILES." - ;; FIXME: This implementation only works for singleton filesets. To make - ;; it work for more cases, we have to either call `file-diffs' manually on - ;; each and every `file' in the fileset, or use `changes --diffs' (and - ;; variants) and maybe filter the output with `filterdiff' to only include - ;; the files in which we're interested. - (let ((file (car files))) - (if (and newvers - (vc-up-to-date-p file) - (equal newvers (vc-working-revision file))) - ;; Newvers is the base revision and the current file is unchanged, - ;; so we can diff with the current file. - (setq newvers nil)) - (if newvers - (error "Diffing specific revisions not implemented") - (let* (process-file-side-effects - ;; Run the command from the root dir. - (default-directory (vc-arch-root file)) - (status - (vc-arch-command - (or buffer "*vc-diff*") - (if async 'async 1) - nil "file-diffs" - (vc-switches 'Arch 'diff) - (file-relative-name file) - (if (equal oldvers (vc-working-revision file)) - nil - oldvers)))) - (if async 1 status))))) ; async diff, pessimistic assumption. - -(defun vc-arch-delete-file (file) - (vc-arch-command nil 0 file "rm")) - -(defun vc-arch-rename-file (old new) - (vc-arch-command nil 0 new "mv" (file-relative-name old))) - -(defalias 'vc-arch-responsible-p 'vc-arch-root) - -(defun vc-arch-command (buffer okstatus file &rest flags) - "A wrapper around `vc-do-command' for use in vc-arch.el." - (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags)) - -;;; Completion of versions and revisions. - -(defun vc-arch--version-completion-table (root string) - (delq nil - (mapcar - (lambda (d) - (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d) - (concat (match-string 2 d) "/" (match-string 1 d)))) - (let ((default-directory root)) - (file-expand-wildcards - (concat "*/*/" - (if (string-match "/" string) - (concat (substring string (match-end 0)) - "*/" (substring string 0 (match-beginning 0))) - (concat "*/" string)) - "*")))))) - -(defun vc-arch-revision-completion-table (files) - (lambda (string pred action) - ;; FIXME: complete revision patches as well. - (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files)))) - (table (vc-arch--version-completion-table root string))) - (complete-with-action action table string pred)))) - -;;; Trimming revision libraries. - -;; This code is not directly related to VC and there are many variants of -;; this functionality available as scripts, but I like this version better, -;; so maybe others will like it too. - -(defun vc-arch-trim-find-least-useful-rev (revs) - (let* ((first (pop revs)) - (second (pop revs)) - (third (pop revs)) - ;; We try to give more importance to recent revisions. The idea is - ;; that it's OK if checking out a revision 1000-patch-old is ten - ;; times slower than checking out a revision 100-patch-old. But at - ;; the same time a 2-patch-old rev isn't really ten times more - ;; important than a 20-patch-old, so we use an arbitrary constant - ;; "100" to reduce this effect for recent revisions. Making this - ;; constant a float has the side effect of causing the subsequent - ;; computations to be done as floats as well. - (max (+ 100.0 (car (or (car (last revs)) third)))) - (cost (lambda () (/ (- (car third) (car first)) (- max (car second))))) - (minrev second) - (mincost (funcall cost))) - (while revs - (setq first second) - (setq second third) - (setq third (pop revs)) - (when (< (funcall cost) mincost) - (setq minrev second) - (setq mincost (funcall cost)))) - minrev)) - -(defun vc-arch-trim-make-sentinel (revs) - (if (null revs) (lambda (_proc _msg) (message "VC-Arch trimming ... done")) - (lambda (_proc _msg) - (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs))) - (rename-file (car revs) (concat (car revs) "*rm*")) - (let ((proc (start-process "vc-arch-trim" nil - "rm" "-rf" (concat (car revs) "*rm*")))) - (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs))))))) - -(defun vc-arch-trim-one-revlib (dir) - "Delete half of the revisions in the revision library." - (interactive "Ddirectory: ") - (let ((garbage (directory-files dir 'full "\\`,," 'nosort))) - (when garbage - (funcall (vc-arch-trim-make-sentinel garbage) nil nil))) - (let ((revs - (sort (delq nil - (mapcar - (lambda (f) - (when (string-match "-\\([0-9]+\\)\\'" f) - (cons (string-to-number (match-string 1 f)) f))) - (directory-files dir nil nil 'nosort))) - 'car-less-than-car)) - (subdirs nil)) - (when (cddr revs) - (dotimes (_i (/ (length revs) 2)) - (let ((minrev (vc-arch-trim-find-least-useful-rev revs))) - (setq revs (delq minrev revs)) - (push minrev subdirs))) - (funcall (vc-arch-trim-make-sentinel - (mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs)) - nil nil)))) - -(defun vc-arch-trim-revlib () - "Delete half of the revisions in the revision library." - (interactive) - (let ((rl-dir (with-output-to-string - (call-process vc-arch-program nil standard-output nil - "my-revision-library")))) - (while (string-match "\\(.*\\)\n" rl-dir) - (let ((dir (match-string 1 rl-dir))) - (setq rl-dir - (if (and (file-directory-p dir) (file-writable-p dir)) - dir - (substring rl-dir (match-end 0)))))) - (unless (file-writable-p rl-dir) - (error "No writable revlib directory found")) - (message "Revlib at %s" rl-dir) - (let* ((archives (directory-files rl-dir 'full "[^.]\\|...")) - (categories - (apply 'append - (mapcar (lambda (dir) - (when (file-directory-p dir) - (directory-files dir 'full "[^.]\\|..."))) - archives))) - (branches - (apply 'append - (mapcar (lambda (dir) - (when (file-directory-p dir) - (directory-files dir 'full "[^.]\\|..."))) - categories))) - (versions - (apply 'append - (mapcar (lambda (dir) - (when (file-directory-p dir) - (directory-files dir 'full "--.*--"))) - branches)))) - (mapc 'vc-arch-trim-one-revlib versions)) - )) - -(defvar vc-arch-extra-menu-map - (let ((map (make-sparse-keymap))) - (define-key map [add-tagline] - '(menu-item "Add tagline" vc-arch-add-tagline)) - map)) - -(defun vc-arch-extra-menu () vc-arch-extra-menu-map) - - -;;; Less obvious implementations. - -(defun vc-arch-find-revision (file rev buffer) - (let ((out (make-temp-file "vc-out"))) - (unwind-protect - (progn - (with-temp-buffer - (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev) - (call-process-region (point-min) (point-max) - "patch" nil nil nil "-R" "-o" out file)) - (with-current-buffer buffer - (insert-file-contents out))) - (delete-file out)))) - -(provide 'vc-arch) - -;;; vc-arch.el ends here diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 61918c9..9a4fe16 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -107,7 +107,7 @@ interpreted as hostnames." :type 'regexp :group 'vc) -(defcustom vc-handled-backends '(RCS CVS SVN SCCS SRC Bzr Git Hg Mtn Arch) +(defcustom vc-handled-backends '(RCS CVS SVN SCCS SRC Bzr Git Hg Mtn) ;; RCS, CVS, SVN, SCCS, and SRC come first because they are per-dir ;; rather than per-tree. RCS comes first because of the multibackend ;; support intended to use RCS for local commits (with a remote CVS server). @@ -122,7 +122,8 @@ An empty list disables VC altogether." :group 'vc) ;; Note: we don't actually have a darcs back end yet. -;; Also, Meta-CVS (corresponding to MCVS) is unsupported. +;; Also, Meta-CVS (corresponding to MCVS) and Arch are unsupported. +;; The Arch back end will be retrieved and fixed if it is ever required. (defcustom vc-directory-exclusion-list (purecopy '("SCCS" "RCS" "CVS" "MCVS" ".src" ".svn" ".git" ".hg" ".bzr" "_MTN" "_darcs" "{arch}"))