commit 068b4fce52dce410a9cc1ee22649541a1823c711 (HEAD, refs/remotes/origin/master) Author: Lars Ingebrigtsen Date: Wed Oct 16 09:20:06 2019 +0200 Expand <<- heredocs in sh * lisp/progmodes/sh-script.el (sh--maybe-here-document): Make <<- expansion work, too. diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 604d13eabe..8177329f32 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -4356,7 +4356,7 @@ The document is bounded by `sh-here-document-word'." (or arg (sh--maybe-here-document))) (defun sh--maybe-here-document () - (when (and (looking-back "[^<]<<[ E]" (line-beginning-position)) + (when (and (looking-back "[^<]<<[ E-]" (line-beginning-position)) (save-excursion (backward-char 2) (not @@ -4368,7 +4368,9 @@ The document is bounded by `sh-here-document-word'." "")) (delim (replace-regexp-in-string "['\"]" "" sh-here-document-word))) - (delete-char -1) + ;; If we're at <<-, we don't want to delete the previous char. + (unless (= (preceding-char) ?-) + (delete-char -1)) (insert sh-here-document-word) (or (eolp) (looking-at "[ \t]") (insert ?\s)) (end-of-line 1) commit 265061d4c2436251db5f2d10dc64be6272e29a54 Author: Robert Pluim Date: Tue Oct 15 12:00:34 2019 +0200 Allow event description to be empty The previous fix for this was incomplete. * lisp/gnus/gnus-icalendar.el (gnus-icalendar-event->org-entry): Allow description to be nil. diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index e4779f52c0..77e73e6606 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -485,7 +485,7 @@ Return nil for non-recurring EVENT." (narrow-to-region (point) (point)) (insert (gnus-icalendar-event:org-timestamp event) "\n\n" - description) + (or description "No description")) (indent-region (point-min) (point-max) 2) (fill-region (point-min) (point-max))) commit a1dbb81f1808194da1b3f2af29beef704dcd1f5a Author: Lars Ingebrigtsen Date: Wed Oct 16 04:44:22 2019 +0200 Fix some &rest body edebug specs * lisp/ses.el (ses--letref): * lisp/emacs-lisp/crm.el (crm--completion-command): Fix edebug &rest body spec (bug#28747). * lisp/emacs-lisp/easy-mmode.el (easy-mmode-define-navigation): * lisp/emacs-lisp/inline.el (inline--leteval) (inline--letlisteval, inline-letevals): diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 14646a2ab1..2a1ffec9fb 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -154,7 +154,7 @@ Return the element's boundaries as (START . END)." (defmacro crm--completion-command (beg end &rest body) "Run BODY with BEG and END bound to the current element's boundaries." - (declare (indent 2) (debug (sexp sexp &rest body))) + (declare (indent 2) (debug (sexp sexp body))) `(let* ((crm--boundaries (crm--current-element)) (,beg (car crm--boundaries)) (,end (cdr crm--boundaries))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index ccdb25ef60..9e239bfa3b 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -626,7 +626,7 @@ ENDFUN should return the end position (with or without moving point). NARROWFUN non-nil means to check for narrowing before moving, and if found, do `widen' first and then call NARROWFUN with no args after moving. BODY is executed after moving to the destination location." - (declare (indent 5) (debug (exp exp exp def-form def-form &rest def-body))) + (declare (indent 5) (debug (exp exp exp def-form def-form def-body))) (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) (next-sym (intern (concat base-name "-next"))) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 3ab6943608..a6c5ae0860 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -568,7 +568,7 @@ REF must have been previously obtained with `gv-ref'." (gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v)) ;; (defmacro gv-letref (vars place &rest body) -;; (declare (indent 2) (debug (sexp form &rest body))) +;; (declare (indent 2) (debug (sexp form body))) ;; (require 'cl-lib) ;Can't require cl-lib at top-level for bootstrap reasons! ;; (gv-letplace (getter setter) place ;; `(cl-macrolet ((,(nth 0 vars) () ',getter) diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index 39f8e9b594..ffad6e8de7 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -90,12 +90,12 @@ (error "inline-error can only be used within define-inline")) (defmacro inline--leteval (_var-exp &rest _body) - (declare (indent 1) (debug (sexp &rest body))) + (declare (indent 1) (debug (sexp body))) ;; BEWARE: if we're here it's presumably via macro-expansion of ;; inline-letevals, so signal the error in terms of the user's code. (error "inline-letevals can only be used within define-inline")) (defmacro inline--letlisteval (_list &rest _body) - (declare (indent 1) (debug (sexp &rest body))) + (declare (indent 1) (debug (sexp body))) ;; BEWARE: if we're here it's presumably via macro-expansion of ;; inline-letevals, so signal the error in terms of the user's code. (error "inline-letevals can only be used within define-inline")) @@ -110,7 +110,7 @@ of arguments, in which case each argument is evaluated and the resulting new list is re-bound to VAR. After VARS is handled, BODY is evaluated in the new environment." - (declare (indent 1) (debug (sexp &rest form))) + (declare (indent 1) (debug (sexp body))) (cond ((consp vars) `(inline--leteval ,(pop vars) (inline-letevals ,vars ,@body))) diff --git a/lisp/ses.el b/lisp/ses.el index 36c966432c..1509e8faa5 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -506,7 +506,7 @@ This can alter PLIST." (setplist name (ses-plist-delq (symbol-plist name) 'ses-cell))) )) (defmacro ses--letref (vars place &rest body) - (declare (indent 2) (debug (sexp form &rest body))) + (declare (indent 2) (debug (sexp form body))) (gv-letplace (getter setter) place `(cl-macrolet ((,(nth 0 vars) () ',getter) (,(nth 1 vars) (v) (funcall ',setter v))) commit 7fd1093d28e8be4683f45000fa9c0440cbe8182c Author: Lars Ingebrigtsen Date: Wed Oct 16 03:47:12 2019 +0200 Tweak heredoc expansion in shell-script-mode * lisp/progmodes/sh-script.el (sh--maybe-here-document): Allow expanding < Date: Wed Oct 16 00:42:31 2019 +0300 Declare tab-bar-tabs the single source of truth in regard to current tab name * lisp/tab-bar.el: Replace all calls of tab-bar-tabs with '(funcall tab-bar-tabs-function)'. (tab-bar-tabs): Update the current tab name here instead of tab-bar-make-keymap-1. (tab-bar-make-keymap-1): Move the current tab name updating to tab-bar-tabs. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 32d7f6c784..c376f59896 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -230,7 +230,8 @@ keyboard commands `tab-list', `tab-new', `tab-close', `tab-next', etc." (set-default sym val) (tab-bar-mode (if (or (eq val t) - (and (natnump val) (> (length (tab-bar-tabs)) val))) + (and (natnump val) + (> (length (funcall tab-bar-tabs-function)) val))) 1 -1))) :group 'tab-bar :version "27.1") @@ -346,9 +347,18 @@ By default, use function `tab-bar-tabs'.") (defun tab-bar-tabs () "Return a list of tabs belonging to the selected frame. Ensure the frame parameter `tabs' is pre-populated. +Update the current tab name when it exists. Return its existing value or a new value." (let ((tabs (frame-parameter nil 'tabs))) - (unless tabs + (if tabs + (let* ((current-tab (assq 'current-tab tabs)) + (current-tab-name (assq 'name current-tab)) + (current-tab-explicit-name (assq 'explicit-name current-tab))) + (when (and current-tab-name + current-tab-explicit-name + (not (cdr current-tab-explicit-name))) + (setf (cdr current-tab-name) + (funcall tab-bar-tab-name-function)))) ;; Create default tabs (setq tabs (list (tab-bar--current-tab))) (set-frame-parameter nil 'tabs tabs)) @@ -358,14 +368,7 @@ Return its existing value or a new value." "Generate an actual keymap from `tab-bar-map', without caching." (let* ((separator (or tab-bar-separator (if window-system " " "|"))) (i 0) - (tabs (funcall tab-bar-tabs-function)) - (current-tab-name (assq 'name (assq 'current-tab tabs))) - (current-tab-explicit-name (assq 'explicit-name (assq 'current-tab tabs)))) - (when (and current-tab-name - current-tab-explicit-name - (not (cdr current-tab-explicit-name))) - (setf (cdr current-tab-name) - (funcall tab-bar-tab-name-function))) + (tabs (funcall tab-bar-tabs-function))) (append '(keymap (mouse-1 . tab-bar-handle-mouse)) (mapcan @@ -443,7 +446,7 @@ Return its existing value or a new value." (defun tab-bar--current-tab-index (&optional tabs) ;; FIXME: could be replaced with 1-liner using seq-position - (let ((tabs (or tabs (tab-bar-tabs))) + (let ((tabs (or tabs (funcall tab-bar-tabs-function))) (i 0)) (catch 'done (while tabs @@ -453,7 +456,7 @@ Return its existing value or a new value." (defun tab-bar--tab-index (tab &optional tabs) ;; FIXME: could be replaced with 1-liner using seq-position - (let ((tabs (or tabs (tab-bar-tabs))) + (let ((tabs (or tabs (funcall tab-bar-tabs-function))) (i 0)) (catch 'done (while tabs @@ -464,7 +467,7 @@ Return its existing value or a new value." (defun tab-bar--tab-index-by-name (name &optional tabs) ;; FIXME: could be replaced with 1-liner using seq-position - (let ((tabs (or tabs (tab-bar-tabs))) + (let ((tabs (or tabs (funcall tab-bar-tabs-function))) (i 0)) (catch 'done (while tabs @@ -486,7 +489,7 @@ to the numeric argument. ARG counts from 1." (- key ?0) 1)))) - (let* ((tabs (tab-bar-tabs)) + (let* ((tabs (funcall tab-bar-tabs-function)) (from-index (tab-bar--current-tab-index tabs)) (to-index (1- (max 1 (min arg (length tabs)))))) (unless (eq from-index to-index) @@ -518,7 +521,7 @@ to the numeric argument. ARG counts from 1." (interactive "p") (unless (integerp arg) (setq arg 1)) - (let* ((tabs (tab-bar-tabs)) + (let* ((tabs (funcall tab-bar-tabs-function)) (from-index (or (tab-bar--current-tab-index tabs) 0)) (to-index (mod (+ from-index arg) (length tabs)))) (tab-bar-select-tab (1+ to-index)))) @@ -535,7 +538,7 @@ to the numeric argument. ARG counts from 1." (interactive (list (completing-read "Switch to tab by name: " (mapcar (lambda (tab) (cdr (assq 'name tab))) - (tab-bar-tabs))))) + (funcall tab-bar-tabs-function))))) (tab-bar-select-tab (1+ (tab-bar--tab-index-by-name name)))) @@ -555,7 +558,7 @@ If `rightmost', create as the last tab." (defun tab-bar-new-tab () "Add a new tab at the position specified by `tab-bar-new-tab-to'." (interactive) - (let* ((tabs (tab-bar-tabs)) + (let* ((tabs (funcall tab-bar-tabs-function)) (from-index (tab-bar--current-tab-index tabs)) (from-tab (tab-bar--tab))) @@ -616,7 +619,7 @@ Optional TO-INDEX could be specified to override the value of of an existing tab to select after closing the current tab. TO-INDEX counts from 1." (interactive "P") - (let* ((tabs (tab-bar-tabs)) + (let* ((tabs (funcall tab-bar-tabs-function)) (current-index (tab-bar--current-tab-index tabs)) (close-index (if (integerp arg) (1- arg) current-index))) @@ -631,7 +634,7 @@ TO-INDEX counts from 1." (setq to-index (max 0 (min (or to-index 0) (1- (length tabs))))) (tab-bar-select-tab (1+ to-index)) ;; Re-read tabs after selecting another tab - (setq tabs (tab-bar-tabs)))) + (setq tabs (funcall tab-bar-tabs-function)))) (set-frame-parameter nil 'tabs (delq (nth close-index tabs) tabs)) @@ -648,13 +651,13 @@ TO-INDEX counts from 1." (interactive (list (completing-read "Close tab by name: " (mapcar (lambda (tab) (cdr (assq 'name tab))) - (tab-bar-tabs))))) + (funcall tab-bar-tabs-function))))) (tab-bar-close-tab (1+ (tab-bar--tab-index-by-name name)))) (defun tab-bar-close-other-tabs () "Close all tabs on the selected frame, except the selected one." (interactive) - (let* ((tabs (tab-bar-tabs)) + (let* ((tabs (funcall tab-bar-tabs-function)) (current-index (tab-bar--current-tab-index tabs))) (when current-index (set-frame-parameter nil 'tabs (list (nth current-index tabs))) @@ -673,7 +676,7 @@ ARG counts from 1. If NAME is the empty string, then use the automatic name function `tab-bar-tab-name-function'." (interactive "sNew name for tab (leave blank for automatic naming): \nP") - (let* ((tabs (tab-bar-tabs)) + (let* ((tabs (funcall tab-bar-tabs-function)) (tab-index (if arg (1- (max 0 (min arg (length tabs)))) (tab-bar--current-tab-index tabs))) @@ -683,8 +686,7 @@ function `tab-bar-tab-name-function'." name (funcall tab-bar-tab-name-function)))) (setf (cdr (assq 'name tab-to-rename)) tab-new-name - (cdr (assq 'explicit-name tab-to-rename)) tab-explicit-name - (frame-parameter nil 'tabs) tabs) + (cdr (assq 'explicit-name tab-to-rename)) tab-explicit-name) (if (tab-bar-mode) (force-mode-line-update) (message "Renamed tab to '%s'" tab-new-name)))) @@ -696,7 +698,7 @@ function `tab-bar-tab-name-function'." (interactive (list (completing-read "Rename tab by name: " (mapcar (lambda (tab) (cdr (assq 'name tab))) - (tab-bar-tabs))) + (funcall tab-bar-tabs-function))) (read-from-minibuffer "New name for tab (leave blank for automatic naming): "))) (tab-bar-rename-tab new-name (tab-bar--tab-index-by-name tab-name))) @@ -753,7 +755,7 @@ For more information, see the function `tab-bar-list'." (let* ((tabs (delq nil (mapcar (lambda (tab) ; remove current tab (unless (eq (car tab) 'current-tab) tab)) - (tab-bar-tabs)))) + (funcall tab-bar-tabs-function)))) ;; Sort by recency (tabs (sort tabs (lambda (a b) (< (cdr (assq 'time b)) (cdr (assq 'time a))))))) @@ -895,7 +897,7 @@ Then move up one line. Prefix arg means move that many lines." (defun tab-bar-list-delete-from-list (tab) "Delete the window configuration from both lists." - (set-frame-parameter nil 'tabs (delq tab (tab-bar-tabs)))) + (set-frame-parameter nil 'tabs (delq tab (funcall tab-bar-tabs-function)))) (defun tab-bar-list-execute () "Delete window configurations marked with \\\\[tab-bar-list-delete] commands." commit bf112e23ef7b2939ff40c0c1f94adce4ffa79187 Author: Robert Cochran Date: Mon Oct 7 13:41:47 2019 -0700 Allow tabs to have consistent given names * lisp/tab-bar.el (tab-bar--tab): Pull automatic name information from current tab (tab-bar--current-tab): Pull automatic name information from current tab, or from new optional template argument (tab-bar-select-tab): Pass the target tab as a template when setting it as current tab (tab-bar-rename-tab, tab-bar-rename-tab-by-name): New functions * doc/emacs/frames.texi (Tab Bars): Document new tab rename functionality. diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi index f93c5b168b..452c167c72 100644 --- a/doc/emacs/frames.texi +++ b/doc/emacs/frames.texi @@ -1282,6 +1282,10 @@ runs @code{find-file-other-tab}. @xref{Visiting}. @item C-x 6 d @var{directory} @key{RET} Select a Dired buffer for directory @var{directory} in another tab. This runs @code{dired-other-tab}. @xref{Dired}. +@item C-x 6 r @var{tabname} @key{RET} +Renames the current tab to @var{tabname}. You can control the +programmatic name given to a tab by default by customizing the +variable @code{tab-bar-tab-name-function}. @end table @vindex tab-bar-new-tab-choice diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index f9d4de4ebf..32d7f6c784 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -359,9 +359,13 @@ Return its existing value or a new value." (let* ((separator (or tab-bar-separator (if window-system " " "|"))) (i 0) (tabs (funcall tab-bar-tabs-function)) - (current-tab-name (assq 'name (assq 'current-tab tabs)))) - (when current-tab-name - (setf (cdr current-tab-name) (funcall tab-bar-tab-name-function))) + (current-tab-name (assq 'name (assq 'current-tab tabs))) + (current-tab-explicit-name (assq 'explicit-name (assq 'current-tab tabs)))) + (when (and current-tab-name + current-tab-explicit-name + (not (cdr current-tab-explicit-name))) + (setf (cdr current-tab-name) + (funcall tab-bar-tab-name-function))) (append '(keymap (mouse-1 . tab-bar-handle-mouse)) (mapcan @@ -413,16 +417,29 @@ Return its existing value or a new value." (defun tab-bar--tab () - `(tab - (name . ,(funcall tab-bar-tab-name-function)) - (time . ,(time-convert nil 'integer)) - (wc . ,(current-window-configuration)) - (ws . ,(window-state-get - (frame-root-window (selected-frame)) 'writable)))) - -(defun tab-bar--current-tab () - `(current-tab - (name . ,(funcall tab-bar-tab-name-function)))) + (let* ((tab (assq 'current-tab (frame-parameter nil 'tabs))) + (tab-explicit-name (cdr (assq 'explicit-name tab)))) + `(tab + (name . ,(if tab-explicit-name + (cdr (assq 'name tab)) + (funcall tab-bar-tab-name-function))) + (explicit-name . ,tab-explicit-name) + (time . ,(time-convert nil 'integer)) + (wc . ,(current-window-configuration)) + (ws . ,(window-state-get + (frame-root-window (selected-frame)) 'writable))))) + +(defun tab-bar--current-tab (&optional tab) + ;; `tab` here is an argument meaning 'use tab as template'. This is + ;; necessary when switching tabs, otherwise the destination tab + ;; inherit the current tab's `explicit-name` parameter. + (let* ((tab (or tab (assq 'current-tab (frame-parameter nil 'tabs)))) + (tab-explicit-name (cdr (assq 'explicit-name tab)))) + `(current-tab + (name . ,(if tab-explicit-name + (cdr (assq 'name tab)) + (funcall tab-bar-tab-name-function))) + (explicit-name . ,tab-explicit-name)))) (defun tab-bar--current-tab-index (&optional tabs) ;; FIXME: could be replaced with 1-liner using seq-position @@ -491,7 +508,7 @@ to the numeric argument. ARG counts from 1." (when from-index (setf (nth from-index tabs) from-tab)) - (setf (nth to-index tabs) (tab-bar--current-tab))) + (setf (nth to-index tabs) (tab-bar--current-tab (nth to-index tabs)))) (when tab-bar-mode (force-mode-line-update))))) @@ -649,16 +666,51 @@ TO-INDEX counts from 1." (force-mode-line-update) (message "Deleted all other tabs"))))) +(defun tab-bar-rename-tab (name &optional arg) + "Rename the tab specified by its absolute position ARG. +If no ARG is specified, then rename the current tab. +ARG counts from 1. +If NAME is the empty string, then use the automatic name +function `tab-bar-tab-name-function'." + (interactive "sNew name for tab (leave blank for automatic naming): \nP") + (let* ((tabs (tab-bar-tabs)) + (tab-index (if arg + (1- (max 0 (min arg (length tabs)))) + (tab-bar--current-tab-index tabs))) + (tab-to-rename (nth tab-index tabs)) + (tab-explicit-name (> (length name) 0)) + (tab-new-name (if tab-explicit-name + name + (funcall tab-bar-tab-name-function)))) + (setf (cdr (assq 'name tab-to-rename)) tab-new-name + (cdr (assq 'explicit-name tab-to-rename)) tab-explicit-name + (frame-parameter nil 'tabs) tabs) + (if (tab-bar-mode) + (force-mode-line-update) + (message "Renamed tab to '%s'" tab-new-name)))) + +(defun tab-bar-rename-tab-by-name (tab-name new-name) + "Rename the tab named TAB-NAME. +If NEW-NAME is the empty string, then use the automatic name +function `tab-bar-tab-name-function'." + (interactive (list (completing-read "Rename tab by name: " + (mapcar (lambda (tab) + (cdr (assq 'name tab))) + (tab-bar-tabs))) + (read-from-minibuffer "New name for tab (leave blank for automatic naming): "))) + (tab-bar-rename-tab new-name (tab-bar--tab-index-by-name tab-name))) + ;;; Short aliases -(defalias 'tab-new 'tab-bar-new-tab) -(defalias 'tab-close 'tab-bar-close-tab) +(defalias 'tab-new 'tab-bar-new-tab) +(defalias 'tab-close 'tab-bar-close-tab) (defalias 'tab-close-other 'tab-bar-close-other-tabs) -(defalias 'tab-select 'tab-bar-select-tab) -(defalias 'tab-next 'tab-bar-switch-to-next-tab) -(defalias 'tab-previous 'tab-bar-switch-to-prev-tab) -(defalias 'tab-list 'tab-bar-list) +(defalias 'tab-select 'tab-bar-select-tab) +(defalias 'tab-next 'tab-bar-switch-to-next-tab) +(defalias 'tab-previous 'tab-bar-switch-to-prev-tab) +(defalias 'tab-rename 'tab-bar-rename-tab) +(defalias 'tab-list 'tab-bar-list) ;;; Non-graphical access to frame-local tabs (named window configurations) @@ -915,6 +967,7 @@ Like \\[find-file-other-frame] (which see), but creates a new tab." (define-key ctl-x-6-map "b" 'switch-to-buffer-other-tab) (define-key ctl-x-6-map "f" 'find-file-other-tab) (define-key ctl-x-6-map "\C-f" 'find-file-other-tab) +(define-key ctl-x-6-map "r" 'tab-rename) (provide 'tab-bar) commit 56a7c60872272eef2dbd4fd071d0af0441f374d8 Author: Juri Linkov Date: Tue Oct 15 23:38:18 2019 +0300 * lisp/tab-bar.el (tab-bar-select-tab-modifiers): New defcustom. (tab-bar-mode): Use tab-bar-select-tab-modifiers to bind tab-bar-select-tab. Don't override user customized key bindings of C-TAB, C-S-TAB. On disabling tab-bar-mode, unset only keys bound by tab-bar. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 13829efe94..f9d4de4ebf 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -83,6 +83,27 @@ :version "27.1" :group 'tab-bar-faces) + +(defcustom tab-bar-select-tab-modifiers '() + "List of key modifiers for selecting a tab by its index digit. +Possible modifiers are `control', `meta', `shift', `hyper', `super' and +`alt'." + :type '(set :tag "Tab selection key modifiers" + (const control) + (const meta) + (const shift) + (const hyper) + (const super) + (const alt)) + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + ;; Reenable the tab-bar with new keybindings + (tab-bar-mode -1) + (tab-bar-mode 1)) + :group 'tab-bar + :version "27.1") + (define-minor-mode tab-bar-mode "Toggle the tab bar in all graphical frames (Tab Bar mode)." @@ -118,10 +139,27 @@ :ascent center)) tab-bar-close-button)) - (when tab-bar-mode - (global-set-key [(control shift iso-lefttab)] 'tab-previous) - (global-set-key [(control shift tab)] 'tab-previous) - (global-set-key [(control tab)] 'tab-next))) + (if tab-bar-mode + (progn + (when tab-bar-select-tab-modifiers + (dotimes (i 9) + (global-set-key (vector (append tab-bar-select-tab-modifiers + (list (+ i 1 ?0)))) + 'tab-bar-select-tab))) + ;; Don't override user customized key bindings + (unless (global-key-binding [(control tab)]) + (global-set-key [(control tab)] 'tab-next)) + (unless (global-key-binding [(control shift tab)]) + (global-set-key [(control shift tab)] 'tab-previous)) + (unless (global-key-binding [(control shift iso-lefttab)]) + (global-set-key [(control shift iso-lefttab)] 'tab-previous))) + ;; Unset only keys bound by tab-bar + (when (eq (global-key-binding [(control tab)]) 'tab-next) + (global-unset-key [(control tab)])) + (when (eq (global-key-binding [(control shift tab)]) 'tab-previous) + (global-unset-key [(control shift tab)])) + (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous) + (global-unset-key [(control shift iso-lefttab)])))) (defun tab-bar-handle-mouse (event) "Text-mode emulation of switching tabs on the tab bar. commit ffa90546980c71fc0c2355005b382f07405aeeec Author: Juri Linkov Date: Tue Oct 15 22:44:10 2019 +0300 Don't use expand-file-name to find images for tabs. * lisp/tab-bar.el (tab-bar-mode): * lisp/tab-line.el (tab-line-new-button, tab-line-close-button): Remove expand-file-name with data-directory. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 3fe750908b..13829efe94 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -102,25 +102,21 @@ (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-new-button))) ;; This file is pre-loaded so only here we can use the right data-directory: - (let ((file (expand-file-name "images/tabs/new.xpm" data-directory))) - (when (file-exists-p file) - (add-text-properties 0 (length tab-bar-new-button) - `(display (image :type xpm - :file ,file - :margin (2 . 0) - :ascent center)) - tab-bar-new-button)))) + (add-text-properties 0 (length tab-bar-new-button) + `(display (image :type xpm + :file "tabs/new.xpm" + :margin (2 . 0) + :ascent center)) + tab-bar-new-button)) (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-close-button))) ;; This file is pre-loaded so only here we can use the right data-directory: - (let ((file (expand-file-name "images/tabs/close.xpm" data-directory))) - (when (file-exists-p file) - (add-text-properties 0 (length tab-bar-close-button) - `(display (image :type xpm - :file ,file - :margin (2 . 0) - :ascent center)) - tab-bar-close-button)))) + (add-text-properties 0 (length tab-bar-close-button) + `(display (image :type xpm + :file "tabs/close.xpm" + :margin (2 . 0) + :ascent center)) + tab-bar-close-button)) (when tab-bar-mode (global-set-key [(control shift iso-lefttab)] 'tab-previous) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 4397cae255..5f2dd3e6dd 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -130,9 +130,7 @@ If nil, don't show the new tab button." (defvar tab-line-new-button (propertize " + " 'display `(image :type xpm - :file ,(expand-file-name - "images/tabs/new.xpm" - data-directory) + :file "tabs/new.xpm" :margin (2 . 0) :ascent center) 'keymap tab-line-add-map @@ -160,9 +158,7 @@ If nil, don't show it at all." (defvar tab-line-close-button (propertize " x" 'display `(image :type xpm - :file ,(expand-file-name - "images/tabs/close.xpm" - data-directory) + :file "tabs/close.xpm" :margin (2 . 0) :ascent center) 'keymap tab-line-tab-close-map commit 4509aaa5b0666a120fb1e255d52d83d03c46c596 Author: Juri Linkov Date: Tue Oct 15 22:41:40 2019 +0300 New variable tab-bar-position * lisp/cus-start.el: Add customization for tab-bar-position. * src/dispnew.c (syms_of_display): New variable Vtab_bar_position. (adjust_frame_glyphs_for_window_redisplay): Use it. diff --git a/etc/NEWS b/etc/NEWS index d06f0a5952..d6a7231474 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2134,6 +2134,8 @@ disabled: by default, they enable tab-bar-mode in that case. The X resource "tabBar", class "TabBar" enables the tab bar when its value is "on", "yes" or "1". +The variable 'tab-bar-position' specifies where to show the tab bar. + Read the new Info node "(emacs) Tab Bars" for full description of all related features. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 89a96a9f51..d1278192ef 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -591,6 +591,12 @@ since it could result in memory overflow and make Emacs crash." (const :tag "Text-image-horiz" :value text-image-horiz) (const :tag "System default" :value nil)) "24.1") (tool-bar-max-label-size frames integer "24.1") + (tab-bar-position tab-bar boolean "27.1" + :set (lambda (sym val) + (set-default sym val) + ;; Redraw the bars: + (tab-bar-mode -1) + (tab-bar-mode 1))) (auto-hscroll-mode scrolling (choice (const :tag "Don't scroll automatically" diff --git a/src/dispnew.c b/src/dispnew.c index 4dd5ee2a1e..4cdc76f5bc 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -2166,8 +2166,10 @@ adjust_frame_glyphs_for_window_redisplay (struct frame *f) w->pixel_left = 0; w->left_col = 0; - w->pixel_top = FRAME_MENU_BAR_HEIGHT (f); - w->top_line = FRAME_MENU_BAR_LINES (f); + w->pixel_top = FRAME_MENU_BAR_HEIGHT (f) + + (!NILP (Vtab_bar_position) ? FRAME_TOOL_BAR_HEIGHT (f) : 0); + w->top_line = FRAME_MENU_BAR_LINES (f) + + (!NILP (Vtab_bar_position) ? FRAME_TOOL_BAR_LINES (f) : 0); w->total_cols = FRAME_TOTAL_COLS (f); w->pixel_width = (FRAME_PIXEL_WIDTH (f) - 2 * FRAME_INTERNAL_BORDER_WIDTH (f)); @@ -2196,8 +2198,10 @@ adjust_frame_glyphs_for_window_redisplay (struct frame *f) w->pixel_left = 0; w->left_col = 0; - w->pixel_top = FRAME_MENU_BAR_HEIGHT (f) + FRAME_TAB_BAR_HEIGHT (f); - w->top_line = FRAME_MENU_BAR_LINES (f) + FRAME_TAB_BAR_LINES (f); + w->pixel_top = FRAME_MENU_BAR_HEIGHT (f) + + (NILP (Vtab_bar_position) ? FRAME_TAB_BAR_HEIGHT (f) : 0); + w->top_line = FRAME_MENU_BAR_LINES (f) + + (NILP (Vtab_bar_position) ? FRAME_TAB_BAR_LINES (f) : 0); w->total_cols = FRAME_TOTAL_COLS (f); w->pixel_width = (FRAME_PIXEL_WIDTH (f) - 2 * FRAME_INTERNAL_BORDER_WIDTH (f)); @@ -6569,6 +6573,11 @@ See `buffer-display-table' for more information. */); beginning of the next redisplay). */ redisplay_dont_pause = true; + DEFVAR_LISP ("tab-bar-position", Vtab_bar_position, + doc: /* Specify on which side from the tool bar the tab bar shall be. +Possible values are `t' (below the tool bar), `nil' (above the tool bar). +This option affects only builds where the tool bar is not external. */); + pdumper_do_now_and_after_load (syms_of_display_for_pdumper); } commit 6ac99ebb3f623c64379f5c6811f1cdeb6ecac7da Author: Stefan Monnier Date: Tue Oct 15 11:08:03 2019 -0400 * lisp/rect.el (string-rectangle): Inherit input method in minibuffer diff --git a/lisp/rect.el b/lisp/rect.el index 34f79e3ed3..4d4d6146f2 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -520,7 +520,8 @@ Called from a program, takes three args; START, END and STRING." (read-string (format "String rectangle (default %s): " (or (car string-rectangle-history) "")) nil 'string-rectangle-history - (car string-rectangle-history))))))) + (car string-rectangle-history) + 'inherit-input-method)))))) ;; If we undo this change, we want to have the point back where we ;; are now, and not after the first line in the rectangle (which is ;; the first line to be changed by the following command). @@ -613,7 +614,7 @@ with a prefix argument, prompt for START-AT and FORMAT." (apply-on-rectangle 'rectangle-number-line-callback start end format))) -;;; New rectangle integration with kill-ring. +;;; Rectangle integration with kill-ring. ;; FIXME: known problems with the new rectangle support: ;; - lots of commands handle the region without paying attention to its commit 06114b79a5c860fc1eb2393f8167d358d5b55d89 Author: Eric Ludlam Date: Mon Oct 14 20:57:06 2019 -0400 Fix test data broken by removing trailing whitespace. diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index d804db70b3..691f5c15b6 100644 --- a/test/lisp/cedet/srecode-utest-template.el +++ b/test/lisp/cedet/srecode-utest-template.el @@ -215,14 +215,12 @@ Return NIL on success, or a diagnostic on failure." (srecode-utest-output :point "wrapinclude-basic" :name "wrapinclude-basic" :output ";; An includable we could use. -;; -;; Text after a point inserter." +;; \n;; Text after a point inserter." ) (srecode-utest-output :point "wrapinclude-basic2" :name "wrapinclude-basic" :output ";; An includable MOOSE we could use. -;; -;; Text after a point inserter." +;; \n;; Text after a point inserter." :dict-entries '("COMMENT" "MOOSE") ) (srecode-utest-output commit 26f5edf0c8afb0a66071a248854898ccbf66b801 Author: Eric Ludlam Date: Mon Oct 14 20:53:24 2019 -0400 Adapt the CEDET SRecoder getset tests to use ERT These tests were copied from CEDET from SourceForge. Author: Eric Ludlam diff --git a/test/lisp/cedet/srecode-utest-getset.el b/test/lisp/cedet/srecode-utest-getset.el new file mode 100644 index 0000000000..d69a195a12 --- /dev/null +++ b/test/lisp/cedet/srecode-utest-getset.el @@ -0,0 +1,177 @@ +;;; srecode/test-getset.el --- Test the getset inserter. + +;; Copyright (C) 2008, 2009, 2011, 2019 Free Software Foundation, Inc + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Unit tests for the getset inserter application. + +;;(require 'cedet-uutil) +(require 'srecode/semantic) + +;;; Code: +(defvar srecode-utest-getset-pre-fill + "// Test Class for getset tests in c++. + +class myClass { +public: + myClass() { }; + ~myClass() { }; + /** miscFunction + */ + int miscFunction(int); + +private: + int fStartingField; + +}; + +" + "The pre-fill class for the getset tests.") + + +;;; Master Harness +;; +(defvar srecode-utest-getset-testfile + (expand-file-name + (concat (make-temp-name "srecode-utest-getset-") ".cpp") + temporary-file-directory) + "File used to do testing.") + +(ert-deftest srecode-utest-getset-output () + "Test various template insertion options." + (save-excursion + (let ((testbuff (find-file-noselect srecode-utest-getset-testfile)) + (srecode-insert-getset-fully-automatic-flag t)) + + (set-buffer testbuff) + (semantic-mode 1) + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'getset) + + (should (srecode-table)) + ;;(error "No template table found for mode %s" major-mode)) + + (condition-case nil + (erase-buffer) + (error nil)) + + (insert srecode-utest-getset-pre-fill) + (goto-char (point-min)) + + ;; Test PRE FILL + (should-not + (srecode-utest-getset-tagcheck '("public" + "myClass" + "myClass" + "miscFunction" + "private" + "fStartingField"))) + (should-not + (srecode-utest-getset-jumptotag "fStartingField")) + + ;; Startup with fully automatic selection. + (srecode-insert-getset) + + ;; * Post get-set "StartingField" + (should-not + (srecode-utest-getset-tagcheck '("public" + "myClass" + "myClass" + "getStartingField" + "setStartingField" + "miscFunction" + "private" + "fStartingField"))) + + ;; Now try convenience args. + (goto-char (point-min)) + (should-not + (srecode-utest-getset-jumptotag "fStartingField")) + (end-of-line) + (insert "\n") + + (srecode-insert-getset nil "AutoInsertField") + + ;; * Post get-set "AutoInsertField" + (should-not + (srecode-utest-getset-tagcheck '("public" + "myClass" + "myClass" + "getStartingField" + "setStartingField" + "getAutoInsertField" + "setAutoInsertField" + "miscFunction" + "private" + "fStartingField" + "fAutoInsertField"))) + + ;; Make sure all the comments are in the right place. + (should-not + (srecode-utest-getset-jumptotag "miscFunction")) + + (let ((pos (point))) + (skip-chars-backward " \t\n") ; xemacs forward-comment is different. + (forward-comment -1) + (re-search-forward "miscFunction" pos)) + + )) + (when (file-exists-p srecode-utest-getset-testfile) + (delete-file srecode-utest-getset-testfile)) + ) + +(defun srecode-utest-getset-tagcheck (expected-members) + "Make sure that the tags in myClass have EXPECTED-MEMBERS." + (semantic-fetch-tags) + (let* ((mc (semantic-find-tags-by-name "myClass" (current-buffer))) + (mem (semantic-tag-type-members (car mc))) + (fail nil)) + (catch 'fail-early + (while (and mem expected-members) + (when (not (string= (semantic-tag-name (car mem)) + (car expected-members))) + (switch-to-buffer (current-buffer)) + (setq fail (format "Did not find %s in %s" (car expected-members) + (buffer-file-name))) + (throw 'fail-early nil)) + (setq mem (cdr mem) + expected-members (cdr expected-members))) + (when expected-members + (switch-to-buffer (current-buffer)) + (setq fail (format "Did not find all expected tags in class: %s" (buffer-file-name))) + (throw 'fail-early t)) + (when mem + (switch-to-buffer (current-buffer)) + (setq fail (format "Found extra tags in class: %s" (buffer-file-name))))) + + (when fail (message "%s" (buffer-string))) + fail)) + +(defun srecode-utest-getset-jumptotag (tagname) + "Jump to the tag named TAGNAME." + (semantic-fetch-tags) + (let ((fail nil) + (tag (semantic-deep-find-tags-by-name tagname (current-buffer)))) + (if tag + (semantic-go-to-tag (car tag)) + (setq fail (format "Failed to jump to tag %s" tagname))) + fail)) + +(provide 'cedet/srecode/test-getset) +;;; srecode/test-getset.el ends here commit 57a786db5a5c653172f994ff707f8eded3d92168 Author: Eric Ludlam Date: Mon Oct 14 20:52:52 2019 -0400 Adapt the CEDET SRecoder template test to use ERT These tests were copied from CEDET from SourceForge. Author: Eric Ludlam diff --git a/etc/srecode/proj-test.srt b/etc/srecode/proj-test.srt new file mode 100644 index 0000000000..c97016fc44 --- /dev/null +++ b/etc/srecode/proj-test.srt @@ -0,0 +1,37 @@ +;; proj-test.srt --- SRecode template for testing project scoping. + +;; Copyright (C) 2008-2019 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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 . + +set mode "srecode-template-mode" +set escape_start "{{" +set escape_end "}}" + +set application "tests" +set project "/tmp/" + +context test + +template test-project +"A template that only exists for files in /tmp." +---- +Contents doesn't matter. +---- + +;; end diff --git a/etc/srecode/test.srt b/etc/srecode/test.srt index 3bbc33e72d..9689f8f111 100644 --- a/etc/srecode/test.srt +++ b/etc/srecode/test.srt @@ -83,13 +83,13 @@ template gapsomething :blank template inlinetext "Insert text that has no newlines" ---- - *In the middle* +*In the middle* ---- template includable :blank ---- ;; An includable $COMMENT$ we could use. -;; $^$ +;; $INPUTNAME$$^$ ;; Text after a point inserter. ---- @@ -99,6 +99,8 @@ $>WI1:includable$ ---- template wrapinclude-around +sectiondictionary "WI1" +set INPUTNAME "[VAR]" ---- $. + +;;; Commentary: +;; +;; Tests of SRecode template insertion routines and tricks. +;; + + +(require 'srecode/map) +(require 'srecode/insert) +(require 'srecode/dictionary) + + +;;; Code: + +;;; MAP DUMP TESTING +(defun srecode-utest-map-reset () + "Reset, then dump the map of SRecoder templates. +Probably should be called 'describe-srecode-maps'." + (interactive) + (message "SRecode Template Path: %S" srecode-map-load-path) + ;; Interactive call allows us to dump. + (call-interactively 'srecode-get-maps) + (switch-to-buffer "*SRECODE MAP*") + (message (buffer-string)) + ) + +;;; OUTPUT TESTING +;; +(defclass srecode-utest-output () + ((point :initarg :point + :type string + :documentation + "Name of this test point.") + (name :initarg :name + :type string + :documentation + "Name of the template tested.") + (output :initarg :output + :type string + :documentation + "Expected output of the template.") + (dict-entries :initarg :dict-entries + :initform nil + :type list + :documentation + "Additional dictionary entries to specify.") + (pre-fill :initarg :pre-fill + :type (or null string) + :initform nil + :documentation + "Text to prefill a buffer with. +Place cursor on the ! and delete it. +If there is a second !, the put the mark there.")) + "A single template test.") + +(cl-defmethod srecode-utest-test ((o srecode-utest-output)) + "Perform the insertion and test the output. +Assumes that the current buffer is the testing buffer. +Return NIL on success, or a diagnostic on failure." + (let ((fail nil)) + (catch 'fail-early + (with-slots (name (output-1 output) dict-entries pre-fill) o + ;; Prepare buffer: erase content and maybe insert pre-fill + ;; content. + (erase-buffer) + (insert (or pre-fill "")) + (goto-char (point-min)) + (let ((start nil)) + (when (re-search-forward "!" nil t) + (goto-char (match-beginning 0)) + (setq start (point)) + (replace-match "")) + (when (re-search-forward "!" nil t) + (push-mark (match-beginning 0) t t) + (replace-match "")) + (when start (goto-char start))) + + ;; Find a template, perform an insertion and validate the output. + (let ((dict (srecode-create-dictionary)) + (temp (or (srecode-template-get-table + (srecode-table) name "test" 'tests) + (progn + (srecode-map-update-map) + (srecode-template-get-table + (srecode-table) name "test" 'tests)) + (progn + (setq fail (format "Test template \"%s\" for `%s' not loaded!" + name major-mode)) + (throw 'fail-early t) + ))) + (srecode-handle-region-when-non-active-flag t)) + + ;; RESOLVE AND INSERT + (let ((entry dict-entries)) + (while entry + (srecode-dictionary-set-value + dict (nth 0 entry) (nth 1 entry)) + (setq entry (nthcdr 1 entry)))) + + (srecode-insert-fcn temp dict) + + ;; COMPARE THE OUTPUT + (let ((actual (buffer-substring-no-properties + (point-min) (point-max)))) + (if (string= output-1 actual) + nil + + (goto-char (point-max)) + (insert "\n\n ------------- ^^ actual ^^ ------------\n\n + ------------- vv expected vv ------------\n\n" + output-1) + (setq fail + (list (format "Entry %s failed:" (oref o point)) + (buffer-string)) + ))))) + ) + fail)) + +;;; ARG HANDLER +;; +(defun srecode-semantic-handle-:utest (dict) + "Add macros into the dictionary DICT for unit testing purposes." + (srecode-dictionary-set-value dict "UTESTVAR1" "ARG HANDLER ONE") + (srecode-dictionary-set-value dict "UTESTVAR2" "ARG HANDLER TWO") + ) + +(defun srecode-semantic-handle-:utestwitharg (dict) + "Add macros into the dictionary DICT based on other vars in DICT." + (let ((val1 (srecode-dictionary-lookup-name dict "UTWA")) + (nval1 nil)) + ;; If there is a value, mutate it + (if (and val1 (stringp val1)) + (setq nval1 (upcase val1)) + ;; No value, make stuff up + (setq nval1 "NO VALUE")) + + (srecode-dictionary-set-value dict "UTESTARGXFORM" nval1)) + + (let ((dicts (srecode-dictionary-lookup-name dict "UTLOOP"))) + (dolist (D dicts) + ;; For each dictionary, lookup NAME, and transform into + ;; something in DICT instead. + (let ((sval (srecode-dictionary-lookup-name D "NAME"))) + (srecode-dictionary-set-value dict (concat "FOO_" sval) sval) + ))) + ) + +;;; TEST POINTS +;; +(defvar srecode-utest-output-entries + (list + (srecode-utest-output + :point "test1" :name "test" + :output (concat ";; " (user-full-name) "\n" + ";; " (upcase (user-full-name))) ) + (srecode-utest-output + :point "subs" :name "subs" + :output ";; Before Loop +;; After Loop" ) + (srecode-utest-output + :point "firstlast" :name "firstlast" + :output " +;; << -- FIRST +;; I'm First +;; I'm Not Last +;; -- >> + +;; << -- MIDDLE +;; I'm Not First +;; I'm Not Last +;; -- >> + +;; << -- LAST +;; I'm Not First +;; I'm Last +;; -- >> +" ) + (srecode-utest-output + :point "gapsomething" :name "gapsomething" + :output ";; First Line +### ALL ALONE ON A LINE ### +;;Second Line" + :pre-fill ";; First Line +!;;Second Line") + (srecode-utest-output + :point "wrapsomething" :name "wrapsomething" + :output ";; Put this line in front: +;; First Line +;; Put this line at the end:" + :pre-fill "!;; First Line +!") + (srecode-utest-output + :point "inlinetext" :name "inlinetext" + :output ";; A big long comment XX*In the middle*XX with cursor in middle" + :pre-fill ";; A big long comment XX!XX with cursor in middle") + + (srecode-utest-output + :point "wrapinclude-basic" :name "wrapinclude-basic" + :output ";; An includable we could use. +;; +;; Text after a point inserter." + ) + (srecode-utest-output + :point "wrapinclude-basic2" :name "wrapinclude-basic" + :output ";; An includable MOOSE we could use. +;; +;; Text after a point inserter." + :dict-entries '("COMMENT" "MOOSE") + ) + (srecode-utest-output + :point "wrapinclude-around" :name "wrapinclude-around" + :output ";; An includable we could use. +;; [VAR]Intermediate Comments +;; Text after a point inserter." + ) + (srecode-utest-output + :point "wrapinclude-around1" :name "wrapinclude-around" + :output ";; An includable PENGUIN we could use. +;; [VAR]Intermediate Comments +;; Text after a point inserter." + :dict-entries '("COMMENT" "PENGUIN") + ) + (srecode-utest-output + :point "complex-subdict" :name "complex-subdict" + :output ";; I have a cow and a dog.") + (srecode-utest-output + :point "wrap-new-template" :name "wrap-new-template" + :output "template newtemplate +\"A nice doc string goes here.\" +---- +Random text in the new template +---- +bind \"a\"" + :dict-entries '( "NAME" "newtemplate" "KEY" "a" ) + ) + (srecode-utest-output + :point "column-data" :name "column-data" + :output "Table of Values: +Left Justified | Right Justified +FIRST | FIRST +VERY VERY LONG STRIN | VERY VERY LONG STRIN +MIDDLE | MIDDLE +S | S +LAST | LAST") + (srecode-utest-output + :point "custom-arg-handler" :name "custom-arg-handler" + :output "OUTSIDE SECTION: ARG HANDLER ONE +INSIDE SECTION: ARG HANDLER ONE") + (srecode-utest-output + :point "custom-arg-w-arg none" :name "custom-arg-w-arg" + :output "Value of xformed UTWA: NO VALUE") + (srecode-utest-output + :point "custom-arg-w-arg upcase" :name "custom-arg-w-arg" + :dict-entries '( "UTWA" "uppercaseme" ) + :output "Value of xformed UTWA: UPPERCASEME") + (srecode-utest-output + :point "custom-arg-w-subdict" :name "custom-arg-w-subdict" + :output "All items here: item1 item2 item3") + + ;; Test cases for new "section ... end" dictionary syntax + (srecode-utest-output + :point "nested-dictionary-syntax-flat" + :name "nested-dictionary-syntax-flat" + :output "sub item1") + (srecode-utest-output + :point "nested-dictionary-syntax-nesting" + :name "nested-dictionary-syntax-nesting" + :output "item11-item11-item21-item31 item21-item11-item21-item31 item31-item311-item321 ") + (srecode-utest-output + :point "nested-dictionary-syntax-mixed" + :name "nested-dictionary-syntax-mixed" + :output "item1 item2")) + "Test point entries for the template output tests.") + +;;; Master Harness +;; +(defvar srecode-utest-testfile + (expand-file-name (concat (make-temp-name "srecode-utest-") ".srt") temporary-file-directory) + "File used to do testing.") + +(ert-deftest srecode-utest-template-output () + "Test various template insertion options." + (save-excursion + (let ((testbuff (find-file-noselect srecode-utest-testfile))) + + (set-buffer testbuff) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'tests) + + (should (srecode-table major-mode)) + + ;; Loop over the output testpoints. + + (dolist (p srecode-utest-output-entries) + (set-buffer testbuff) ;; XEmacs causes a buffer switch. I don't know why + (should-not (srecode-utest-test p)) + ) + + )) + (when (file-exists-p srecode-utest-testfile) + (delete-file srecode-utest-testfile))) + +;;; Project test +;; +;; Test that "project" specification works ok. + +(ert-deftest srecode-utest-project () + "Test thta project filtering works." + (save-excursion + (let ((testbuff (find-file-noselect srecode-utest-testfile)) + (temp nil)) + + (set-buffer testbuff) + (erase-buffer) + + ;; Load the basics, and test that we can't find the application templates. + (srecode-load-tables-for-mode major-mode) + + (should (srecode-table major-mode)) + + (setq temp (srecode-template-get-table (srecode-table) + "test-project" + "test" + 'tests + )) + (when temp + (should-not "App Template Loaded when not specified.")) + + ;; Load the application templates, and make sure we can find them. + (srecode-load-tables-for-mode major-mode 'tests) + + (setq temp (srecode-template-get-table (srecode-table) + "test-project" + "test" + 'tests + )) + + (when (not temp) + (should-not "Failed to load app specific template when available.")) + + ;; Temporarily change the home of this file. This will make the + ;; project template go out of scope. + (let ((default-directory (expand-file-name "~/"))) + + (setq temp (srecode-template-get-table (srecode-table) + "test-project" + "test" + 'tests + )) + + (when temp + (should-not "Project specific template available when in wrong directory.")) + + ))) + (when (file-exists-p srecode-utest-testfile) + (delete-file srecode-utest-testfile))) + + +(provide 'cedet/srecode-utest-template) +;;; srecode-utest-template.el ends here commit 3f8915a0192fe629dc985909c4acd5f80aa78b60 Author: Eric Ludlam Date: Mon Oct 14 20:48:16 2019 -0400 Copy CEDET/Semantic's tag formatter test suite to be an automated test. These tests were copied from CEDET on Sourceforge and adapted to use ERT. Author: Eric Ludlam diff --git a/test/lisp/cedet/semantic-utest-fmt.el b/test/lisp/cedet/semantic-utest-fmt.el new file mode 100644 index 0000000000..88d574e105 --- /dev/null +++ b/test/lisp/cedet/semantic-utest-fmt.el @@ -0,0 +1,129 @@ +;;; cedet/semantic-utest-fmt.el --- Parsing / Formatting tests + +;;; Copyright (C) 2003-2004, 2007-2019 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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: +;; +;; Unit tests for the formatting feature. +;; +;; Using test code from the tests source directory, parse the source +;; file. After parsing, read the comments for each signature, and +;; make sure that the semantic-tag-format-* functions in question +;; created the desired output. + +(require 'semantic) +(require 'semantic/format) + +;;; Code: + +(defvar cedet-utest-directory + (let* ((C (file-name-directory (locate-library "cedet"))) + (D (expand-file-name "../../test/manual/cedet/" C))) + D) + "Location of test files for this test suite.") + +(defvar semantic-fmt-utest-file-list + '("tests/test-fmt.cpp" + ;; "tests/test-fmt.el" - add this when elisp is support by dflt in Emacs + ) + "List of files to run unit tests in.") + +(defvar semantic-fmt-utest-error-log-list nil + "Log errors during testing in this variable.") + +(ert-deftest semantic-fmt-utest () + "Visit all file entries, and run formatting test. +Files to visit are in `semantic-fmt-utest-file-list'." + (save-current-buffer + (semantic-mode 1) + (let ((fl semantic-fmt-utest-file-list) + (fname nil) + ) + + (dolist (FILE fl) + + (save-current-buffer + (setq fname (expand-file-name FILE cedet-utest-directory)) + + ;; Make sure we have the files we think we have. + (should (file-exists-p fname)) + ;; (error "Cannot find unit test file: %s" fname)) + + ;; Run the tests. + (let ((fb (find-buffer-visiting fname)) + (b (semantic-find-file-noselect fname)) + (num 0) + (tags nil)) + + (save-current-buffer + (set-buffer b) + (should (semantic-active-p)) + ;;(error "Cannot open %s for format tests" fname)) + + ;; This will force a reparse, removing any chance of semanticdb cache + ;; using stale data. + (semantic-clear-toplevel-cache) + ;; Force the reparse + (setq tags (semantic-fetch-tags)) + (setq num (length tags)) + + (save-excursion + (while tags + (let* ((T (car tags)) + (start (semantic-tag-end T)) + (end (if (cdr tags) + (semantic-tag-start (car (cdr tags))) + (point-max))) + (TESTS nil) + ) + (goto-char start) + ;; Scan the space between tags for all test condition matches. + (while (re-search-forward "## \\([a-z-]+\\) \"\\([^\n\"]+\\)\"$" end t) + (push (cons (match-string 1) (match-string 2)) TESTS)) + (setq TESTS (nreverse TESTS)) + + (dolist (TST TESTS) + (let* ( ;; For each test, convert CAR into a semantic-format-tag* fcn + (sym (intern (concat "semantic-format-tag-" (car TST)))) + ;; Convert the desired result from a string syntax to a string. + (desired (cdr TST)) + ;; What does the fmt function do? + (actual (funcall sym T)) + ) + (when (not (string= desired actual)) + (should-not (list "Desired" desired + "Actual" actual + "Formatter" (car TST)))) + ))) + (setq tags (cdr tags))) + + )) + + ;; If it wasn't already in memory, whack it. + (when (and b (not fb)) + (kill-buffer b))) + )) + + ))) + + +(provide 'cedet/semantic/fmt-utest) + +;;; semantic-fmt-utest.el ends here diff --git a/test/manual/cedet/tests/test-fmt.cpp b/test/manual/cedet/tests/test-fmt.cpp new file mode 100644 index 0000000000..c94bcfafbc --- /dev/null +++ b/test/manual/cedet/tests/test-fmt.cpp @@ -0,0 +1,108 @@ +/** test-fmt.cpp --- Signatures, and format answers for testing + * + * Copyright (C) 2012, 2016, 2019 Free Software Foundation + * + * Author: Eric M. Ludlam + * + * 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 . + */ + +/* + * About semantic-fmt-utest : + * + * These tests validate two features: + * 1) The C++ parser can parse the different signatures + * 2) The semantic-tag-format-* functions can recreate them. + * + */ + +void basic_fcn() { } +/* + * ## name "basic_fcn" + * ## abbreviate "basic_fcn()" + * ## prototype "void basic_fcn ()" + * ## uml-prototype "basic_fcn () : void" + */ + +int twoargs_fcn(int a, char b) { } +/* + * ## name "twoargs_fcn" + * ## abbreviate "twoargs_fcn()" + * ## prototype "int twoargs_fcn (int a,char b)" + * ## uml-prototype "twoargs_fcn (a : int,b : char) : int" + */ + +struct moose { + int field1; + char field2; +}; +/* + * ## name "moose" + * ## abbreviate "moose{}" + * ## prototype "struct moose {}" + * ## uml-prototype "moose{} : struct" + */ + +struct moose strct_fcn ( struct moose in, char *out); +/* + * ## name "strct_fcn" + * ## abbreviate "strct_fcn()" + * ## prototype "struct moose strct_fcn (struct moose in,char* out)" + * ## uml-prototype "strct_fcn (in : struct moose,out : char*) : struct moose" + */ + +struct moose *var_one = NULL; +/* + * ## name "var_one" + * ## summarize "Variables: struct moose* var_one[=NULL]" + * ## prototype "struct moose* var_one[=NULL]" + * ## uml-prototype "var_one : struct moose*" + */ + +const int var_two = 1; +/* + * ## name "var_two" + * ## summarize "Variables: const int var_two[=1]" + * ## prototype "const int var_two[=1]" + * ## uml-prototype "var_two : int" + */ + +namespace NS { + enum TestEnum {a,b}; +} +/* + * ## name "NS" + * ## summarize "Types: namespace NS {}" + * ## prototype "namespace NS {}" + * ## uml-prototype "NS{} : namespace" + */ + + +// void func_ns_arg(NS::TestEnum v = NS::a); <<--- TODO - bring FIX from CEDET on SF +/* + * # # name "func_ns_arg" + * # # summarize "Functions: void func_ns_arg (NS::TestEnum v[=NS::a])" + * # # prototype "void func_ns_arg (NS::TestEnum v[=NS::a])" + * # # uml-prototype "func_ns_arg (v : NS::TestEnum) : void" + */ + +//int const var_three = 1; +/* + * # # name "var_three" + * # # summarize "Variables: int const var_three" <-- this fails + * # # prototype "int const var_three" <-- this fails + * # # uml-prototype "var_three : int" + */ diff --git a/test/manual/cedet/tests/test-fmt.el b/test/manual/cedet/tests/test-fmt.el new file mode 100644 index 0000000000..93c04f8e77 --- /dev/null +++ b/test/manual/cedet/tests/test-fmt.el @@ -0,0 +1,65 @@ +;;; test-fmt.el --- test semantic tag formatting + +;;; Copyright (C) 2012, 2019 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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: +;; +;; + +;;; Code: +(require 'semantic) +;; +;; ## name "semantic" +;; ## abbreviate "semantic<>" +;; ## summarize "Requires: semantic" + +(defun test-fmt-1 (a) + "Function with 1 arg.") +;; +;; ## name "test-fmt-1" +;; ## abbreviate "(test-fmt-1)" +;; ## summarize "Defuns: (test-fmt-1 a)" +;; ## short-doc "Function with 1 arg." +;; ## uml-prototype "(test-fmt-1 a)" <-- That is probably wrong. + +(defvar test-fmt-var nil + "Variable test.") +;; +;; ## name "test-fmt-var" +;; ## abbreviate "test-fmt-var" +;; ## summarize "Variables: test-fmt-var" +;; ## short-doc "Variable test." +;; ## uml-prototype "test-fmt-var" + +(defclass test-fmt-class () + ((slot1 :initarg :slot1)) + "Class for testing.") +;; +;; ## name "test-fmt-class" +;; ## abbreviate "test-fmt-class{}" +;; ## summarize "Types: class test-fmt-class {}" +;; ## short-doc "Class for testing." +;; ## uml-prototype "class test-fmt-class {}" + + + +(provide 'test-fmt) + +;;; test-fmt.el ends here commit 128f803197c319807de838550270725ecdedbc7c Author: Eric Ludlam Date: Mon Oct 14 20:46:01 2019 -0400 Update CEDET manual tests so that they run. To run visit test/manual/cedet/cedet-utests.el M-x eval-buffer M-x cedet-utest Author: Eric Ludlam diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 124ede17fd..e4b41f4198 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -607,6 +607,8 @@ SORT-PRED if desired." (chart-bar-quickie 'vertical "Test Bar Chart" '( "U1" "ME2" "C3" "B4" "QT" "EZ") "Items" '( 5 -10 23 20 30 -3) "Values") + (if (not (called-interactively-p 'any)) + (kill-buffer "*Test Bar Chart*")) ) ;;; Sample utility function diff --git a/test/manual/cedet/cedet-utests.el b/test/manual/cedet/cedet-utests.el index b8f08886fe..369dff98f6 100644 --- a/test/manual/cedet/cedet-utests.el +++ b/test/manual/cedet/cedet-utests.el @@ -26,6 +26,20 @@ ;; into one command. (require 'cedet) +(require 'inversion) + +(defvar cedet-utest-directory + (let* ((C (file-name-directory (locate-library "cedet"))) + (D (expand-file-name "../../test/manual/cedet/" C))) + D) + "Location of test files for this test suite.") + +(defvar cedet-utest-libs '("ede-tests" + "semantic-tests" + "srecode-tests" + ) + "List of test srcs that need to be loaded.") + ;;; Code: (defvar cedet-utest-test-alist '( @@ -38,7 +52,9 @@ ;; EZ Image dumping. ("ezimage associations" . ezimage-image-association-dump) - ("ezimage images" . ezimage-image-dump) + ("ezimage images" . (lambda () + (ezimage-image-dump) + (kill-buffer "*Ezimage Images*"))) ;; Pulse ("pulse interactive test" . (lambda () (pulse-test t))) @@ -49,14 +65,17 @@ ;; ;; EIEIO ;; - ("eieio" . (lambda () (let ((lib (locate-library "eieio-tests.el" - t))) - (load-file lib)))) - ("eieio: browser" . eieio-browse) + + ("eieio: browser" . (lambda () + (eieio-browse) + (kill-buffer "*EIEIO OBJECT BROWSE*"))) ("eieio: custom" . (lambda () (require 'eieio-custom) - (customize-variable 'eieio-widget-test))) + (customize-variable 'eieio-widget-test) + (kill-buffer "*Customize Option: Eieio Widget Test*") + )) ("eieio: chart" . (lambda () + (require 'chart) (if noninteractive (message " ** Skipping test in noninteractive mode.") (chart-test-it-all)))) @@ -71,9 +90,9 @@ ;; SEMANTIC ;; ("semantic: lex spp table write" . semantic-lex-spp-write-utest) - ("semantic: multi-lang parsing" . semantic-utest-main) - ("semantic: C preprocessor" . semantic-utest-c) - ("semantic: analyzer tests" . semantic-ia-utest) + ;;("semantic: multi-lang parsing" . semantic-utest-main) + ;;("semantic: C preprocessor" . semantic-utest-c) - Now in automated suite + ;;("semantic: analyzer tests" . semantic-ia-utest) ("semanticdb: data cache" . semantic-test-data-cache) ("semantic: throw-on-input" . (lambda () @@ -81,14 +100,17 @@ (message " ** Skipping test in noninteractive mode.") (semantic-test-throw-on-input)))) - ("semantic: gcc: output parse test" . semantic-gcc-test-output-parser) + ;;("semantic: gcc: output parse test" . semantic-gcc-test-output-parser) + ;; ;; SRECODE ;; - ("srecode: fields" . srecode-field-utest) - ("srecode: templates" . srecode-utest-template-output) + + ;; TODO - fix the fields test + ;;("srecode: fields" . srecode-field-utest) + ;;("srecode: templates" . srecode-utest-template-output) ("srecode: show maps" . srecode-get-maps) - ("srecode: getset" . srecode-utest-getset-output) + ;;("srecode: getset" . srecode-utest-getset-output) ) "Alist of all the tests in CEDET we should run.") @@ -100,9 +122,11 @@ EXIT-ON-ERROR causes the test suite to exit on an error, instead of just logging the error." (interactive) - (if (or (not (featurep 'semanticdb-mode)) + (if (or (not (featurep 'semantic/db-mode)) (not (semanticdb-minor-mode-p))) - (error "CEDET Tests require: M-x semantic-load-enable-minimum-features")) + (error "CEDET Tests require semantic-mode to be enabled")) + (dolist (L cedet-utest-libs) + (load-file (expand-file-name (concat L ".el") cedet-utest-directory))) (cedet-utest-log-setup "ALL TESTS") (let ((tl cedet-utest-test-alist) (notes nil) @@ -489,7 +513,7 @@ When optional NO-ERROR don't throw an error if we can't run tests." (when (interactive-p) (message " Pulse line a specific color.") (read-char)) - (pulse-momentary-highlight-one-line (point) 'modeline) + (pulse-momentary-highlight-one-line (point) 'mode-line) (when (interactive-p) (message " Pulse a pre-existing overlay.") (read-char)) diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el index 9109d665fa..ce6467dedd 100644 --- a/test/manual/cedet/semantic-tests.el +++ b/test/manual/cedet/semantic-tests.el @@ -228,13 +228,16 @@ Analyze the area between BEG and END." (defun semantic-lex-spp-write-utest () "Unit test using the test spp file to test the slot write fcn." (interactive) - (let* ((sem (locate-library "semantic-lex-spp.el")) - (dir (file-name-directory sem))) - (save-excursion - (set-buffer (find-file-noselect - (expand-file-name "tests/testsppreplace.c" - dir))) - (semantic-lex-spp-write-test)))) + (save-excursion + (let ((buff (find-file-noselect + (expand-file-name "tests/testsppreplace.c" + cedet-utest-directory)))) + (set-buffer buff) + (semantic-lex-spp-write-test) + (kill-buffer buff) + (when (not (interactive-p)) + (kill-buffer "*SPP Write Test*")) + ))) ;;; From semantic-tag-write: diff --git a/test/manual/cedet/srecode-tests.el b/test/manual/cedet/srecode-tests.el index 94c5dbbd95..355bc0715d 100644 --- a/test/manual/cedet/srecode-tests.el +++ b/test/manual/cedet/srecode-tests.el @@ -243,7 +243,7 @@ It is filled with some text." ;;; From srecode-document: -(require 'srecode/doc) +(require 'srecode/document) (defun srecode-document-function-comment-extract-test () "Test old comment extraction. commit a99812ee0fb7245d4ee3a862f3139c0a53a8c5d7 Author: Eric Ludlam Date: Mon Oct 14 20:43:28 2019 -0400 Convert manual CEDET tests from test/manual/cedet to be automated tests in test/lisp/cedet. Author: Eric Ludlam diff --git a/test/lisp/cedet/semantic-utest-c.el b/test/lisp/cedet/semantic-utest-c.el new file mode 100644 index 0000000000..a6a5fd1625 --- /dev/null +++ b/test/lisp/cedet/semantic-utest-c.el @@ -0,0 +1,181 @@ +;;; semantic-utest-c.el --- C based parsing tests. + +;; Copyright (C) 2008-2019 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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: +;; +;; Run some C based parsing tests. + +(require 'ert) +(require 'semantic) + +(defvar semantic-utest-c-comparisons + '( ("testsppreplace.c" . "testsppreplaced.c") + ) + "List of files to parse and compare against each other.") + +(defvar cedet-utest-directory + (let* ((C (file-name-directory (locate-library "cedet"))) + (D (expand-file-name "../../test/manual/cedet/" C))) + D) + "Location of test files for this test suite.") + +(defvar semantic-utest-c-test-directory (expand-file-name "tests" cedet-utest-directory) + "Location of test files.") + +;;; Code: +;;;###autoload +(ert-deftest semantic-test-c-preprocessor-simulation () + "Run parsing test for C from the test directory." + (interactive) + (semantic-mode 1) + (dolist (fp semantic-utest-c-comparisons) + (let* ((semantic-lex-c-nested-namespace-ignore-second nil) + (tags-actual + (save-excursion + (set-buffer (find-file-noselect (expand-file-name (car fp) semantic-utest-c-test-directory))) + (semantic-clear-toplevel-cache) + (semantic-fetch-tags))) + (tags-expected + (save-excursion + (set-buffer (find-file-noselect (expand-file-name (cdr fp) semantic-utest-c-test-directory))) + (semantic-clear-toplevel-cache) + (semantic-fetch-tags)))) + (when (or (not tags-expected) (not tags-actual)) + (message "Tried to find test files in: %s" semantic-utest-c-test-directory) + (error "Failed: Disovered no tags in test files or test file not found.")) + + ;; Now that we have the tags, compare them for SPP accuracy. + (dolist (tag tags-actual) + (if (and (semantic-tag-of-class-p tag 'variable) + (semantic-tag-variable-constant-p tag)) + nil ; skip the macros. + + (if (semantic-tag-similar-with-subtags-p tag (car tags-expected)) + (setq tags-expected (cdr tags-expected)) + (with-mode-local c-mode + (should nil) ;; this is a fail condition + (message "Error: Found: >> %s << Expected: >> %s <<" + (semantic-format-tag-prototype tag nil t) + (semantic-format-tag-prototype (car tags-expected) nil t) + ))) + )) + ))) + +(require 'semantic/bovine/gcc) + +;; Example output of "gcc -v" +(defvar semantic-gcc-test-strings + '(;; My old box: + "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux +Thread model: posix +gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)" + ;; Alex Ott: + "Using built-in specs. +Target: i486-linux-gnu +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu +Thread model: posix +gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)" + ;; My debian box: + "Using built-in specs. +Target: x86_64-unknown-linux-gnu +Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib +Thread model: posix +gcc version 4.2.3" + ;; My mac: + "Using built-in specs. +Target: i686-apple-darwin8 +Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8 +Thread model: posix +gcc version 4.0.1 (Apple Computer, Inc. build 5341)" + ;; Ubuntu Intrepid + "Using built-in specs. +Target: x86_64-linux-gnu +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu +Thread model: posix +gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" + ;; Red Hat EL4 + "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux +Thread model: posix +gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)" + ;; Red Hat EL5 + "Using built-in specs. +Target: x86_64-redhat-linux +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux +Thread model: posix +gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)" + ;; David Engster's german gcc on ubuntu 4.3 + "Es werden eingebaute Spezifikationen verwendet. +Ziel: i486-linux-gnu +Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu +Thread-Modell: posix +gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" + ;; Damien Deville bsd + "Using built-in specs. +Target: i386-undermydesk-freebsd +Configured with: FreeBSD/i386 system compiler +Thread model: posix +gcc version 4.2.1 20070719 [FreeBSD]" + ) + "A bunch of sample gcc -v outputs from different machines.") + +(defvar semantic-gcc-test-strings-fail + '(;; A really old solaris box I found + "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs +gcc version 2.95.2 19991024 (release)" + ) + "A bunch of sample gcc -v outputs that fail to provide the info we want.") + +(ert-deftest semantic-test-gcc-output-parser () + "Test the output parser against some collected strings." + (let ((fail nil)) + (dolist (S semantic-gcc-test-strings) + (let* ((fields (semantic-gcc-fields S)) + (v (cdr (assoc 'version fields))) + (h (or (cdr (assoc 'target fields)) + (cdr (assoc '--target fields)) + (cdr (assoc '--host fields)))) + (p (cdr (assoc '--prefix fields))) + ) + ;; No longer test for prefixes. + (when (not (and v h)) + (let ((strs (split-string S "\n"))) + (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p) + )) + (should (and v h)) + )) + (dolist (S semantic-gcc-test-strings-fail) + (let* ((fields (semantic-gcc-fields S)) + (v (cdr (assoc 'version fields))) + (h (or (cdr (assoc '--host fields)) + (cdr (assoc 'target fields)))) + (p (cdr (assoc '--prefix fields))) + ) + ;; negative test + (should-not (and v h p)) + )) + )) + + +(provide 'semantic-utest-c) + +;;; semantic-utest-c.el ends here diff --git a/test/manual/cedet/semantic-ia-utest.el b/test/lisp/cedet/semantic-utest-ia.el similarity index 59% rename from test/manual/cedet/semantic-ia-utest.el rename to test/lisp/cedet/semantic-utest-ia.el index 10f02b3c34..f83a89a868 100644 --- a/test/manual/cedet/semantic-ia-utest.el +++ b/test/lisp/cedet/semantic-utest-ia.el @@ -1,4 +1,4 @@ -;;; semantic-ia-utest.el --- Analyzer unit tests +;;; semantic-utest-ia.el --- Analyzer unit tests ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. @@ -35,101 +35,77 @@ (require 'semantic/symref) (require 'semantic/symref/filter) -(load-file "cedet-utests.el") - -(defvar semantic-ia-utest-file-list - '( - "tests/testdoublens.cpp" - "tests/testsubclass.cpp" - "tests/testtypedefs.cpp" - "tests/testfriends.cpp" - "tests/testnsp.cpp" - "tests/testsppcomplete.c" - "tests/testvarnames.c" - "tests/testjavacomp.java" - ) - "List of files with analyzer completion test points.") - -(defvar semantic-ia-utest-error-log-list nil - "List of errors occurring during a run.") - -;;;###autoload -(defun semantic-ia-utest (&optional arg) - "Run the semantic ia unit test against stored sources. -Argument ARG specifies which set of tests to run. - 1 - ia utests - 2 - regs utests - 3 - symrefs utests - 4 - symref count utests" - (interactive "P") - (save-excursion - - (let ((fl semantic-ia-utest-file-list) - (semantic-ia-utest-error-log-list nil) - ) - - (cedet-utest-log-setup "ANALYZER") - - (set-buffer (semantic-find-file-noselect - (or (locate-library "semantic-ia-utest.el") - "semantic-ia-utest.el"))) - - (while fl - - ;; Make sure we have the files we think we have. - (when (not (file-exists-p (car fl))) - (error "Cannot find unit test file: %s" (car fl))) - - ;; Run the tests. - (let ((fb (find-buffer-visiting (car fl))) - (b (semantic-find-file-noselect (car fl) t))) - - ;; Run the test on it. - (save-excursion - (set-buffer b) - - ;; This line will also force the include, scope, and typecache. - (semantic-clear-toplevel-cache) - ;; Force tags to be parsed. - (semantic-fetch-tags) - - (semantic-ia-utest-log " ** Starting tests in %s" - (buffer-name)) - - (when (or (not arg) (= arg 1)) - (semantic-ia-utest-buffer)) - - (when (or (not arg) (= arg 2)) - (set-buffer b) - (semantic-ia-utest-buffer-refs)) - - (when (or (not arg) (= arg 3)) - (set-buffer b) - (semantic-sr-utest-buffer-refs)) - - (when (or (not arg) (= arg 4)) - (set-buffer b) - (semantic-src-utest-buffer-refs)) - - (semantic-ia-utest-log " ** Completed tests in %s\n" - (buffer-name)) - ) - - ;; If it wasn't already in memory, whack it. - (when (not fb) - (kill-buffer b)) - ) - (setq fl (cdr fl))) - - (cedet-utest-log-shutdown - "ANALYZER" - (when semantic-ia-utest-error-log-list - (format "%s Failures found." - (length semantic-ia-utest-error-log-list)))) - (when semantic-ia-utest-error-log-list - (error "Failures found during analyzer unit tests")) - )) - ) +(defvar cedet-utest-directory + (let* ((C (file-name-directory (locate-library "cedet"))) + (D (expand-file-name "../../test/manual/cedet/" C))) + D) + "Location of test files for this test suite.") + +(defvar semantic-utest-test-directory (expand-file-name "tests" cedet-utest-directory) + "Location of test files.") + +(ert-deftest semantic-utest-ia-doublens.cpp () + (let ((tst (expand-file-name "testdoublens.cpp" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-subclass.cpp () + (let ((tst (expand-file-name "testsubclass.cpp" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-typedefs.cpp () + (let ((tst (expand-file-name "testtypedefs.cpp" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-friends.cpp () + (let ((tst (expand-file-name "testfriends.cpp" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-namespace.cpp () + (let ((tst (expand-file-name "testnsp.cpp" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-sppcomplete.c () + (let ((tst (expand-file-name "testsppcomplete.c" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-varnames.c () + (let ((tst (expand-file-name "testvarnames.c" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +(ert-deftest semantic-utest-ia-javacomp.java () + (let ((tst (expand-file-name "testjavacomp.java" semantic-utest-test-directory))) + (should (file-exists-p tst)) + (should-not (semantic-ia-utest tst)))) + +;;; Core testing utility +(defun semantic-ia-utest (testfile) + "Run the semantic ia unit test against stored sources." + (semantic-mode 1) + (let ((b (semantic-find-file-noselect testfile t))) + + ;; Run the test on it. + (with-current-buffer b + + ;; This line will also force the include, scope, and typecache. + (semantic-clear-toplevel-cache) + ;; Force tags to be parsed. + (semantic-fetch-tags) + + (prog1 + (or (semantic-ia-utest-buffer) + (semantic-ia-utest-buffer-refs) + (semantic-sr-utest-buffer-refs) + (semantic-src-utest-buffer-refs)) + + (kill-buffer b) + )))) (defun semantic-ia-utest-buffer () "Run analyzer completion unit-test pass in the current buffer." @@ -148,6 +124,7 @@ Argument ARG specifies which set of tests to run. (semanticdb-find-default-throttle (remq 'system semanticdb-find-default-throttle)) ) + ;; Keep looking for test points until we run out. (while (save-excursion (setq regex-p (concat "//\\s-*-" (number-to-string idx) "-" ) @@ -182,29 +159,19 @@ Argument ARG specifies which set of tests to run. (if (equal actual desired) (setq pass (cons idx pass)) - (setq fail (cons idx fail)) - (semantic-ia-utest-log - " Failed %d. Desired: %S Actual %S" - idx desired actual) - (add-to-list 'semantic-ia-utest-error-log-list - (list (buffer-name) idx desired actual) - ) - - ) - ) + (setq fail (cons + (list + (format "Failed %d. Desired: %S Actual %S" + idx desired actual) + ) + fail))) (setq p nil a nil) (setq idx (1+ idx))) + ) - (if fail - (progn - (semantic-ia-utest-log - " Unit tests (completions) failed tests %S" - (reverse fail)) - ) - (semantic-ia-utest-log " Unit tests (completions) passed (%d total)" - (- idx 1))) - + (when fail + (cons "COMPLETION SUBTEST" fail)) )) (defun semantic-ia-utest-buffer-refs () @@ -287,34 +254,22 @@ Argument ARG specifies which set of tests to run. (throw 'failed t) ))) - (if (not pf) + (if (not pf) ;; We passed (setq pass (cons idx pass)) ;; We failed. - (setq fail (cons idx fail)) - (semantic-ia-utest-log - " Failed %d. For %s (Num impls %d) (Num protos %d)" - idx (if ct (semantic-tag-name ct) "") - (length impl) (length proto)) - (add-to-list 'semantic-ia-utest-error-log-list - (list (buffer-name) idx) - ) + (setq fail (cons + (list + (message "Test id %d. For %s (Num impls %d) (Num protos %d)" + idx (if ct (semantic-tag-name ct) "") + (length impl) (length proto)) + ) + fail)) )) - (setq p nil) - (setq idx (1+ idx)) - - )) - - (if fail - (progn - (semantic-ia-utest-log - " Unit tests (refs) failed tests") - ) - (semantic-ia-utest-log " Unit tests (refs) passed (%d total)" - (- idx 1))) - - )) + (setq idx (1+ idx)))) + (when fail + (cons "ANALYZER REF COUNTING SUBTEST" fail)))) (defun semantic-sr-utest-buffer-refs () "Run a symref unit-test pass in the current buffer." @@ -358,14 +313,7 @@ Argument ARG specifies which set of tests to run. (if (not actual-result) (progn (setq fail (cons idx fail)) - (semantic-ia-utest-log - " Failed FNames %d: No results." idx) - (semantic-ia-utest-log - " Failed Tool: %s" (object-name symref-tool-used)) - - (add-to-list 'semantic-ia-utest-error-log-list - (list (buffer-name) idx) - ) + (message "Failed Tool: %s" (eieio-object-name symref-tool-used)) ) (setq actual (list (sort (mapcar @@ -383,38 +331,28 @@ Argument ARG specifies which set of tests to run. ;; We passed (setq pass (cons idx pass)) ;; We failed. - (setq fail (cons idx fail)) - (when (not (equal (car actual) (car desired))) - (semantic-ia-utest-log - " Failed FNames %d: Actual: %S Desired: %S" - idx (car actual) (car desired)) - (semantic-ia-utest-log - " Failed Tool: %s" (object-name symref-tool-used)) - ) - (when (not (equal (car (cdr actual)) (car (cdr desired)))) - (semantic-ia-utest-log - " Failed TNames %d: Actual: %S Desired: %S" - idx (car (cdr actual)) (car (cdr desired))) - (semantic-ia-utest-log - " Failed Tool: %s" (object-name symref-tool-used)) - ) - (add-to-list 'semantic-ia-utest-error-log-list - (list (buffer-name) idx) - ) + (setq fail + (cons (list + (when (not (equal (car actual) (car desired))) + (list + (format "Actual: %S Desired: %S" + (car actual) (car desired)) + (format "Failed Tool: %s" (eieio-object-name symref-tool-used)) + )) + (when (not (equal (car (cdr actual)) (car (cdr desired)))) + (list (format + "Actual: %S Desired: %S" + (car (cdr actual)) (car (cdr desired))) + (format + "Failed Tool: %s" (eieio-object-name symref-tool-used))))) + fail)) )) (setq idx (1+ idx)) (setq tag nil)) - (if fail - (progn - (semantic-ia-utest-log - " Unit tests (symrefs) failed tests") - ) - (semantic-ia-utest-log " Unit tests (symrefs) passed (%d total)" - (- idx 1))) - - )) + (when fail + (cons "SYMREF SUBTEST" fail)))) (defun semantic-symref-test-count-hits-in-tag () "Lookup in the current tag the symbol under point. @@ -431,10 +369,6 @@ tag that contains point, and return that." target (lambda (start end prefix) (setq Lcount (1+ Lcount))) (semantic-tag-start tag) (semantic-tag-end tag)) - (when (interactive-p) - (message "Found %d occurrences of %s in %.2f seconds" - Lcount (semantic-tag-name target) - (semantic-elapsed-time start nil))) Lcount))) (defun semantic-src-utest-buffer-refs () @@ -474,54 +408,33 @@ tag that contains point, and return that." (if (not actual) (progn - (setq fail (cons idx fail)) - (semantic-ia-utest-log - " Failed symref count %d: No results." idx) + (setq fail (cons + (list + (format + "Symref id %d: No results." idx)) + fail)) - (add-to-list 'semantic-ia-utest-error-log-list - (list (buffer-name) idx) - ) ) (if (equal desired actual) ;; We passed (setq pass (cons idx pass)) ;; We failed. - (setq fail (cons idx fail)) - (when (not (equal actual desired)) - (semantic-ia-utest-log - " Failed symref count %d: Actual: %S Desired: %S" - idx actual desired) - ) - - (add-to-list 'semantic-ia-utest-error-log-list - (list (buffer-name) idx) - ) + (setq fail (cons (list + (when (not (equal actual desired)) + (format + "Symref id %d: Actual: %S Desired: %S" + idx actual desired) + ) + ) + fail)) )) (setq idx (1+ idx)) ) - (if fail - (progn - (semantic-ia-utest-log - " Unit tests (symrefs counter) failed tests") - ) - (semantic-ia-utest-log " Unit tests (symrefs counter) passed (%d total)" - (- idx 1))) - - )) - -(defun semantic-ia-utest-start-log () - "Start up a testlog for a run." - ;; Redo w/ CEDET utest framework. - (cedet-utest-log-start "semantic: analyzer tests")) - -(defun semantic-ia-utest-log (&rest args) - "Log some test results. -Pass ARGS to format to create the log message." - ;; Forward to CEDET utest framework. - (apply 'cedet-utest-log args)) + (when fail + (cons "SYMREF COUNTING SUBTEST" fail)))) (provide 'semantic-ia-utest) diff --git a/test/manual/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el similarity index 81% rename from test/manual/cedet/semantic-utest.el rename to test/lisp/cedet/semantic-utest.el index 102c128355..7303c0ef09 100644 --- a/test/manual/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -26,9 +26,17 @@ ;; and full reparsing system, and anything else I may feel the urge ;; to write a test for. +(require 'cedet) (require 'semantic) -(load-file "cedet-utests.el") +(defvar cedet-utest-directory + (let* ((C (file-name-directory (locate-library "cedet"))) + (D (expand-file-name "../../test/manual/cedet/" C))) + D) + "Location of test files for this test suite.") + +(defvar semantic-utest-test-directory (expand-file-name "tests" cedet-utest-directory) + "Location of test files.") (defvar semantic-utest-temp-directory (if (fboundp 'temp-directory) (temp-directory) @@ -332,8 +340,8 @@ t2:t1 #1 " (define fun1 2) - (define fun2 3 ;1 - ) + (define fun2 3) ;1 + ") (defvar semantic-utest-Scheme-name-contents @@ -493,9 +501,9 @@ Pre-fill the buffer with CONTENTS." ) ) -(defun semantic-utest-C () +(ert-deftest semantic-utest-C () "Run semantic's C unit test." - (interactive) + (semantic-mode 1) (save-excursion (let ((buff (semantic-utest-makebuffer semantic-utest-C-filename semantic-utest-C-buffer-contents)) (buff2 (semantic-utest-makebuffer semantic-utest-C-filename-h semantic-utest-C-h-buffer-contents)) @@ -512,24 +520,19 @@ Pre-fill the buffer with CONTENTS." ;; Update tags, and show it. (semantic-fetch-tags) - (switch-to-buffer buff) - (sit-for 0) - ;; Run the tests. ;;(message "First parsing test.") - (semantic-utest-verify-names semantic-utest-C-name-contents) + (should (semantic-utest-verify-names semantic-utest-C-name-contents)) ;;(message "Invalid tag test.") (semantic-utest-last-invalid semantic-utest-C-name-contents '("fun2") "/\\*1\\*/" "/* Deleted this line */") - (semantic-utest-verify-names semantic-utest-C-name-contents) + (should (semantic-utest-verify-names semantic-utest-C-name-contents)) (set-buffer-modified-p nil) ;; Clean up - ;; (kill-buffer buff) - ;; (kill-buffer buff2) - )) - (message "All C tests passed.") - ) + (kill-buffer buff) + (kill-buffer buff2) + ))) @@ -544,6 +547,7 @@ NAME-CONTENTS is the list of names that should be in the contents. NAMES-REMOVED is the list of names that gets removed in the removal step. KILLME is the name of items to be killed. INSERTME is the text to be inserted after the deletion." + (semantic-mode 1) (save-excursion (let ((buff (semantic-utest-makebuffer filename contents)) ) @@ -554,79 +558,69 @@ INSERTME is the text to be inserted after the deletion." (semantic-highlight-edits-mode 1) ;; Update tags, and show it. + (semantic-clear-toplevel-cache) (semantic-fetch-tags) (switch-to-buffer buff) (sit-for 0) ;; Run the tests. ;;(message "First parsing test %s." testname) - (semantic-utest-verify-names name-contents) + (should (semantic-utest-verify-names name-contents)) ;;(message "Invalid tag test %s." testname) (semantic-utest-last-invalid name-contents names-removed killme insertme) - (semantic-utest-verify-names name-contents) + (should (semantic-utest-verify-names name-contents)) (set-buffer-modified-p nil) ;; Clean up - ;; (kill-buffer buff) - )) - (message "All %s tests passed." testname) - ) + (kill-buffer buff) + ))) -(defun semantic-utest-Python() - (interactive) - (if (fboundp 'python-mode) - (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") - (message "Skilling Python test: NO major mode.")) - ) +(ert-deftest semantic-utest-Python() + (skip-unless (featurep 'python-mode)) + (let ((python-indent-guess-indent-offset nil)) + (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") + )) -(defun semantic-utest-Javascript() - (interactive) +(ert-deftest semantic-utest-Javascript() (if (fboundp 'javascript-mode) (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") (message "Skipping JavaScript test: NO major mode.")) ) -(defun semantic-utest-Java() - (interactive) +(ert-deftest semantic-utest-Java() ;; If JDE is installed, it might mess things up depending on the version ;; that was installed. (let ((auto-mode-alist '(("\\.java\\'" . java-mode)))) (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line") )) -(defun semantic-utest-Makefile() - (interactive) +(ert-deftest semantic-utest-Makefile() (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line") ) -(defun semantic-utest-Scheme() - (interactive) +(ert-deftest semantic-utest-Scheme() + (skip-unless nil) ;; There is a bug w/ scheme parser. Skip this for now. (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line") ) -(defun semantic-utest-Html() - (interactive) +(ert-deftest semantic-utest-Html() ;; Disable html-helper auto-fill-in mode. (let ((html-helper-build-new-buffer nil)) (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "" "") )) -(defun semantic-utest-PHP() - (interactive) - (if (fboundp 'php-mode) - (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") - (message "Skipping PHP Test. No php-mode loaded.")) +(ert-deftest semantic-utest-PHP() + (skip-unless (featurep 'php-mode)) + (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") ) ;look at http://mfgames.com/linux/csharp-mode -(defun semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose - (interactive) - (if (fboundp 'csharp-mode) - (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") - (message "Skipping C# test. No csharp-mode loaded.")) +(ert-deftest semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose + (skip-unless (featurep 'csharp-mode)) + (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -653,32 +647,6 @@ INSERTME is the text to be inserted after the deletion." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;###autoload -(defun semantic-utest-main() - (interactive) - "call all utests" - (cedet-utest-log-start "multi-lang parsing") - (cedet-utest-log " * C tests...") - (semantic-utest-C) - (cedet-utest-log " * Python tests...") - (semantic-utest-Python) - (cedet-utest-log " * Java tests...") - (semantic-utest-Java) - (cedet-utest-log " * Javascript tests...") - (semantic-utest-Javascript) - (cedet-utest-log " * Makefile tests...") - (semantic-utest-Makefile) - (cedet-utest-log " * Scheme tests...") - (semantic-utest-Scheme) - (cedet-utest-log " * Html tests...") - (semantic-utest-Html) - (cedet-utest-log " * PHP tests...") - (semantic-utest-PHP) - (cedet-utest-log " * Csharp tests...") - (semantic-utest-Csharp) - - (cedet-utest-log-shutdown "multi-lang parsing") - ) ;;; Buffer contents validation ;; @@ -724,21 +692,25 @@ SKIPNAMES is a list of names that should be skipped in the NAMES list." (while SN (setq names (remove (car SN) names)) (setq SN (cdr SN)))) - (while (and names table) - (if (not (semantic-utest-equivalent-tag-p (car names) - (car table) - skipnames)) - (error "Expected %s, found %s" - (semantic-format-tag-prototype (car names)) - (semantic-format-tag-prototype (car table)))) - (setq names (cdr names) - table (cdr table))) - (when names (error "Items forgotten: %S" - (mapcar 'semantic-tag-name names) - )) - (when table (error "Items extra: %S" - (mapcar 'semantic-tag-name table))) - t) + (catch 'utest-err + (while (and names table) + (when (not (semantic-utest-equivalent-tag-p (car names) + (car table) + skipnames)) + (message "Semantic Parse Test Fail: Expected %s, found %s" + (semantic-format-tag-prototype (car names)) + (semantic-format-tag-prototype (car table))) + (throw 'utest-err nil) + ) + (setq names (cdr names) + table (cdr table))) + (when names + (message "Semantic Parse Test Fail: Items forgotten: %S" (mapcar 'semantic-tag-name names)) + (throw 'utest-err nil)) + (when table + (message "Semantic parse Test Fail: Items extra: %S" (mapcar 'semantic-tag-name table)) + (throw 'utest-err nil)) + t)) (defun semantic-utest-verify-names (name-contents &optional skipnames) "Verify the names of the test buffer from NAME-CONTENTS. @@ -778,6 +750,9 @@ SKIPNAMES is a list of names to remove from NAME-CONTENTS" ;;; Kill indicator line ;; +;; Utilities to modify the buffer for reparse, making sure a specific tag is deleted +;; via the incremental parser. + (defvar semantic-utest-last-kill-text nil "The text from the last kill.") @@ -806,9 +781,6 @@ SKIPNAMES is a list of names to remove from NAME-CONTENTS" (sit-for 0) ) -;;; EDITING TESTS -;; - (defun semantic-utest-last-invalid (name-contents names-removed killme insertme) "Make the last fcn invalid." (semantic-utest-kill-indicator killme insertme) @@ -818,50 +790,4 @@ SKIPNAMES is a list of names to remove from NAME-CONTENTS" - -;"#]*\\)>" -;#]*\)> -;(overlay \1 \2 "\3") - - -;; JAVE -;; these are some unit tests for cedet that I got from Eric and modified a bit for: -;; python -;; javascript -;; java -;; I tried to generalize the structure of the tests a bit to make it easier to add languages - -;; Mail from Eric: -;; Many items in the checklist look like: - -;; M-x global-semantic-highlight-edits-mode RET -;; - Edit a file. See the highlight of newly inserted text. -;; - Customize `semantic-edits-verbose-flag' to be non-nil. -;; - Wait for the idle scheduler, it should clean up the edits. -;; - observe messages from incremental parser. Do they relate -;; to the edits? -;; - M-x bovinate RET - verify your changes are reflected. - -;; It's all about watching the behavior. Timers go off, things get -;; cleaned up, you type in new changes, etc. An example I tried to -;; do is below, but covers only 1 language, and not very well at that. -;; I seem to remember seeing a unit test framework going by one of the -;; lists. I'm not sure if that would help. - -;; Another that might be automatable: - -;; M-x semantic-analyze-current-context RET -;; - Do this in different contexts in your language -;; files. Verify that reasonable results are returned -;; such as identification of assignments, function arguments, etc. - -;; Anyway, those are some ideas. Any effort you put it will be helpful! - -;; Thanks -;; Eric - -;; ----------- - - - ;;; semantic-utest.el ends here diff --git a/test/manual/cedet/semantic-utest-c.el b/test/manual/cedet/semantic-utest-c.el deleted file mode 100644 index a79c7c8822..0000000000 --- a/test/manual/cedet/semantic-utest-c.el +++ /dev/null @@ -1,72 +0,0 @@ -;;; semantic-utest-c.el --- C based parsing tests. - -;; Copyright (C) 2008-2019 Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam - -;; 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: -;; -;; Run some C based parsing tests. - -(require 'semantic) - -(defvar semantic-utest-c-comparisons - '( ("testsppreplace.c" . "testsppreplaced.c") - ) - "List of files to parse and compare against each other.") - -;;; Code: -;;;###autoload -(defun semantic-utest-c () - "Run parsing test for C from the test directory." - (interactive) - (dolist (fp semantic-utest-c-comparisons) - (let* ((sem (locate-library "semantic")) - (sdir (file-name-directory sem)) - (semantic-lex-c-nested-namespace-ignore-second nil) - (tags-actual - (save-excursion - (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (car fp)) sdir))) - (semantic-clear-toplevel-cache) - (semantic-fetch-tags))) - (tags-expected - (save-excursion - (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (cdr fp)) sdir))) - (semantic-clear-toplevel-cache) - (semantic-fetch-tags)))) - ;; Now that we have the tags, compare them for SPP accuracy. - (dolist (tag tags-actual) - (if (and (semantic-tag-of-class-p tag 'variable) - (semantic-tag-variable-constant-p tag)) - nil ; skip the macros. - (if (semantic-tag-similar-with-subtags-p tag (car tags-expected)) - (setq tags-expected (cdr tags-expected)) - (with-mode-local c-mode - (error "Found: >> %s << Expected: >> %s <<" - (semantic-format-tag-prototype tag nil t) - (semantic-format-tag-prototype (car tags-expected) nil t) - ))) - )) - ;; Passed? - (message "PASSED!") - ))) - - -(provide 'semantic-utest-c) - -;;; semantic-utest-c.el ends here commit 68df7d7069bb0e0a2e804b727fb0f993698c6c9c Author: Robert Pluim Date: Tue Oct 15 14:41:43 2019 +0200 Fix duplicated words in lispref * doc/lispref/text.texi (Base 64): * doc/lispref/internals.texi (Window Internals): Remove duplicated words. diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi index e9fcbf48cb..e870d6e06e 100644 --- a/doc/lispref/internals.texi +++ b/doc/lispref/internals.texi @@ -2402,7 +2402,7 @@ The value of @code{pointm} at the last redisplay time. @item force_start If this flag is non-@code{nil}, it says that the window has been -scrolled explicitly by the Lisp program, and the value of the the +scrolled explicitly by the Lisp program, and the value of the window's @code{start} was set for redisplay to honor. This affects what the next redisplay does if point is off the screen: instead of scrolling the window to show the text around point, it moves point to diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index bf88477adb..4c644f1a62 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -4620,7 +4620,7 @@ the decoded text. The decoding functions ignore newline characters in the encoded text. -If optional argument @var{base64url} is is non-@code{nil}, then padding +If optional argument @var{base64url} is non-@code{nil}, then padding is optional, and the URL variant of base 64 encoding is used. @end deffn commit eda385266e7998c7960f9cf3c35715e7419e6148 Author: Robert Pluim Date: Mon Oct 14 20:31:33 2019 +0200 Fix duplicated words in comments * src/coding.c (encode_string_utf_8): * src/keyboard.c (syms_of_keyboard): * src/mini-gmp.c (gmp_lucas_mod, mpz_export): * src/pdumper.c (dump_set_referrer, dump_queue_compute_score): * src/timefns.c (Ftime_convert): Remove duplicated words. diff --git a/src/coding.c b/src/coding.c index 21e6dc4c19..560ec0883f 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9613,7 +9613,7 @@ get_char_bytes (int c, int *len) byte of the same value. If HANDLE-OVER-UNI is Qt, encode an over-unicode character - into the the same 4 or 5-byte sequence. + into the same 4 or 5-byte sequence. If the two arguments are Qnil, return Qnil if STRING has a non-Unicode character. */ diff --git a/src/keyboard.c b/src/keyboard.c index 40aaf49638..d67d18a801 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -12063,7 +12063,7 @@ and the minor mode maps regardless of `overriding-local-map'. */); The special values `dragging' and `dropping' assert that the mouse cursor retains its appearance during mouse motion. Any non-nil value but `dropping' asserts that motion events always relate to the frame -where the the mouse movement started. The value `dropping' asserts +where the mouse movement started. The value `dropping' asserts that motion events relate to the frame where the mouse cursor is seen when generating the event. If there's no such frame, such motion events relate to the frame where the mouse movement started. */); diff --git a/src/mini-gmp.c b/src/mini-gmp.c index e92e7cf9c7..bf8a616498 100644 --- a/src/mini-gmp.c +++ b/src/mini-gmp.c @@ -3427,7 +3427,7 @@ gmp_lucas_mod (mpz_t V, mpz_t Qk, long Q, gmp_lucas_step_k_2k (V, Qk, n); /* A step k->k+1 is performed if the bit in $n$ is 1 */ - /* mpz_tstbit(n,bs) or the the bit is 0 in $n$ but */ + /* mpz_tstbit(n,bs) or the bit is 0 in $n$ but */ /* should be 1 in $n+1$ (bs == b0) */ if (b0 == bs || mpz_tstbit (n, bs)) { @@ -4492,7 +4492,7 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian, ptrdiff_t word_step; /* The current (partial) limb. */ mp_limb_t limb; - /* The number of bytes left to to in this limb. */ + /* The number of bytes left to do in this limb. */ size_t bytes; /* The index where the limb was read. */ mp_size_t i; diff --git a/src/pdumper.c b/src/pdumper.c index ca272a2e7f..74f198c4ae 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -630,7 +630,7 @@ dump_set_have_current_referrer (struct dump_context *ctx, bool have) #endif } -/* Return true if if objects should be enqueued in CTX to refer to an +/* Return true if objects should be enqueued in CTX to refer to an object that the caller should store into CTX->current_referrer. Until dump_clear_referrer is called, any objects enqueued are being @@ -1093,7 +1093,7 @@ dump_calc_link_score (dump_off basis, return powf (link_score, (float) link_weight / 1000.0f); } -/* Compute the score score for a queued object. +/* Compute the score for a queued object. OBJECT is the object to query, which must currently be queued for dumping. BASIS is the offset at which we would be diff --git a/src/timefns.c b/src/timefns.c index 6afeca1cb3..fe08efd4c1 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1719,7 +1719,7 @@ DEFUN ("time-convert", Ftime_convert, Stime_convert, 1, 2, 0, With optional FORM, convert to that timestamp form. Truncate the returned value toward minus infinity. -If FORM is nil (the default), return the the same form as `current-time'. +If FORM is nil (the default), return the same form as `current-time'. If FORM is a positive integer, return a pair of integers (TICKS . FORM), where TICKS is the number of clock ticks and FORM is the clock frequency in ticks per second. (Currently the positive integer should be at least commit c76b968374e59b0d2c6f652b4f37555374f1ae7d Author: Eli Zaretskii Date: Tue Oct 15 15:09:55 2019 +0300 Fix recording keyboard macros in Calc * lisp/calc/calc.el (calc-unread-command): Prevent recording key twice when defining a keyboard macro. Patch by Christoph Arenz . Copyright-paperwork-exempt: yes diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index ad483b406d..3996c377b1 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -3400,7 +3400,12 @@ See Info node `(calc)Defining Functions'." (cons key key))) (defun calc-unread-command (&optional input) - (push (or input last-command-event) unread-command-events)) + (let ((event (or input last-command-event))) + ;; Avoid recording twice the keys pressed while defining a + ;; keyboard macro. + (when defining-kbd-macro + (setq event (cons 'no-record event))) + (push event unread-command-events))) (defun calc-clear-unread-commands () (setq unread-command-events nil)) commit fcb89237d9ab969bcd29bf8f8fae8d9905644b92 Author: Daiki Ueno Date: Tue Oct 15 12:42:37 2019 +0200 auth-source: Fix wrong-type-argument when searching plstore `auth-source-search' can be called with an integer port number from `network-stream-certificate`, while the backend implementation doesn't allow non-string attributes. * lisp/auth-source.el (auth-source-plstore-search): Ensure attributes are string. diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 1d3d8dba40..fdd869df3a 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -2049,9 +2049,9 @@ entries for git.gnus.org: (if (or (null v) (eq t v)) nil - (if (stringp v) - (setq v (list v))) - (list k v)))) + (list + k + (auth-source-ensure-strings v))))) search-keys))) ;; needed keys (always including host, login, port, and secret) (returned-keys (delete-dups (append commit 42df8cd686f359de7a4f2d8c941ca8f8f05f4e0b Author: Lars Ingebrigtsen Date: Tue Oct 15 11:06:40 2019 +0200 Revert "Remove XEmacs code from tetris.el" This reverts commit 68b91333d5a070c84afeadc273fd5c44df70f0a6. This should be ported to Emacs instead. diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index a8fa7b7586..a797a26d59 100644 --- a/lisp/play/tetris.el +++ b/lisp/play/tetris.el @@ -599,6 +599,17 @@ Drops the shape one square, testing for collision." (use-local-map tetris-null-map) + (unless (featurep 'emacs) + (setq mode-popup-menu + '("Tetris Commands" + ["Start new game" tetris-start-game] + ["End game" tetris-end-game + (tetris-active-p)] + ["Pause" tetris-pause-game + (and (tetris-active-p) (not tetris-paused))] + ["Resume" tetris-pause-game + (and (tetris-active-p) tetris-paused)]))) + (setq show-trailing-whitespace nil) (setq gamegrid-use-glyphs tetris-use-glyphs) commit f33965798bc4e659c0888b66853f3df3faf4e70a Author: Lars Ingebrigtsen Date: Tue Oct 15 11:06:14 2019 +0200 Revert "Remove XEmacs-only code from snake.el" This reverts commit 7174a2b59f4cb883beb70bb3d182d59ab425e2f1. This should be ported to Emacs instead. diff --git a/lisp/play/snake.el b/lisp/play/snake.el index 2769a621a4..d0f9457906 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -368,6 +368,17 @@ Argument SNAKE-BUFFER is the name of the buffer." (use-local-map snake-null-map) + (unless (featurep 'emacs) + (setq mode-popup-menu + '("Snake Commands" + ["Start new game" snake-start-game] + ["End game" snake-end-game + (snake-active-p)] + ["Pause" snake-pause-game + (and (snake-active-p) (not snake-paused))] + ["Resume" snake-pause-game + (and (snake-active-p) snake-paused)]))) + (setq gamegrid-use-glyphs snake-use-glyphs-flag) (setq gamegrid-use-color snake-use-color-flag)