diff options
| author | Kenichi Handa | 2012-11-23 23:36:24 +0900 |
|---|---|---|
| committer | Kenichi Handa | 2012-11-23 23:36:24 +0900 |
| commit | 2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9 (patch) | |
| tree | 3711b97807201b7eeaa066003b1c3a4ce929e5bb /lisp | |
| parent | e1d276cbf9e18f13101328f56bed1a1c0a66e63a (diff) | |
| parent | e7d0e5ee247a155a268ffbf80bedbe25e15b5032 (diff) | |
| download | emacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.tar.gz emacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.zip | |
Diffstat (limited to 'lisp')
54 files changed, 1441 insertions, 940 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ca65e431964..09f42233f96 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,166 @@ | |||
| 1 | 2012-11-23 Chong Yidong <cyd@gnu.org> | ||
| 2 | |||
| 3 | * find-cmd.el (find-constituents): Add executable, ipath, | ||
| 4 | readable, samefile, writable, daystart, regextype (Bug#12856). | ||
| 5 | |||
| 6 | 2012-11-23 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 7 | |||
| 8 | * emacs-lisp/ert.el, emacs-lisp/ert-x.el: Use cl-lib and lexical-binding. | ||
| 9 | |||
| 10 | 2012-11-22 Paul Eggert <eggert@cs.ucla.edu> | ||
| 11 | |||
| 12 | * calc/calc.el (calc-gregorian-switch): Move to after calc-refresh | ||
| 13 | definition. This fixes a bootstrap failure. | ||
| 14 | (calc-gregorian-switch): In menu, put dates before regions. | ||
| 15 | This is easier to follow, lines up better in the menu, and lets us | ||
| 16 | coalesce regions that switch at the same time. Give country | ||
| 17 | names, not "Vatican", as that's better for non-expert users. | ||
| 18 | Use names that are stable between the date of switch and now, e.g., | ||
| 19 | Bohemia and Moravia (which existed then and now) and not | ||
| 20 | Czechoslovakia (which didn't exist then and doesn't exist now). | ||
| 21 | What is now the U.S. mostly did not switch at the same time as | ||
| 22 | Britain, so omit the U.S. Correct spelling of "Britain". | ||
| 23 | Catholic Switzerland was too much of a mess, so omit it. | ||
| 24 | |||
| 25 | 2012-11-22 Jay Belanger <jay.p.belanger@gmail.com> | ||
| 26 | |||
| 27 | * calc/calc.el (calc-gregorian-switch): Refresh the Calc buffer | ||
| 28 | after the variable is changed. | ||
| 29 | |||
| 30 | 2012-11-21 Daniel Colascione <dancol@dancol.org> | ||
| 31 | |||
| 32 | * progmodes/sql.el (sql-mode-font-lock-object-name): Support IF NOT EXISTS | ||
| 33 | in SQL declarations for font-lock. | ||
| 34 | (sql-imenu-generic-expression): Teach imenu about IF NOT EXISTS. | ||
| 35 | |||
| 36 | 2012-11-21 Glenn Morris <rgm@gnu.org> | ||
| 37 | |||
| 38 | * faces.el (face-underline-p, face-inverse-video-p, face-bold-p) | ||
| 39 | (face-italic-p): Add optional argument "inherit". | ||
| 40 | |||
| 41 | * faces.el (set-face-inverse-video, set-face-bold, set-face-italic): | ||
| 42 | Remove -p suffix from names, for consistency with other set-face-*. | ||
| 43 | (set-face-inverse-video): Fix interactive spec. | ||
| 44 | * play/gamegrid.el (gamegrid-make-mono-tty-face): | ||
| 45 | * textmodes/table.el (table--update-cell-face): | ||
| 46 | Use set-face-inverse-video rather than now obsolete alias. | ||
| 47 | |||
| 48 | 2012-11-21 Eli Zaretskii <eliz@gnu.org> | ||
| 49 | |||
| 50 | * simple.el (line-move): Don't call line-move-partial if | ||
| 51 | scroll-conservatively is in effect. (Bug#12927) | ||
| 52 | |||
| 53 | 2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 54 | |||
| 55 | * eshell/em-cmpl.el (eshell-pcomplete): Refine fix for bug#12838: | ||
| 56 | Fallback on completion-at-point rather than | ||
| 57 | pcomplete-expand-and-complete, and only if pcomplete actually failed. | ||
| 58 | (eshell-cmpl-initialize): Setup completion-at-point. | ||
| 59 | |||
| 60 | * pcomplete.el (pcomplete--entries): Obey pcomplete-ignore-case. | ||
| 61 | |||
| 62 | * emacs-lisp/ert.el (ert--expand-should-1): Adapt to cl-lib. | ||
| 63 | |||
| 64 | 2012-11-21 Michael Albinus <michael.albinus@gmx.de> | ||
| 65 | |||
| 66 | * net/tramp-sh.el (tramp-do-copy-or-rename-file): If both files | ||
| 67 | are remote, check out-of-band property for both. | ||
| 68 | |||
| 69 | 2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 70 | |||
| 71 | * window.el (switch-to-buffer): Re-add the warning that was lost in the | ||
| 72 | code rewrite. | ||
| 73 | |||
| 74 | 2012-11-21 Paul Eggert <eggert@cs.ucla.edu> | ||
| 75 | |||
| 76 | More minor time fixes. | ||
| 77 | * calendar/time-date.el: Commentary fix. | ||
| 78 | * net/tramp-sh.el (tramp-do-file-attributes-with-ls): Undo last change; | ||
| 79 | too much other code depends on (0 0) time stamps. | ||
| 80 | * net/tramp.el (tramp-time-less-p, tramp-time-subtract): | ||
| 81 | Add a couple of FIXME comments. | ||
| 82 | |||
| 83 | Minor cleanup for times as lists of four integers. | ||
| 84 | * files.el (dir-locals-directory-cache): | ||
| 85 | * ps-bdf.el (bdf-file-mod-time, bdf-read-font-info): | ||
| 86 | Doc fixes. | ||
| 87 | * net/tramp-sh.el (tramp-do-file-attributes-with-ls): | ||
| 88 | * ps-bdf.el (bdf-file-newer-than-time): | ||
| 89 | Process four-integers time stamps, not two. Doc fixes. | ||
| 90 | |||
| 91 | 2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 92 | |||
| 93 | * uniquify.el (uniquify-managed): Use defvar-local. | ||
| 94 | (rename-buffer, create-file-buffer): Advise with advice-add. | ||
| 95 | (uniquify-unload-function): Unadvise accordingly. | ||
| 96 | |||
| 97 | * emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding. | ||
| 98 | (trace-buffer): Don't purecopy. | ||
| 99 | (trace-entry-message, trace-exit-message): Add `context' arg. | ||
| 100 | (trace--timer): New var. | ||
| 101 | (trace-make-advice): Adjust for use in nadvice. | ||
| 102 | Add `context' argument. Delay `display-buffer' via a timer. | ||
| 103 | (trace-function-internal): Use advice-add. | ||
| 104 | (trace--read-args): New function. | ||
| 105 | (trace-function-foreground, trace-function-background): Use it. | ||
| 106 | (trace-function): Rename to trace-function-foreground and redefine as | ||
| 107 | an alias to that new name. | ||
| 108 | (untrace-function, untrace-all): Adjust to the use of nadvice. | ||
| 109 | |||
| 110 | * emacs-lisp/bytecomp.el (byte-compile): Fix handling of closures. | ||
| 111 | |||
| 112 | * emacs-lisp/byte-run.el (defun-declarations-alist): Fix last change. | ||
| 113 | |||
| 114 | * subr.el (called-interactively-p-functions): New var. | ||
| 115 | (internal--called-interactively-p--get-frame): New macro. | ||
| 116 | (called-interactively-p, interactive-p): Rewrite in Lisp. | ||
| 117 | * emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun. | ||
| 118 | (called-interactively-p-functions): Use it. | ||
| 119 | * emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun. | ||
| 120 | (called-interactively-p-functions): Use it. | ||
| 121 | * allout.el (allout-called-interactively-p): Don't assume | ||
| 122 | called-interactively-p is a subr. | ||
| 123 | |||
| 124 | 2012-11-20 Glenn Morris <rgm@gnu.org> | ||
| 125 | |||
| 126 | * profiler.el (profiler-report-mode-map): Add a menu. | ||
| 127 | No need to bind `q' because we derive from special-mode. | ||
| 128 | (profiler-report-find-entry): Handle calls from the menu-bar. | ||
| 129 | |||
| 130 | 2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 131 | |||
| 132 | * emacs-lisp/byte-run.el (defun-declarations-alist): | ||
| 133 | Allow a compiler-macro to be a lambda expression. | ||
| 134 | |||
| 135 | * progmodes/python.el: Use cl-lib. Move var declarations outside of | ||
| 136 | eval-when-compile. | ||
| 137 | (python-syntax-context): Add compiler-macro. | ||
| 138 | (python-font-lock-keywords): Simplify with De Morgan. | ||
| 139 | |||
| 140 | * vc/diff-mode.el (diff-hunk): Don't make useless timers. | ||
| 141 | |||
| 142 | * files.el (load-file): Require match in minibuffer selection, as was | ||
| 143 | the case in Emacs-20 before we changed the spec to allow .elc files | ||
| 144 | (bug#12935). | ||
| 145 | |||
| 146 | * json.el: Don't require cl since we don't use it. | ||
| 147 | * color.el: Don't require cl. | ||
| 148 | (color-complement): `caddr' -> `nth 2'. | ||
| 149 | |||
| 150 | * calendar/time-date.el (time-to-seconds): De-obsolete. | ||
| 151 | |||
| 152 | 2012-11-19 Jay Belanger <jay.p.belanger@gmail.com> | ||
| 153 | |||
| 154 | * calc/calc-forms.el (math-leap-year-p): Fix formula for negative | ||
| 155 | year numbers. | ||
| 156 | (math-date-to-julian-dt): Adjust the initial approximation for the | ||
| 157 | year to deal with the new definition of the DATE. | ||
| 158 | |||
| 159 | 2012-11-19 Daniel Colascione <dancol@dancol.org> | ||
| 160 | |||
| 161 | * term/w32-win.el (cygwin-convert-path-from-windows): | ||
| 162 | Accomodate rename of cygwin_convert_path* to cygwin_convert_file_name*. | ||
| 163 | |||
| 1 | 2012-11-18 Chong Yidong <cyd@gnu.org> | 164 | 2012-11-18 Chong Yidong <cyd@gnu.org> |
| 2 | 165 | ||
| 3 | * filecache.el (file-cache--read-list): New function. | 166 | * filecache.el (file-cache--read-list): New function. |
| @@ -47,8 +210,10 @@ | |||
| 47 | 210 | ||
| 48 | 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> | 211 | 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> |
| 49 | 212 | ||
| 213 | Calc by default uses the Gregorian calendar for all dates (Bug#12633). | ||
| 214 | It also uses January 1, 1 AD as its day number 1. | ||
| 50 | * calc/calc-forms.el (math-julian-date-beginning) | 215 | * calc/calc-forms.el (math-julian-date-beginning) |
| 51 | (math-julian-date-beginning-int): Implement [new date numbering]. | 216 | (math-julian-date-beginning-int): Implement this. |
| 52 | 217 | ||
| 53 | 2012-11-17 Juanma Barranquero <lekktu@gmail.com> | 218 | 2012-11-17 Juanma Barranquero <lekktu@gmail.com> |
| 54 | 219 | ||
diff --git a/lisp/allout.el b/lisp/allout.el index 04de853ebe0..e93aefd12cc 100644 --- a/lisp/allout.el +++ b/lisp/allout.el | |||
| @@ -1657,10 +1657,9 @@ and the place for the cursor after the decryption is done." | |||
| 1657 | (defmacro allout-called-interactively-p () | 1657 | (defmacro allout-called-interactively-p () |
| 1658 | "A version of `called-interactively-p' independent of Emacs version." | 1658 | "A version of `called-interactively-p' independent of Emacs version." |
| 1659 | ;; ... to ease maintenance of allout without betraying deprecation. | 1659 | ;; ... to ease maintenance of allout without betraying deprecation. |
| 1660 | (if (equal (subr-arity (symbol-function 'called-interactively-p)) | 1660 | (if (ignore-errors (called-interactively-p 'interactive) t) |
| 1661 | '(0 . 0)) | 1661 | '(called-interactively-p 'interactive) |
| 1662 | '(called-interactively-p) | 1662 | '(called-interactively-p))) |
| 1663 | '(called-interactively-p 'interactive))) | ||
| 1664 | ;;;_ = allout-inhibit-aberrance-doublecheck nil | 1663 | ;;;_ = allout-inhibit-aberrance-doublecheck nil |
| 1665 | ;; In some exceptional moments, disparate topic depths need to be allowed | 1664 | ;; In some exceptional moments, disparate topic depths need to be allowed |
| 1666 | ;; momentarily, eg when one topic is being yanked into another and they're | 1665 | ;; momentarily, eg when one topic is being yanked into another and they're |
diff --git a/lisp/calc/README b/lisp/calc/README index 25d1a5e9b58..638b482a60a 100644 --- a/lisp/calc/README +++ b/lisp/calc/README | |||
| @@ -70,11 +70,18 @@ opinions. | |||
| 70 | Summary of changes to "Calc" | 70 | Summary of changes to "Calc" |
| 71 | ------- -- ------- -- ---- | 71 | ------- -- ------- -- ---- |
| 72 | 72 | ||
| 73 | Emacs 24.4 | ||
| 74 | |||
| 75 | * The date forms use the Gregorian calendar for all dates. | ||
| 76 | (Previously they were a combination of Julian and Gregorian | ||
| 77 | dates.) This can be configured with the customizable variable | ||
| 78 | `calc-gregorian-switch'. | ||
| 79 | |||
| 73 | Emacs 24.3 | 80 | Emacs 24.3 |
| 74 | 81 | ||
| 75 | Algebraic simplification mode is now the default. | 82 | * Algebraic simplification mode is now the default. |
| 76 | To restrict to the limited simplifications given by the former | 83 | To restrict to the limited simplifications given by the former |
| 77 | default simplification mode, use `m I'. | 84 | default simplification mode, use `m I'. |
| 78 | 85 | ||
| 79 | Emacs 24.1 | 86 | Emacs 24.1 |
| 80 | 87 | ||
diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 709250f9ba9..98b22550f75 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el | |||
| @@ -371,9 +371,10 @@ | |||
| 371 | ;;; These versions are rewritten to use arbitrary-size integers. | 371 | ;;; These versions are rewritten to use arbitrary-size integers. |
| 372 | 372 | ||
| 373 | ;;; A numerical date is the number of days since midnight on | 373 | ;;; A numerical date is the number of days since midnight on |
| 374 | ;;; the morning of December 31, 1 B.C. Emacs's calendar refers to such | 374 | ;;; the morning of December 31, 1 B.C. (Gregorian) or January 2, 1 A.D. (Julian). |
| 375 | ;;; a date as an absolute date, some function names also use that | 375 | ;;; Emacs's calendar refers to such a date as an absolute date, some Calc function |
| 376 | ;;; terminology. If the date is a non-integer, it represents a specific date and time. | 376 | ;;; names also use that terminology. If the date is a non-integer, it represents |
| 377 | ;;; a specific date and time. | ||
| 377 | ;;; A "dt" is a list of the form, (year month day), corresponding to | 378 | ;;; A "dt" is a list of the form, (year month day), corresponding to |
| 378 | ;;; an integer code, or (year month day hour minute second), corresponding | 379 | ;;; an integer code, or (year month day hour minute second), corresponding |
| 379 | ;;; to a non-integer code. | 380 | ;;; to a non-integer code. |
| @@ -408,8 +409,8 @@ DATE is the number of days since December 31, -1 in the Gregorian calendar." | |||
| 408 | (let* ((month 1) | 409 | (let* ((month 1) |
| 409 | day | 410 | day |
| 410 | (year (math-quotient (math-add date (if (Math-lessp date 711859) | 411 | (year (math-quotient (math-add date (if (Math-lessp date 711859) |
| 411 | 365 ; for speed, we take | 412 | 367 ; for speed, we take |
| 412 | -108)) ; >1950 as a special case | 413 | -106)) ; >1950 as a special case |
| 413 | (if (math-negp date) 366 365))) | 414 | (if (math-negp date) 366 365))) |
| 414 | ; this result may be an overestimate | 415 | ; this result may be an overestimate |
| 415 | temp) | 416 | temp) |
| @@ -494,6 +495,8 @@ Gregorian calendar." | |||
| 494 | (if (math-negp year) | 495 | (if (math-negp year) |
| 495 | (= (math-imod (math-neg year) 4) 1) | 496 | (= (math-imod (math-neg year) 4) 1) |
| 496 | (= (math-imod year 4) 0)) | 497 | (= (math-imod year 4) 0)) |
| 498 | (if (math-negp year) | ||
| 499 | (setq year (math-sub -1 year))) | ||
| 497 | (setq year (math-imod year 400)) | 500 | (setq year (math-imod year 400)) |
| 498 | (or (and (= (% year 4) 0) (/= (% year 100) 0)) | 501 | (or (and (= (% year 4) 0) (/= (% year 100) 0)) |
| 499 | (= year 0)))) | 502 | (= year 0)))) |
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index aeca45ebf26..58eabf9bcec 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el | |||
| @@ -466,50 +466,6 @@ to be identified as that note." | |||
| 466 | 466 | ||
| 467 | (defvar math-format-date-cache) ; calc-forms.el | 467 | (defvar math-format-date-cache) ; calc-forms.el |
| 468 | 468 | ||
| 469 | ;; Dates that are built-in options for `calc-gregorian-switch' should be | ||
| 470 | ;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. | ||
| 471 | (defcustom calc-gregorian-switch nil | ||
| 472 | "The first day the Gregorian calendar is used by Calc's date forms. | ||
| 473 | This is `nil' (the default) if the Gregorian calendar is the only one used. | ||
| 474 | Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use | ||
| 475 | the Gregorian calendar; Calc will use the Julian calendar for earlier dates. | ||
| 476 | The dates in which different regions of the world began to use the | ||
| 477 | Gregorian calendar vary quite a bit, even within a single country. | ||
| 478 | If you want Calc's date forms to switch between the Julian and | ||
| 479 | Gregorian calendar, you can specify the date or choose from several | ||
| 480 | common choices. Some of these choices should be taken with a grain | ||
| 481 | of salt; for example different parts of France changed calendars at | ||
| 482 | different times, and Sweden's change to the Gregorian calendar was | ||
| 483 | complicated. Also, the boundaries of the countries were different at | ||
| 484 | the times of the calendar changes than they are now. | ||
| 485 | The Vatican decided that the Gregorian calendar should take effect | ||
| 486 | on 15 October 1582 (Gregorian), and many Catholic countries made | ||
| 487 | the change then. Great Britian and its colonies had the Gregorian | ||
| 488 | calendar take effect on 14 September 1752 (Gregorian); this includes | ||
| 489 | the United States." | ||
| 490 | :group 'calc | ||
| 491 | :version "24.4" | ||
| 492 | :type '(choice (const :tag "Always use the Gregorian calendar" nil) | ||
| 493 | (const :tag "Great Britian and the US (1752 9 14)" (1752 9 14 639797)) | ||
| 494 | (const :tag "Vatican (1582 10 15)" (1582 10 15 577736)) | ||
| 495 | (const :tag "Czechoslovakia (1584 1 17)" (1584 1 17 578195)) | ||
| 496 | (const :tag "Denmark (1700 3 1)" (1700 3 1 620607)) | ||
| 497 | (const :tag "France (1582 12 20)" (1582 12 20 577802)) | ||
| 498 | (const :tag "Hungary (1587 11 1)" (1587 11 1 579579)) | ||
| 499 | (const :tag "Luxemburg (1582 12 25)" (1582 12 25 577807)) | ||
| 500 | (const :tag "Romania (1919 4 14)" (1919 4 14 700638)) | ||
| 501 | (const :tag "Russia (1918 2 14)" (1918 2 14 700214)) | ||
| 502 | (const :tag "Sweden (1753 3 1)" (1753 3 1 639965)) | ||
| 503 | (const :tag "Switzerland (Catholic) (1584 1 22)" (1584 1 22 578200)) | ||
| 504 | (const :tag "Switzerland (Protestant) (1701 1 12)" (1701 1 12 620924)) | ||
| 505 | (list :tag "(YEAR MONTH DAY)" | ||
| 506 | (integer :tag "Year") | ||
| 507 | (integer :tag "Month (integer)") | ||
| 508 | (integer :tag "Day"))) | ||
| 509 | :set (lambda (symbol value) | ||
| 510 | (set-default symbol value) | ||
| 511 | (setq math-format-date-cache nil))) | ||
| 512 | |||
| 513 | (defface calc-nonselected-face | 469 | (defface calc-nonselected-face |
| 514 | '((t :inherit shadow | 470 | '((t :inherit shadow |
| 515 | :slant italic)) | 471 | :slant italic)) |
| @@ -2066,6 +2022,50 @@ See calc-keypad for details." | |||
| 2066 | (calc-refresh align))) | 2022 | (calc-refresh align))) |
| 2067 | (setq calc-refresh-count (1+ calc-refresh-count))) | 2023 | (setq calc-refresh-count (1+ calc-refresh-count))) |
| 2068 | 2024 | ||
| 2025 | ;; Dates that are built-in options for `calc-gregorian-switch' should be | ||
| 2026 | ;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. | ||
| 2027 | (defcustom calc-gregorian-switch nil | ||
| 2028 | "The first day the Gregorian calendar is used by Calc's date forms. | ||
| 2029 | This is `nil' (the default) if the Gregorian calendar is the only one used. | ||
| 2030 | Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use | ||
| 2031 | the Gregorian calendar; Calc will use the Julian calendar for earlier dates. | ||
| 2032 | The dates in which different regions of the world began to use the | ||
| 2033 | Gregorian calendar vary quite a bit, even within a single country. | ||
| 2034 | If you want Calc's date forms to switch between the Julian and | ||
| 2035 | Gregorian calendar, you can specify the date or choose from several | ||
| 2036 | common choices. Some of these choices should be taken with a grain | ||
| 2037 | of salt; for example different parts of France changed calendars at | ||
| 2038 | different times, and Sweden's change to the Gregorian calendar was | ||
| 2039 | complicated. Also, the boundaries of the countries were different at | ||
| 2040 | the times of the calendar changes than they are now. | ||
| 2041 | The Vatican decided that the Gregorian calendar should take effect | ||
| 2042 | on 15 October 1582 (Gregorian), and many Catholic countries made | ||
| 2043 | the change then. Great Britain and its colonies had the Gregorian | ||
| 2044 | calendar take effect on 14 September 1752 (Gregorian); this includes | ||
| 2045 | the United States." | ||
| 2046 | :group 'calc | ||
| 2047 | :version "24.4" | ||
| 2048 | :type '(choice (const :tag "Always use the Gregorian calendar" nil) | ||
| 2049 | (const :tag "1582-10-15 - Italy, Poland, Portugal, Spain" (1582 10 15 577736)) | ||
| 2050 | (const :tag "1582-12-20 - France" (1582 12 20 577802)) | ||
| 2051 | (const :tag "1582-12-25 - Luxemburg" (1582 12 25 577807)) | ||
| 2052 | (const :tag "1584-01-17 - Bohemia and Moravia" (1584 1 17 578195)) | ||
| 2053 | (const :tag "1587-11-01 - Hungary" (1587 11 1 579579)) | ||
| 2054 | (const :tag "1700-03-01 - Denmark" (1700 3 1 620607)) | ||
| 2055 | (const :tag "1701-01-12 - Protestant Switzerland" (1701 1 12 620924)) | ||
| 2056 | (const :tag "1752-09-14 - Great Britain and dominions" (1752 9 14 639797)) | ||
| 2057 | (const :tag "1753-03-01 - Sweden" (1753 3 1 639965)) | ||
| 2058 | (const :tag "1918-02-14 - Russia" (1918 2 14 700214)) | ||
| 2059 | (const :tag "1919-04-14 - Romania" (1919 4 14 700638)) | ||
| 2060 | (list :tag "(YEAR MONTH DAY)" | ||
| 2061 | (integer :tag "Year") | ||
| 2062 | (integer :tag "Month (integer)") | ||
| 2063 | (integer :tag "Day"))) | ||
| 2064 | :set (lambda (symbol value) | ||
| 2065 | (set-default symbol value) | ||
| 2066 | (setq math-format-date-cache nil) | ||
| 2067 | (calc-refresh))) | ||
| 2068 | |||
| 2069 | ;;;; The Calc Trail buffer. | 2069 | ;;;; The Calc Trail buffer. |
| 2070 | 2070 | ||
| 2071 | (defun calc-check-trail-aligned () | 2071 | (defun calc-check-trail-aligned () |
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 38b766084c9..9cac659d848 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el | |||
| @@ -30,11 +30,10 @@ | |||
| 30 | ;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12 | 30 | ;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12 |
| 31 | ;; seconds, where missing components are treated as zero. HIGH can be | 31 | ;; seconds, where missing components are treated as zero. HIGH can be |
| 32 | ;; negative, either because the value is a time difference, or because | 32 | ;; negative, either because the value is a time difference, or because |
| 33 | ;; the machine supports negative time stamps that fall before the | 33 | ;; the machine supports negative time stamps that fall before the epoch. |
| 34 | ;; epoch. The macro `with-decoded-time-value' and the | 34 | ;; The macro `with-decoded-time-value' and the function |
| 35 | ;; function `encode-time-value' make it easier to deal with these | 35 | ;; `encode-time-value' make it easier to deal with these formats. |
| 36 | ;; three formats. See `time-subtract' for an example of how to use | 36 | ;; See `time-subtract' for an example of how to use them. |
| 37 | ;; them. | ||
| 38 | 37 | ||
| 39 | ;;; Code: | 38 | ;;; Code: |
| 40 | 39 | ||
| @@ -134,9 +133,7 @@ If DATE lacks timezone information, GMT is assumed." | |||
| 134 | ;;;###autoload(if (or (featurep 'emacs) | 133 | ;;;###autoload(if (or (featurep 'emacs) |
| 135 | ;;;###autoload (and (fboundp 'float-time) | 134 | ;;;###autoload (and (fboundp 'float-time) |
| 136 | ;;;###autoload (subrp (symbol-function 'float-time)))) | 135 | ;;;###autoload (subrp (symbol-function 'float-time)))) |
| 137 | ;;;###autoload (progn | 136 | ;;;###autoload (defalias 'time-to-seconds 'float-time) |
| 138 | ;;;###autoload (defalias 'time-to-seconds 'float-time) | ||
| 139 | ;;;###autoload (make-obsolete 'time-to-seconds 'float-time "21.1")) | ||
| 140 | ;;;###autoload (autoload 'time-to-seconds "time-date")) | 137 | ;;;###autoload (autoload 'time-to-seconds "time-date")) |
| 141 | 138 | ||
| 142 | (eval-when-compile | 139 | (eval-when-compile |
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index a01ce4c30a3..cdfb357b646 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog | |||
| @@ -1,12 +1,17 @@ | |||
| 1 | 2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * semantic/fw.el (semantic-make-local-hook, semantic-mode-line-update): | ||
| 4 | Simplify via CSE. | ||
| 5 | |||
| 1 | 2012-11-16 David Engster <deng@randomsample.de> | 6 | 2012-11-16 David Engster <deng@randomsample.de> |
| 2 | 7 | ||
| 3 | * semantic/symref/list.el (semantic-symref-symbol): Use | 8 | * semantic/symref/list.el (semantic-symref-symbol): |
| 4 | `semantic-complete-read-tag-project' instead of | 9 | Use `semantic-complete-read-tag-project' instead of |
| 5 | `semantic-complete-read-tag-buffer-deep', since the latter is not | 10 | `semantic-complete-read-tag-buffer-deep', since the latter is not |
| 6 | working correctly. | 11 | working correctly. |
| 7 | 12 | ||
| 8 | * semantic/symref.el (semantic-symref-result-get-tags): Use | 13 | * semantic/symref.el (semantic-symref-result-get-tags): |
| 9 | `find-buffer-visiting' to follow symbolic links. | 14 | Use `find-buffer-visiting' to follow symbolic links. |
| 10 | 15 | ||
| 11 | * semantic/fw.el (semantic-find-file-noselect): Always set | 16 | * semantic/fw.el (semantic-find-file-noselect): Always set |
| 12 | `enable-local-variables' to `:safe' when loading files. | 17 | `enable-local-variables' to `:safe' when loading files. |
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 14ffc808c44..6dd85309967 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el | |||
| @@ -122,15 +122,13 @@ | |||
| 122 | ) | 122 | ) |
| 123 | 123 | ||
| 124 | 124 | ||
| 125 | (if (and (not (featurep 'xemacs)) | 125 | (defalias 'semantic-make-local-hook |
| 126 | (>= emacs-major-version 21)) | 126 | (if (and (not (featurep 'xemacs)) |
| 127 | (defalias 'semantic-make-local-hook 'identity) | 127 | (>= emacs-major-version 21)) |
| 128 | (defalias 'semantic-make-local-hook 'make-local-hook) | 128 | #'identity #'make-local-hook)) |
| 129 | ) | ||
| 130 | 129 | ||
| 131 | (if (featurep 'xemacs) | 130 | (defalias 'semantic-mode-line-update |
| 132 | (defalias 'semantic-mode-line-update 'redraw-modeline) | 131 | (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) |
| 133 | (defalias 'semantic-mode-line-update 'force-mode-line-update)) | ||
| 134 | 132 | ||
| 135 | ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to | 133 | ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to |
| 136 | ;; run major mode hooks. | 134 | ;; run major mode hooks. |
diff --git a/lisp/color.el b/lisp/color.el index b915beacb0a..e1563ea474c 100644 --- a/lisp/color.el +++ b/lisp/color.el | |||
| @@ -33,9 +33,6 @@ | |||
| 33 | 33 | ||
| 34 | ;;; Code: | 34 | ;;; Code: |
| 35 | 35 | ||
| 36 | (eval-when-compile | ||
| 37 | (require 'cl)) | ||
| 38 | |||
| 39 | ;; Emacs < 23.3 | 36 | ;; Emacs < 23.3 |
| 40 | (eval-and-compile | 37 | (eval-and-compile |
| 41 | (unless (boundp 'float-pi) | 38 | (unless (boundp 'float-pi) |
| @@ -69,9 +66,9 @@ RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive." | |||
| 69 | COLOR-NAME should be a string naming a color (e.g. \"white\"), or | 66 | COLOR-NAME should be a string naming a color (e.g. \"white\"), or |
| 70 | a string specifying a color's RGB components (e.g. \"#ff12ec\")." | 67 | a string specifying a color's RGB components (e.g. \"#ff12ec\")." |
| 71 | (let ((color (color-name-to-rgb color-name))) | 68 | (let ((color (color-name-to-rgb color-name))) |
| 72 | (list (- 1.0 (car color)) | 69 | (list (- 1.0 (nth 0 color)) |
| 73 | (- 1.0 (cadr color)) | 70 | (- 1.0 (nth 1 color)) |
| 74 | (- 1.0 (caddr color))))) | 71 | (- 1.0 (nth 2 color))))) |
| 75 | 72 | ||
| 76 | (defun color-gradient (start stop step-number) | 73 | (defun color-gradient (start stop step-number) |
| 77 | "Return a list with STEP-NUMBER colors from START to STOP. | 74 | "Return a list with STEP-NUMBER colors from START to STOP. |
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 462b4a25154..b4582a41d6c 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el | |||
| @@ -81,8 +81,14 @@ The return value of this function is not used." | |||
| 81 | #'(lambda (f _args new-name when) | 81 | #'(lambda (f _args new-name when) |
| 82 | `(make-obsolete ',f ',new-name ,when))) | 82 | `(make-obsolete ',f ',new-name ,when))) |
| 83 | (list 'compiler-macro | 83 | (list 'compiler-macro |
| 84 | #'(lambda (f _args compiler-function) | 84 | #'(lambda (f args compiler-function) |
| 85 | `(put ',f 'compiler-macro #',compiler-function))) | 85 | ;; FIXME: Make it possible to just reuse `args'. |
| 86 | `(eval-and-compile | ||
| 87 | (put ',f 'compiler-macro | ||
| 88 | ,(if (eq (car-safe compiler-function) 'lambda) | ||
| 89 | `(lambda ,(append (cadr compiler-function) args) | ||
| 90 | ,@(cddr compiler-function)) | ||
| 91 | `#',compiler-function))))) | ||
| 86 | (list 'doc-string | 92 | (list 'doc-string |
| 87 | #'(lambda (f _args pos) | 93 | #'(lambda (f _args pos) |
| 88 | (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) | 94 | (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) |
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a325e0f3e44..60036c86dc0 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el | |||
| @@ -2509,8 +2509,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2509 | (when (symbolp form) | 2509 | (when (symbolp form) |
| 2510 | (unless (memq (car-safe fun) '(closure lambda)) | 2510 | (unless (memq (car-safe fun) '(closure lambda)) |
| 2511 | (error "Don't know how to compile %S" fun)) | 2511 | (error "Don't know how to compile %S" fun)) |
| 2512 | (setq fun (byte-compile--reify-function fun)) | 2512 | (setq lexical-binding (eq (car fun) 'closure)) |
| 2513 | (setq lexical-binding (eq (car fun) 'closure))) | 2513 | (setq fun (byte-compile--reify-function fun))) |
| 2514 | (unless (eq (car-safe fun) 'lambda) | 2514 | (unless (eq (car-safe fun) 'lambda) |
| 2515 | (error "Don't know how to compile %S" fun)) | 2515 | (error "Don't know how to compile %S" fun)) |
| 2516 | ;; Expand macros. | 2516 | ;; Expand macros. |
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 483ed64de20..12311711fe0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el | |||
| @@ -4268,6 +4268,21 @@ With prefix argument, make it a temporary breakpoint." | |||
| 4268 | 4268 | ||
| 4269 | ;;; Finalize Loading | 4269 | ;;; Finalize Loading |
| 4270 | 4270 | ||
| 4271 | ;; When edebugging a function, some of the sub-expressions are | ||
| 4272 | ;; wrapped in (edebug-enter (lambda () ..)), so we need to teach | ||
| 4273 | ;; called-interactively-p that calls within the inner lambda should refer to | ||
| 4274 | ;; the outside function. | ||
| 4275 | (add-hook 'called-interactively-p-functions | ||
| 4276 | #'edebug--called-interactively-skip) | ||
| 4277 | (defun edebug--called-interactively-skip (i frame1 frame2) | ||
| 4278 | (when (and (eq (car-safe (nth 1 frame1)) 'lambda) | ||
| 4279 | (eq (nth 1 (nth 1 frame1)) '()) | ||
| 4280 | (eq (nth 1 frame2) 'edebug-enter)) | ||
| 4281 | ;; `edebug-enter' calls itself on its first invocation. | ||
| 4282 | (if (eq (nth 1 (internal--called-interactively-p--get-frame i)) | ||
| 4283 | 'edebug-enter) | ||
| 4284 | 2 1))) | ||
| 4285 | |||
| 4271 | ;; Finally, hook edebug into the rest of Emacs. | 4286 | ;; Finally, hook edebug into the rest of Emacs. |
| 4272 | ;; There are probably some other things that could go here. | 4287 | ;; There are probably some other things that could go here. |
| 4273 | 4288 | ||
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index c3b8e5e10d4..60d74774e87 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; ert-x.el --- Staging area for experimental extensions to ERT | 1 | ;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -28,8 +28,7 @@ | |||
| 28 | 28 | ||
| 29 | ;;; Code: | 29 | ;;; Code: |
| 30 | 30 | ||
| 31 | (eval-when-compile | 31 | (eval-when-compile (require 'cl-lib)) |
| 32 | (require 'cl)) | ||
| 33 | (require 'ert) | 32 | (require 'ert) |
| 34 | 33 | ||
| 35 | 34 | ||
| @@ -90,8 +89,8 @@ ERT--THUNK with that buffer as current." | |||
| 90 | (kill-buffer ert--buffer) | 89 | (kill-buffer ert--buffer) |
| 91 | (remhash ert--buffer ert--test-buffers)))) | 90 | (remhash ert--buffer ert--test-buffers)))) |
| 92 | 91 | ||
| 93 | (defmacro* ert-with-test-buffer ((&key ((:name name-form))) | 92 | (cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) |
| 94 | &body body) | 93 | &body body) |
| 95 | "Create a test buffer and run BODY in that buffer. | 94 | "Create a test buffer and run BODY in that buffer. |
| 96 | 95 | ||
| 97 | To be used in ERT tests. If BODY finishes successfully, the test | 96 | To be used in ERT tests. If BODY finishes successfully, the test |
| @@ -116,10 +115,10 @@ the name of the test and the result of NAME-FORM." | |||
| 116 | "Kill all test buffers that are still live." | 115 | "Kill all test buffers that are still live." |
| 117 | (interactive) | 116 | (interactive) |
| 118 | (let ((count 0)) | 117 | (let ((count 0)) |
| 119 | (maphash (lambda (buffer dummy) | 118 | (maphash (lambda (buffer _dummy) |
| 120 | (when (or (not (buffer-live-p buffer)) | 119 | (when (or (not (buffer-live-p buffer)) |
| 121 | (kill-buffer buffer)) | 120 | (kill-buffer buffer)) |
| 122 | (incf count))) | 121 | (cl-incf count))) |
| 123 | ert--test-buffers) | 122 | ert--test-buffers) |
| 124 | (message "%s out of %s test buffers killed" | 123 | (message "%s out of %s test buffers killed" |
| 125 | count (hash-table-count ert--test-buffers))) | 124 | count (hash-table-count ert--test-buffers))) |
| @@ -149,9 +148,9 @@ the rest are arguments to the command. | |||
| 149 | 148 | ||
| 150 | NOTE: Since the command is not called by `call-interactively' | 149 | NOTE: Since the command is not called by `call-interactively' |
| 151 | test for `called-interactively' in the command will fail." | 150 | test for `called-interactively' in the command will fail." |
| 152 | (assert (listp command) t) | 151 | (cl-assert (listp command) t) |
| 153 | (assert (commandp (car command)) t) | 152 | (cl-assert (commandp (car command)) t) |
| 154 | (assert (not unread-command-events) t) | 153 | (cl-assert (not unread-command-events) t) |
| 155 | (let (return-value) | 154 | (let (return-value) |
| 156 | ;; For the order of things here see command_loop_1 in keyboard.c. | 155 | ;; For the order of things here see command_loop_1 in keyboard.c. |
| 157 | ;; | 156 | ;; |
| @@ -175,7 +174,7 @@ test for `called-interactively' in the command will fail." | |||
| 175 | (when (boundp 'last-repeatable-command) | 174 | (when (boundp 'last-repeatable-command) |
| 176 | (setq last-repeatable-command real-last-command)) | 175 | (setq last-repeatable-command real-last-command)) |
| 177 | (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) | 176 | (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) |
| 178 | (assert (not unread-command-events) t) | 177 | (cl-assert (not unread-command-events) t) |
| 179 | return-value)) | 178 | return-value)) |
| 180 | 179 | ||
| 181 | (defun ert-run-idle-timers () | 180 | (defun ert-run-idle-timers () |
| @@ -198,7 +197,7 @@ rather than the entire match." | |||
| 198 | (with-temp-buffer | 197 | (with-temp-buffer |
| 199 | (insert s) | 198 | (insert s) |
| 200 | (dolist (x regexps) | 199 | (dolist (x regexps) |
| 201 | (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) | 200 | (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) |
| 202 | (goto-char (point-min)) | 201 | (goto-char (point-min)) |
| 203 | (while (re-search-forward regexp nil t) | 202 | (while (re-search-forward regexp nil t) |
| 204 | (replace-match "" t t nil subexp)))) | 203 | (replace-match "" t t nil subexp)))) |
| @@ -224,15 +223,15 @@ would return the string \"foo bar baz quux\" where the substring | |||
| 224 | None of the ARGS are modified, but the return value may share | 223 | None of the ARGS are modified, but the return value may share |
| 225 | structure with the plists in ARGS." | 224 | structure with the plists in ARGS." |
| 226 | (with-temp-buffer | 225 | (with-temp-buffer |
| 227 | (loop with current-plist = nil | 226 | (cl-loop with current-plist = nil |
| 228 | for x in args do | 227 | for x in args do |
| 229 | (etypecase x | 228 | (cl-etypecase x |
| 230 | (string (let ((begin (point))) | 229 | (string (let ((begin (point))) |
| 231 | (insert x) | 230 | (insert x) |
| 232 | (set-text-properties begin (point) current-plist))) | 231 | (set-text-properties begin (point) current-plist))) |
| 233 | (list (unless (zerop (mod (length x) 2)) | 232 | (list (unless (zerop (mod (length x) 2)) |
| 234 | (error "Odd number of args in plist: %S" x)) | 233 | (error "Odd number of args in plist: %S" x)) |
| 235 | (setq current-plist x)))) | 234 | (setq current-plist x)))) |
| 236 | (buffer-string))) | 235 | (buffer-string))) |
| 237 | 236 | ||
| 238 | 237 | ||
| @@ -245,8 +244,8 @@ buffer, and renames the original buffer back to BUFFER-NAME. | |||
| 245 | 244 | ||
| 246 | This is useful if THUNK has undesirable side-effects on an Emacs | 245 | This is useful if THUNK has undesirable side-effects on an Emacs |
| 247 | buffer with a fixed name such as *Messages*." | 246 | buffer with a fixed name such as *Messages*." |
| 248 | (lexical-let ((new-buffer-name (generate-new-buffer-name | 247 | (let ((new-buffer-name (generate-new-buffer-name |
| 249 | (format "%s orig buffer" buffer-name)))) | 248 | (format "%s orig buffer" buffer-name)))) |
| 250 | (with-current-buffer (get-buffer-create buffer-name) | 249 | (with-current-buffer (get-buffer-create buffer-name) |
| 251 | (rename-buffer new-buffer-name)) | 250 | (rename-buffer new-buffer-name)) |
| 252 | (unwind-protect | 251 | (unwind-protect |
| @@ -258,7 +257,7 @@ buffer with a fixed name such as *Messages*." | |||
| 258 | (with-current-buffer new-buffer-name | 257 | (with-current-buffer new-buffer-name |
| 259 | (rename-buffer buffer-name))))) | 258 | (rename-buffer buffer-name))))) |
| 260 | 259 | ||
| 261 | (defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) | 260 | (cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) |
| 262 | "Protect the buffer named BUFFER-NAME from side-effects and run BODY. | 261 | "Protect the buffer named BUFFER-NAME from side-effects and run BODY. |
| 263 | 262 | ||
| 264 | See `ert-call-with-buffer-renamed' for details." | 263 | See `ert-call-with-buffer-renamed' for details." |
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index ff00be7a237..ab6dcb58143 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; ert.el --- Emacs Lisp Regression Testing | 1 | ;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -54,8 +54,7 @@ | |||
| 54 | 54 | ||
| 55 | ;;; Code: | 55 | ;;; Code: |
| 56 | 56 | ||
| 57 | (eval-when-compile | 57 | (eval-when-compile (require 'cl-lib)) |
| 58 | (require 'cl)) | ||
| 59 | (require 'button) | 58 | (require 'button) |
| 60 | (require 'debug) | 59 | (require 'debug) |
| 61 | (require 'easymenu) | 60 | (require 'easymenu) |
| @@ -105,33 +104,33 @@ | |||
| 105 | "A reimplementation of `remove-if-not'. | 104 | "A reimplementation of `remove-if-not'. |
| 106 | 105 | ||
| 107 | ERT-PRED is a predicate, ERT-LIST is the input list." | 106 | ERT-PRED is a predicate, ERT-LIST is the input list." |
| 108 | (loop for ert-x in ert-list | 107 | (cl-loop for ert-x in ert-list |
| 109 | if (funcall ert-pred ert-x) | 108 | if (funcall ert-pred ert-x) |
| 110 | collect ert-x)) | 109 | collect ert-x)) |
| 111 | 110 | ||
| 112 | (defun ert--intersection (a b) | 111 | (defun ert--intersection (a b) |
| 113 | "A reimplementation of `intersection'. Intersect the sets A and B. | 112 | "A reimplementation of `intersection'. Intersect the sets A and B. |
| 114 | 113 | ||
| 115 | Elements are compared using `eql'." | 114 | Elements are compared using `eql'." |
| 116 | (loop for x in a | 115 | (cl-loop for x in a |
| 117 | if (memql x b) | 116 | if (memql x b) |
| 118 | collect x)) | 117 | collect x)) |
| 119 | 118 | ||
| 120 | (defun ert--set-difference (a b) | 119 | (defun ert--set-difference (a b) |
| 121 | "A reimplementation of `set-difference'. Subtract the set B from the set A. | 120 | "A reimplementation of `set-difference'. Subtract the set B from the set A. |
| 122 | 121 | ||
| 123 | Elements are compared using `eql'." | 122 | Elements are compared using `eql'." |
| 124 | (loop for x in a | 123 | (cl-loop for x in a |
| 125 | unless (memql x b) | 124 | unless (memql x b) |
| 126 | collect x)) | 125 | collect x)) |
| 127 | 126 | ||
| 128 | (defun ert--set-difference-eq (a b) | 127 | (defun ert--set-difference-eq (a b) |
| 129 | "A reimplementation of `set-difference'. Subtract the set B from the set A. | 128 | "A reimplementation of `set-difference'. Subtract the set B from the set A. |
| 130 | 129 | ||
| 131 | Elements are compared using `eq'." | 130 | Elements are compared using `eq'." |
| 132 | (loop for x in a | 131 | (cl-loop for x in a |
| 133 | unless (memq x b) | 132 | unless (memq x b) |
| 134 | collect x)) | 133 | collect x)) |
| 135 | 134 | ||
| 136 | (defun ert--union (a b) | 135 | (defun ert--union (a b) |
| 137 | "A reimplementation of `union'. Compute the union of the sets A and B. | 136 | "A reimplementation of `union'. Compute the union of the sets A and B. |
| @@ -149,7 +148,7 @@ Elements are compared using `eql'." | |||
| 149 | (make-symbol (format "%s%s" | 148 | (make-symbol (format "%s%s" |
| 150 | prefix | 149 | prefix |
| 151 | (prog1 ert--gensym-counter | 150 | (prog1 ert--gensym-counter |
| 152 | (incf ert--gensym-counter)))))) | 151 | (cl-incf ert--gensym-counter)))))) |
| 153 | 152 | ||
| 154 | (defun ert--coerce-to-vector (x) | 153 | (defun ert--coerce-to-vector (x) |
| 155 | "Coerce X to a vector." | 154 | "Coerce X to a vector." |
| @@ -158,19 +157,19 @@ Elements are compared using `eql'." | |||
| 158 | x | 157 | x |
| 159 | (vconcat x))) | 158 | (vconcat x))) |
| 160 | 159 | ||
| 161 | (defun* ert--remove* (x list &key key test) | 160 | (cl-defun ert--remove* (x list &key key test) |
| 162 | "Does not support all the keywords of remove*." | 161 | "Does not support all the keywords of remove*." |
| 163 | (unless key (setq key #'identity)) | 162 | (unless key (setq key #'identity)) |
| 164 | (unless test (setq test #'eql)) | 163 | (unless test (setq test #'eql)) |
| 165 | (loop for y in list | 164 | (cl-loop for y in list |
| 166 | unless (funcall test x (funcall key y)) | 165 | unless (funcall test x (funcall key y)) |
| 167 | collect y)) | 166 | collect y)) |
| 168 | 167 | ||
| 169 | (defun ert--string-position (c s) | 168 | (defun ert--string-position (c s) |
| 170 | "Return the position of the first occurrence of C in S, or nil if none." | 169 | "Return the position of the first occurrence of C in S, or nil if none." |
| 171 | (loop for i from 0 | 170 | (cl-loop for i from 0 |
| 172 | for x across s | 171 | for x across s |
| 173 | when (eql x c) return i)) | 172 | when (eql x c) return i)) |
| 174 | 173 | ||
| 175 | (defun ert--mismatch (a b) | 174 | (defun ert--mismatch (a b) |
| 176 | "Return index of first element that differs between A and B. | 175 | "Return index of first element that differs between A and B. |
| @@ -184,29 +183,30 @@ Like `mismatch'. Uses `equal' for comparison." | |||
| 184 | (t | 183 | (t |
| 185 | (let ((la (length a)) | 184 | (let ((la (length a)) |
| 186 | (lb (length b))) | 185 | (lb (length b))) |
| 187 | (assert (arrayp a) t) | 186 | (cl-assert (arrayp a) t) |
| 188 | (assert (arrayp b) t) | 187 | (cl-assert (arrayp b) t) |
| 189 | (assert (<= la lb) t) | 188 | (cl-assert (<= la lb) t) |
| 190 | (loop for i below la | 189 | (cl-loop for i below la |
| 191 | when (not (equal (aref a i) (aref b i))) return i | 190 | when (not (equal (aref a i) (aref b i))) return i |
| 192 | finally (return (if (/= la lb) | 191 | finally (cl-return (if (/= la lb) |
| 193 | la | 192 | la |
| 194 | (assert (equal a b) t) | 193 | (cl-assert (equal a b) t) |
| 195 | nil))))))) | 194 | nil))))))) |
| 196 | 195 | ||
| 197 | (defun ert--subseq (seq start &optional end) | 196 | (defun ert--subseq (seq start &optional end) |
| 198 | "Return a subsequence of SEQ from START to END." | 197 | "Return a subsequence of SEQ from START to END." |
| 199 | (when (char-table-p seq) (error "Not supported")) | 198 | (when (char-table-p seq) (error "Not supported")) |
| 200 | (let ((vector (substring (ert--coerce-to-vector seq) start end))) | 199 | (let ((vector (substring (ert--coerce-to-vector seq) start end))) |
| 201 | (etypecase seq | 200 | (cl-etypecase seq |
| 202 | (vector vector) | 201 | (vector vector) |
| 203 | (string (concat vector)) | 202 | (string (concat vector)) |
| 204 | (list (append vector nil)) | 203 | (list (append vector nil)) |
| 205 | (bool-vector (loop with result = (make-bool-vector (length vector) nil) | 204 | (bool-vector (cl-loop with result |
| 206 | for i below (length vector) do | 205 | = (make-bool-vector (length vector) nil) |
| 207 | (setf (aref result i) (aref vector i)) | 206 | for i below (length vector) do |
| 208 | finally (return result))) | 207 | (setf (aref result i) (aref vector i)) |
| 209 | (char-table (assert nil))))) | 208 | finally (cl-return result))) |
| 209 | (char-table (cl-assert nil))))) | ||
| 210 | 210 | ||
| 211 | (defun ert-equal-including-properties (a b) | 211 | (defun ert-equal-including-properties (a b) |
| 212 | "Return t if A and B have similar structure and contents. | 212 | "Return t if A and B have similar structure and contents. |
| @@ -225,10 +225,10 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." | |||
| 225 | ;;; Defining and locating tests. | 225 | ;;; Defining and locating tests. |
| 226 | 226 | ||
| 227 | ;; The data structure that represents a test case. | 227 | ;; The data structure that represents a test case. |
| 228 | (defstruct ert-test | 228 | (cl-defstruct ert-test |
| 229 | (name nil) | 229 | (name nil) |
| 230 | (documentation nil) | 230 | (documentation nil) |
| 231 | (body (assert nil)) | 231 | (body (cl-assert nil)) |
| 232 | (most-recent-result nil) | 232 | (most-recent-result nil) |
| 233 | (expected-result-type ':passed) | 233 | (expected-result-type ':passed) |
| 234 | (tags '())) | 234 | (tags '())) |
| @@ -273,7 +273,7 @@ Returns a two-element list containing the keys-and-values plist | |||
| 273 | and the body." | 273 | and the body." |
| 274 | (let ((extracted-key-accu '()) | 274 | (let ((extracted-key-accu '()) |
| 275 | (remaining keys-and-body)) | 275 | (remaining keys-and-body)) |
| 276 | (while (and (consp remaining) (keywordp (first remaining))) | 276 | (while (keywordp (car-safe remaining)) |
| 277 | (let ((keyword (pop remaining))) | 277 | (let ((keyword (pop remaining))) |
| 278 | (unless (consp remaining) | 278 | (unless (consp remaining) |
| 279 | (error "Value expected after keyword %S in %S" | 279 | (error "Value expected after keyword %S in %S" |
| @@ -283,13 +283,13 @@ and the body." | |||
| 283 | keys-and-body)) | 283 | keys-and-body)) |
| 284 | (push (cons keyword (pop remaining)) extracted-key-accu))) | 284 | (push (cons keyword (pop remaining)) extracted-key-accu))) |
| 285 | (setq extracted-key-accu (nreverse extracted-key-accu)) | 285 | (setq extracted-key-accu (nreverse extracted-key-accu)) |
| 286 | (list (loop for (key . value) in extracted-key-accu | 286 | (list (cl-loop for (key . value) in extracted-key-accu |
| 287 | collect key | 287 | collect key |
| 288 | collect value) | 288 | collect value) |
| 289 | remaining))) | 289 | remaining))) |
| 290 | 290 | ||
| 291 | ;;;###autoload | 291 | ;;;###autoload |
| 292 | (defmacro* ert-deftest (name () &body docstring-keys-and-body) | 292 | (cl-defmacro ert-deftest (name () &body docstring-keys-and-body) |
| 293 | "Define NAME (a symbol) as a test. | 293 | "Define NAME (a symbol) as a test. |
| 294 | 294 | ||
| 295 | BODY is evaluated as a `progn' when the test is run. It should | 295 | BODY is evaluated as a `progn' when the test is run. It should |
| @@ -313,12 +313,13 @@ description of valid values for RESULT-TYPE. | |||
| 313 | (indent 2)) | 313 | (indent 2)) |
| 314 | (let ((documentation nil) | 314 | (let ((documentation nil) |
| 315 | (documentation-supplied-p nil)) | 315 | (documentation-supplied-p nil)) |
| 316 | (when (stringp (first docstring-keys-and-body)) | 316 | (when (stringp (car docstring-keys-and-body)) |
| 317 | (setq documentation (pop docstring-keys-and-body) | 317 | (setq documentation (pop docstring-keys-and-body) |
| 318 | documentation-supplied-p t)) | 318 | documentation-supplied-p t)) |
| 319 | (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) | 319 | (cl-destructuring-bind |
| 320 | (tags nil tags-supplied-p)) | 320 | ((&key (expected-result nil expected-result-supplied-p) |
| 321 | body) | 321 | (tags nil tags-supplied-p)) |
| 322 | body) | ||
| 322 | (ert--parse-keys-and-body docstring-keys-and-body) | 323 | (ert--parse-keys-and-body docstring-keys-and-body) |
| 323 | `(progn | 324 | `(progn |
| 324 | (ert-set-test ',name | 325 | (ert-set-test ',name |
| @@ -388,16 +389,11 @@ DATA is displayed to the user and should state the reason of the failure." | |||
| 388 | (defun ert--expand-should-1 (whole form inner-expander) | 389 | (defun ert--expand-should-1 (whole form inner-expander) |
| 389 | "Helper function for the `should' macro and its variants." | 390 | "Helper function for the `should' macro and its variants." |
| 390 | (let ((form | 391 | (let ((form |
| 391 | ;; If `cl-macroexpand' isn't bound, the code that we're | 392 | (macroexpand form (cond |
| 392 | ;; compiling doesn't depend on cl and thus doesn't need an | 393 | ((boundp 'macroexpand-all-environment) |
| 393 | ;; environment arg for `macroexpand'. | 394 | macroexpand-all-environment) |
| 394 | (if (fboundp 'cl-macroexpand) | 395 | ((boundp 'cl-macro-environment) |
| 395 | ;; Suppress warning about run-time call to cl function: we | 396 | cl-macro-environment))))) |
| 396 | ;; only call it if it's fboundp. | ||
| 397 | (with-no-warnings | ||
| 398 | (cl-macroexpand form (and (boundp 'cl-macro-environment) | ||
| 399 | cl-macro-environment))) | ||
| 400 | (macroexpand form)))) | ||
| 401 | (cond | 397 | (cond |
| 402 | ((or (atom form) (ert--special-operator-p (car form))) | 398 | ((or (atom form) (ert--special-operator-p (car form))) |
| 403 | (let ((value (ert--gensym "value-"))) | 399 | (let ((value (ert--gensym "value-"))) |
| @@ -410,10 +406,10 @@ DATA is displayed to the user and should state the reason of the failure." | |||
| 410 | (t | 406 | (t |
| 411 | (let ((fn-name (car form)) | 407 | (let ((fn-name (car form)) |
| 412 | (arg-forms (cdr form))) | 408 | (arg-forms (cdr form))) |
| 413 | (assert (or (symbolp fn-name) | 409 | (cl-assert (or (symbolp fn-name) |
| 414 | (and (consp fn-name) | 410 | (and (consp fn-name) |
| 415 | (eql (car fn-name) 'lambda) | 411 | (eql (car fn-name) 'lambda) |
| 416 | (listp (cdr fn-name))))) | 412 | (listp (cdr fn-name))))) |
| 417 | (let ((fn (ert--gensym "fn-")) | 413 | (let ((fn (ert--gensym "fn-")) |
| 418 | (args (ert--gensym "args-")) | 414 | (args (ert--gensym "args-")) |
| 419 | (value (ert--gensym "value-")) | 415 | (value (ert--gensym "value-")) |
| @@ -451,35 +447,34 @@ should return code that calls INNER-FORM and performs the checks | |||
| 451 | and error signaling specific to the particular variant of | 447 | and error signaling specific to the particular variant of |
| 452 | `should'. The code that INNER-EXPANDER returns must not call | 448 | `should'. The code that INNER-EXPANDER returns must not call |
| 453 | FORM-DESCRIPTION-FORM before it has called INNER-FORM." | 449 | FORM-DESCRIPTION-FORM before it has called INNER-FORM." |
| 454 | (lexical-let ((inner-expander inner-expander)) | 450 | (ert--expand-should-1 |
| 455 | (ert--expand-should-1 | 451 | whole form |
| 456 | whole form | 452 | (lambda (inner-form form-description-form value-var) |
| 457 | (lambda (inner-form form-description-form value-var) | 453 | (let ((form-description (ert--gensym "form-description-"))) |
| 458 | (let ((form-description (ert--gensym "form-description-"))) | 454 | `(let (,form-description) |
| 459 | `(let (,form-description) | 455 | ,(funcall inner-expander |
| 460 | ,(funcall inner-expander | 456 | `(unwind-protect |
| 461 | `(unwind-protect | 457 | ,inner-form |
| 462 | ,inner-form | 458 | (setq ,form-description ,form-description-form) |
| 463 | (setq ,form-description ,form-description-form) | 459 | (ert--signal-should-execution ,form-description)) |
| 464 | (ert--signal-should-execution ,form-description)) | 460 | `,form-description |
| 465 | `,form-description | 461 | value-var)))))) |
| 466 | value-var))))))) | 462 | |
| 467 | 463 | (cl-defmacro should (form) | |
| 468 | (defmacro* should (form) | ||
| 469 | "Evaluate FORM. If it returns nil, abort the current test as failed. | 464 | "Evaluate FORM. If it returns nil, abort the current test as failed. |
| 470 | 465 | ||
| 471 | Returns the value of FORM." | 466 | Returns the value of FORM." |
| 472 | (ert--expand-should `(should ,form) form | 467 | (ert--expand-should `(should ,form) form |
| 473 | (lambda (inner-form form-description-form value-var) | 468 | (lambda (inner-form form-description-form _value-var) |
| 474 | `(unless ,inner-form | 469 | `(unless ,inner-form |
| 475 | (ert-fail ,form-description-form))))) | 470 | (ert-fail ,form-description-form))))) |
| 476 | 471 | ||
| 477 | (defmacro* should-not (form) | 472 | (cl-defmacro should-not (form) |
| 478 | "Evaluate FORM. If it returns non-nil, abort the current test as failed. | 473 | "Evaluate FORM. If it returns non-nil, abort the current test as failed. |
| 479 | 474 | ||
| 480 | Returns nil." | 475 | Returns nil." |
| 481 | (ert--expand-should `(should-not ,form) form | 476 | (ert--expand-should `(should-not ,form) form |
| 482 | (lambda (inner-form form-description-form value-var) | 477 | (lambda (inner-form form-description-form _value-var) |
| 483 | `(unless (not ,inner-form) | 478 | `(unless (not ,inner-form) |
| 484 | (ert-fail ,form-description-form))))) | 479 | (ert-fail ,form-description-form))))) |
| 485 | 480 | ||
| @@ -490,10 +485,10 @@ Returns nil." | |||
| 490 | Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, | 485 | Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, |
| 491 | and aborts the current test as failed if it doesn't." | 486 | and aborts the current test as failed if it doesn't." |
| 492 | (let ((signaled-conditions (get (car condition) 'error-conditions)) | 487 | (let ((signaled-conditions (get (car condition) 'error-conditions)) |
| 493 | (handled-conditions (etypecase type | 488 | (handled-conditions (cl-etypecase type |
| 494 | (list type) | 489 | (list type) |
| 495 | (symbol (list type))))) | 490 | (symbol (list type))))) |
| 496 | (assert signaled-conditions) | 491 | (cl-assert signaled-conditions) |
| 497 | (unless (ert--intersection signaled-conditions handled-conditions) | 492 | (unless (ert--intersection signaled-conditions handled-conditions) |
| 498 | (ert-fail (append | 493 | (ert-fail (append |
| 499 | (funcall form-description-fn) | 494 | (funcall form-description-fn) |
| @@ -512,7 +507,7 @@ and aborts the current test as failed if it doesn't." | |||
| 512 | 507 | ||
| 513 | ;; FIXME: The expansion will evaluate the keyword args (if any) in | 508 | ;; FIXME: The expansion will evaluate the keyword args (if any) in |
| 514 | ;; nonstandard order. | 509 | ;; nonstandard order. |
| 515 | (defmacro* should-error (form &rest keys &key type exclude-subtypes) | 510 | (cl-defmacro should-error (form &rest keys &key type exclude-subtypes) |
| 516 | "Evaluate FORM and check that it signals an error. | 511 | "Evaluate FORM and check that it signals an error. |
| 517 | 512 | ||
| 518 | The error signaled needs to match TYPE. TYPE should be a list | 513 | The error signaled needs to match TYPE. TYPE should be a list |
| @@ -560,19 +555,19 @@ failed." | |||
| 560 | 555 | ||
| 561 | (defun ert--proper-list-p (x) | 556 | (defun ert--proper-list-p (x) |
| 562 | "Return non-nil if X is a proper list, nil otherwise." | 557 | "Return non-nil if X is a proper list, nil otherwise." |
| 563 | (loop | 558 | (cl-loop |
| 564 | for firstp = t then nil | 559 | for firstp = t then nil |
| 565 | for fast = x then (cddr fast) | 560 | for fast = x then (cddr fast) |
| 566 | for slow = x then (cdr slow) do | 561 | for slow = x then (cdr slow) do |
| 567 | (when (null fast) (return t)) | 562 | (when (null fast) (cl-return t)) |
| 568 | (when (not (consp fast)) (return nil)) | 563 | (when (not (consp fast)) (cl-return nil)) |
| 569 | (when (null (cdr fast)) (return t)) | 564 | (when (null (cdr fast)) (cl-return t)) |
| 570 | (when (not (consp (cdr fast))) (return nil)) | 565 | (when (not (consp (cdr fast))) (cl-return nil)) |
| 571 | (when (and (not firstp) (eq fast slow)) (return nil)))) | 566 | (when (and (not firstp) (eq fast slow)) (cl-return nil)))) |
| 572 | 567 | ||
| 573 | (defun ert--explain-format-atom (x) | 568 | (defun ert--explain-format-atom (x) |
| 574 | "Format the atom X for `ert--explain-equal'." | 569 | "Format the atom X for `ert--explain-equal'." |
| 575 | (typecase x | 570 | (cl-typecase x |
| 576 | (fixnum (list x (format "#x%x" x) (format "?%c" x))) | 571 | (fixnum (list x (format "#x%x" x) (format "?%c" x))) |
| 577 | (t x))) | 572 | (t x))) |
| 578 | 573 | ||
| @@ -581,7 +576,7 @@ failed." | |||
| 581 | Returns nil if they are." | 576 | Returns nil if they are." |
| 582 | (if (not (equal (type-of a) (type-of b))) | 577 | (if (not (equal (type-of a) (type-of b))) |
| 583 | `(different-types ,a ,b) | 578 | `(different-types ,a ,b) |
| 584 | (etypecase a | 579 | (cl-etypecase a |
| 585 | (cons | 580 | (cons |
| 586 | (let ((a-proper-p (ert--proper-list-p a)) | 581 | (let ((a-proper-p (ert--proper-list-p a)) |
| 587 | (b-proper-p (ert--proper-list-p b))) | 582 | (b-proper-p (ert--proper-list-p b))) |
| @@ -593,19 +588,19 @@ Returns nil if they are." | |||
| 593 | ,a ,b | 588 | ,a ,b |
| 594 | first-mismatch-at | 589 | first-mismatch-at |
| 595 | ,(ert--mismatch a b)) | 590 | ,(ert--mismatch a b)) |
| 596 | (loop for i from 0 | 591 | (cl-loop for i from 0 |
| 597 | for ai in a | 592 | for ai in a |
| 598 | for bi in b | 593 | for bi in b |
| 599 | for xi = (ert--explain-equal-rec ai bi) | 594 | for xi = (ert--explain-equal-rec ai bi) |
| 600 | do (when xi (return `(list-elt ,i ,xi))) | 595 | do (when xi (cl-return `(list-elt ,i ,xi))) |
| 601 | finally (assert (equal a b) t))) | 596 | finally (cl-assert (equal a b) t))) |
| 602 | (let ((car-x (ert--explain-equal-rec (car a) (car b)))) | 597 | (let ((car-x (ert--explain-equal-rec (car a) (car b)))) |
| 603 | (if car-x | 598 | (if car-x |
| 604 | `(car ,car-x) | 599 | `(car ,car-x) |
| 605 | (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) | 600 | (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) |
| 606 | (if cdr-x | 601 | (if cdr-x |
| 607 | `(cdr ,cdr-x) | 602 | `(cdr ,cdr-x) |
| 608 | (assert (equal a b) t) | 603 | (cl-assert (equal a b) t) |
| 609 | nil)))))))) | 604 | nil)))))))) |
| 610 | (array (if (not (equal (length a) (length b))) | 605 | (array (if (not (equal (length a) (length b))) |
| 611 | `(arrays-of-different-length ,(length a) ,(length b) | 606 | `(arrays-of-different-length ,(length a) ,(length b) |
| @@ -613,12 +608,12 @@ Returns nil if they are." | |||
| 613 | ,@(unless (char-table-p a) | 608 | ,@(unless (char-table-p a) |
| 614 | `(first-mismatch-at | 609 | `(first-mismatch-at |
| 615 | ,(ert--mismatch a b)))) | 610 | ,(ert--mismatch a b)))) |
| 616 | (loop for i from 0 | 611 | (cl-loop for i from 0 |
| 617 | for ai across a | 612 | for ai across a |
| 618 | for bi across b | 613 | for bi across b |
| 619 | for xi = (ert--explain-equal-rec ai bi) | 614 | for xi = (ert--explain-equal-rec ai bi) |
| 620 | do (when xi (return `(array-elt ,i ,xi))) | 615 | do (when xi (cl-return `(array-elt ,i ,xi))) |
| 621 | finally (assert (equal a b) t)))) | 616 | finally (cl-assert (equal a b) t)))) |
| 622 | (atom (if (not (equal a b)) | 617 | (atom (if (not (equal a b)) |
| 623 | (if (and (symbolp a) (symbolp b) (string= a b)) | 618 | (if (and (symbolp a) (symbolp b) (string= a b)) |
| 624 | `(different-symbols-with-the-same-name ,a ,b) | 619 | `(different-symbols-with-the-same-name ,a ,b) |
| @@ -637,10 +632,10 @@ Returns nil if they are." | |||
| 637 | 632 | ||
| 638 | (defun ert--significant-plist-keys (plist) | 633 | (defun ert--significant-plist-keys (plist) |
| 639 | "Return the keys of PLIST that have non-null values, in order." | 634 | "Return the keys of PLIST that have non-null values, in order." |
| 640 | (assert (zerop (mod (length plist) 2)) t) | 635 | (cl-assert (zerop (mod (length plist) 2)) t) |
| 641 | (loop for (key value . rest) on plist by #'cddr | 636 | (cl-loop for (key value . rest) on plist by #'cddr |
| 642 | unless (or (null value) (memq key accu)) collect key into accu | 637 | unless (or (null value) (memq key accu)) collect key into accu |
| 643 | finally (return accu))) | 638 | finally (cl-return accu))) |
| 644 | 639 | ||
| 645 | (defun ert--plist-difference-explanation (a b) | 640 | (defun ert--plist-difference-explanation (a b) |
| 646 | "Return a programmer-readable explanation of why A and B are different plists. | 641 | "Return a programmer-readable explanation of why A and B are different plists. |
| @@ -648,8 +643,8 @@ Returns nil if they are." | |||
| 648 | Returns nil if they are equivalent, i.e., have the same value for | 643 | Returns nil if they are equivalent, i.e., have the same value for |
| 649 | each key, where absent values are treated as nil. The order of | 644 | each key, where absent values are treated as nil. The order of |
| 650 | key/value pairs in each list does not matter." | 645 | key/value pairs in each list does not matter." |
| 651 | (assert (zerop (mod (length a) 2)) t) | 646 | (cl-assert (zerop (mod (length a) 2)) t) |
| 652 | (assert (zerop (mod (length b) 2)) t) | 647 | (cl-assert (zerop (mod (length b) 2)) t) |
| 653 | ;; Normalizing the plists would be another way to do this but it | 648 | ;; Normalizing the plists would be another way to do this but it |
| 654 | ;; requires a total ordering on all lisp objects (since any object | 649 | ;; requires a total ordering on all lisp objects (since any object |
| 655 | ;; is valid as a text property key). Perhaps defining such an | 650 | ;; is valid as a text property key). Perhaps defining such an |
| @@ -659,21 +654,21 @@ key/value pairs in each list does not matter." | |||
| 659 | (keys-b (ert--significant-plist-keys b)) | 654 | (keys-b (ert--significant-plist-keys b)) |
| 660 | (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) | 655 | (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) |
| 661 | (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) | 656 | (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) |
| 662 | (flet ((explain-with-key (key) | 657 | (cl-flet ((explain-with-key (key) |
| 663 | (let ((value-a (plist-get a key)) | 658 | (let ((value-a (plist-get a key)) |
| 664 | (value-b (plist-get b key))) | 659 | (value-b (plist-get b key))) |
| 665 | (assert (not (equal value-a value-b)) t) | 660 | (cl-assert (not (equal value-a value-b)) t) |
| 666 | `(different-properties-for-key | 661 | `(different-properties-for-key |
| 667 | ,key ,(ert--explain-equal-including-properties value-a | 662 | ,key ,(ert--explain-equal-including-properties value-a |
| 668 | value-b))))) | 663 | value-b))))) |
| 669 | (cond (keys-in-a-not-in-b | 664 | (cond (keys-in-a-not-in-b |
| 670 | (explain-with-key (first keys-in-a-not-in-b))) | 665 | (explain-with-key (car keys-in-a-not-in-b))) |
| 671 | (keys-in-b-not-in-a | 666 | (keys-in-b-not-in-a |
| 672 | (explain-with-key (first keys-in-b-not-in-a))) | 667 | (explain-with-key (car keys-in-b-not-in-a))) |
| 673 | (t | 668 | (t |
| 674 | (loop for key in keys-a | 669 | (cl-loop for key in keys-a |
| 675 | when (not (equal (plist-get a key) (plist-get b key))) | 670 | when (not (equal (plist-get a key) (plist-get b key))) |
| 676 | return (explain-with-key key))))))) | 671 | return (explain-with-key key))))))) |
| 677 | 672 | ||
| 678 | (defun ert--abbreviate-string (s len suffixp) | 673 | (defun ert--abbreviate-string (s len suffixp) |
| 679 | "Shorten string S to at most LEN chars. | 674 | "Shorten string S to at most LEN chars. |
| @@ -697,29 +692,30 @@ Returns a programmer-readable explanation of why A and B are not | |||
| 697 | `ert-equal-including-properties', or nil if they are." | 692 | `ert-equal-including-properties', or nil if they are." |
| 698 | (if (not (equal a b)) | 693 | (if (not (equal a b)) |
| 699 | (ert--explain-equal a b) | 694 | (ert--explain-equal a b) |
| 700 | (assert (stringp a) t) | 695 | (cl-assert (stringp a) t) |
| 701 | (assert (stringp b) t) | 696 | (cl-assert (stringp b) t) |
| 702 | (assert (eql (length a) (length b)) t) | 697 | (cl-assert (eql (length a) (length b)) t) |
| 703 | (loop for i from 0 to (length a) | 698 | (cl-loop for i from 0 to (length a) |
| 704 | for props-a = (text-properties-at i a) | 699 | for props-a = (text-properties-at i a) |
| 705 | for props-b = (text-properties-at i b) | 700 | for props-b = (text-properties-at i b) |
| 706 | for difference = (ert--plist-difference-explanation props-a props-b) | 701 | for difference = (ert--plist-difference-explanation |
| 707 | do (when difference | 702 | props-a props-b) |
| 708 | (return `(char ,i ,(substring-no-properties a i (1+ i)) | 703 | do (when difference |
| 709 | ,difference | 704 | (cl-return `(char ,i ,(substring-no-properties a i (1+ i)) |
| 710 | context-before | 705 | ,difference |
| 711 | ,(ert--abbreviate-string | 706 | context-before |
| 712 | (substring-no-properties a 0 i) | 707 | ,(ert--abbreviate-string |
| 713 | 10 t) | 708 | (substring-no-properties a 0 i) |
| 714 | context-after | 709 | 10 t) |
| 715 | ,(ert--abbreviate-string | 710 | context-after |
| 716 | (substring-no-properties a (1+ i)) | 711 | ,(ert--abbreviate-string |
| 717 | 10 nil)))) | 712 | (substring-no-properties a (1+ i)) |
| 718 | ;; TODO(ohler): Get `equal-including-properties' fixed in | 713 | 10 nil)))) |
| 719 | ;; Emacs, delete `ert-equal-including-properties', and | 714 | ;; TODO(ohler): Get `equal-including-properties' fixed in |
| 720 | ;; re-enable this assertion. | 715 | ;; Emacs, delete `ert-equal-including-properties', and |
| 721 | ;;finally (assert (equal-including-properties a b) t) | 716 | ;; re-enable this assertion. |
| 722 | ))) | 717 | ;;finally (cl-assert (equal-including-properties a b) t) |
| 718 | ))) | ||
| 723 | (put 'ert-equal-including-properties | 719 | (put 'ert-equal-including-properties |
| 724 | 'ert-explainer | 720 | 'ert-explainer |
| 725 | 'ert--explain-equal-including-properties) | 721 | 'ert--explain-equal-including-properties) |
| @@ -734,8 +730,8 @@ Returns a programmer-readable explanation of why A and B are not | |||
| 734 | 730 | ||
| 735 | Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") | 731 | Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") |
| 736 | 732 | ||
| 737 | (defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) | 733 | (cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) |
| 738 | &body body) | 734 | &body body) |
| 739 | "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. | 735 | "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. |
| 740 | 736 | ||
| 741 | To be used within ERT tests. MESSAGE-FORM should evaluate to a | 737 | To be used within ERT tests. MESSAGE-FORM should evaluate to a |
| @@ -755,18 +751,19 @@ and is displayed in front of the value of MESSAGE-FORM." | |||
| 755 | "Non-nil means enter debugger when a test fails or terminates with an error.") | 751 | "Non-nil means enter debugger when a test fails or terminates with an error.") |
| 756 | 752 | ||
| 757 | ;; The data structures that represent the result of running a test. | 753 | ;; The data structures that represent the result of running a test. |
| 758 | (defstruct ert-test-result | 754 | (cl-defstruct ert-test-result |
| 759 | (messages nil) | 755 | (messages nil) |
| 760 | (should-forms nil) | 756 | (should-forms nil) |
| 761 | ) | 757 | ) |
| 762 | (defstruct (ert-test-passed (:include ert-test-result))) | 758 | (cl-defstruct (ert-test-passed (:include ert-test-result))) |
| 763 | (defstruct (ert-test-result-with-condition (:include ert-test-result)) | 759 | (cl-defstruct (ert-test-result-with-condition (:include ert-test-result)) |
| 764 | (condition (assert nil)) | 760 | (condition (cl-assert nil)) |
| 765 | (backtrace (assert nil)) | 761 | (backtrace (cl-assert nil)) |
| 766 | (infos (assert nil))) | 762 | (infos (cl-assert nil))) |
| 767 | (defstruct (ert-test-quit (:include ert-test-result-with-condition))) | 763 | (cl-defstruct (ert-test-quit (:include ert-test-result-with-condition))) |
| 768 | (defstruct (ert-test-failed (:include ert-test-result-with-condition))) | 764 | (cl-defstruct (ert-test-failed (:include ert-test-result-with-condition))) |
| 769 | (defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) | 765 | (cl-defstruct (ert-test-aborted-with-non-local-exit |
| 766 | (:include ert-test-result))) | ||
| 770 | 767 | ||
| 771 | 768 | ||
| 772 | (defun ert--record-backtrace () | 769 | (defun ert--record-backtrace () |
| @@ -779,7 +776,7 @@ and is displayed in front of the value of MESSAGE-FORM." | |||
| 779 | ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we | 776 | ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we |
| 780 | ;; already have `ert-results-rerun-test-debugging-errors-at-point'. | 777 | ;; already have `ert-results-rerun-test-debugging-errors-at-point'. |
| 781 | ;; For batch use, however, printing the backtrace may be useful. | 778 | ;; For batch use, however, printing the backtrace may be useful. |
| 782 | (loop | 779 | (cl-loop |
| 783 | ;; 6 is the number of frames our own debugger adds (when | 780 | ;; 6 is the number of frames our own debugger adds (when |
| 784 | ;; compiled; more when interpreted). FIXME: Need to describe a | 781 | ;; compiled; more when interpreted). FIXME: Need to describe a |
| 785 | ;; procedure for determining this constant. | 782 | ;; procedure for determining this constant. |
| @@ -796,33 +793,33 @@ and is displayed in front of the value of MESSAGE-FORM." | |||
| 796 | (print-level 8) | 793 | (print-level 8) |
| 797 | (print-length 50)) | 794 | (print-length 50)) |
| 798 | (dolist (frame backtrace) | 795 | (dolist (frame backtrace) |
| 799 | (ecase (first frame) | 796 | (cl-ecase (car frame) |
| 800 | ((nil) | 797 | ((nil) |
| 801 | ;; Special operator. | 798 | ;; Special operator. |
| 802 | (destructuring-bind (special-operator &rest arg-forms) | 799 | (cl-destructuring-bind (special-operator &rest arg-forms) |
| 803 | (cdr frame) | 800 | (cdr frame) |
| 804 | (insert | 801 | (insert |
| 805 | (format " %S\n" (list* special-operator arg-forms))))) | 802 | (format " %S\n" (cons special-operator arg-forms))))) |
| 806 | ((t) | 803 | ((t) |
| 807 | ;; Function call. | 804 | ;; Function call. |
| 808 | (destructuring-bind (fn &rest args) (cdr frame) | 805 | (cl-destructuring-bind (fn &rest args) (cdr frame) |
| 809 | (insert (format " %S(" fn)) | 806 | (insert (format " %S(" fn)) |
| 810 | (loop for firstp = t then nil | 807 | (cl-loop for firstp = t then nil |
| 811 | for arg in args do | 808 | for arg in args do |
| 812 | (unless firstp | 809 | (unless firstp |
| 813 | (insert " ")) | 810 | (insert " ")) |
| 814 | (insert (format "%S" arg))) | 811 | (insert (format "%S" arg))) |
| 815 | (insert ")\n"))))))) | 812 | (insert ")\n"))))))) |
| 816 | 813 | ||
| 817 | ;; A container for the state of the execution of a single test and | 814 | ;; A container for the state of the execution of a single test and |
| 818 | ;; environment data needed during its execution. | 815 | ;; environment data needed during its execution. |
| 819 | (defstruct ert--test-execution-info | 816 | (cl-defstruct ert--test-execution-info |
| 820 | (test (assert nil)) | 817 | (test (cl-assert nil)) |
| 821 | (result (assert nil)) | 818 | (result (cl-assert nil)) |
| 822 | ;; A thunk that may be called when RESULT has been set to its final | 819 | ;; A thunk that may be called when RESULT has been set to its final |
| 823 | ;; value and test execution should be terminated. Should not | 820 | ;; value and test execution should be terminated. Should not |
| 824 | ;; return. | 821 | ;; return. |
| 825 | (exit-continuation (assert nil)) | 822 | (exit-continuation (cl-assert nil)) |
| 826 | ;; The binding of `debugger' outside of the execution of the test. | 823 | ;; The binding of `debugger' outside of the execution of the test. |
| 827 | next-debugger | 824 | next-debugger |
| 828 | ;; The binding of `ert-debug-on-error' that is in effect for the | 825 | ;; The binding of `ert-debug-on-error' that is in effect for the |
| @@ -831,7 +828,7 @@ and is displayed in front of the value of MESSAGE-FORM." | |||
| 831 | ;; don't remember whether this feature is important.) | 828 | ;; don't remember whether this feature is important.) |
| 832 | ert-debug-on-error) | 829 | ert-debug-on-error) |
| 833 | 830 | ||
| 834 | (defun ert--run-test-debugger (info debugger-args) | 831 | (defun ert--run-test-debugger (info args) |
| 835 | "During a test run, `debugger' is bound to a closure that calls this function. | 832 | "During a test run, `debugger' is bound to a closure that calls this function. |
| 836 | 833 | ||
| 837 | This function records failures and errors and either terminates | 834 | This function records failures and errors and either terminates |
| @@ -839,21 +836,21 @@ the test silently or calls the interactive debugger, as | |||
| 839 | appropriate. | 836 | appropriate. |
| 840 | 837 | ||
| 841 | INFO is the ert--test-execution-info corresponding to this test | 838 | INFO is the ert--test-execution-info corresponding to this test |
| 842 | run. DEBUGGER-ARGS are the arguments to `debugger'." | 839 | run. ARGS are the arguments to `debugger'." |
| 843 | (destructuring-bind (first-debugger-arg &rest more-debugger-args) | 840 | (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) |
| 844 | debugger-args | 841 | args |
| 845 | (ecase first-debugger-arg | 842 | (cl-ecase first-debugger-arg |
| 846 | ((lambda debug t exit nil) | 843 | ((lambda debug t exit nil) |
| 847 | (apply (ert--test-execution-info-next-debugger info) debugger-args)) | 844 | (apply (ert--test-execution-info-next-debugger info) args)) |
| 848 | (error | 845 | (error |
| 849 | (let* ((condition (first more-debugger-args)) | 846 | (let* ((condition (car more-debugger-args)) |
| 850 | (type (case (car condition) | 847 | (type (cl-case (car condition) |
| 851 | ((quit) 'quit) | 848 | ((quit) 'quit) |
| 852 | (otherwise 'failed))) | 849 | (otherwise 'failed))) |
| 853 | (backtrace (ert--record-backtrace)) | 850 | (backtrace (ert--record-backtrace)) |
| 854 | (infos (reverse ert--infos))) | 851 | (infos (reverse ert--infos))) |
| 855 | (setf (ert--test-execution-info-result info) | 852 | (setf (ert--test-execution-info-result info) |
| 856 | (ecase type | 853 | (cl-ecase type |
| 857 | (quit | 854 | (quit |
| 858 | (make-ert-test-quit :condition condition | 855 | (make-ert-test-quit :condition condition |
| 859 | :backtrace backtrace | 856 | :backtrace backtrace |
| @@ -864,39 +861,42 @@ run. DEBUGGER-ARGS are the arguments to `debugger'." | |||
| 864 | :infos infos)))) | 861 | :infos infos)))) |
| 865 | ;; Work around Emacs's heuristic (in eval.c) for detecting | 862 | ;; Work around Emacs's heuristic (in eval.c) for detecting |
| 866 | ;; errors in the debugger. | 863 | ;; errors in the debugger. |
| 867 | (incf num-nonmacro-input-events) | 864 | (cl-incf num-nonmacro-input-events) |
| 868 | ;; FIXME: We should probably implement more fine-grained | 865 | ;; FIXME: We should probably implement more fine-grained |
| 869 | ;; control a la non-t `debug-on-error' here. | 866 | ;; control a la non-t `debug-on-error' here. |
| 870 | (cond | 867 | (cond |
| 871 | ((ert--test-execution-info-ert-debug-on-error info) | 868 | ((ert--test-execution-info-ert-debug-on-error info) |
| 872 | (apply (ert--test-execution-info-next-debugger info) debugger-args)) | 869 | (apply (ert--test-execution-info-next-debugger info) args)) |
| 873 | (t)) | 870 | (t)) |
| 874 | (funcall (ert--test-execution-info-exit-continuation info))))))) | 871 | (funcall (ert--test-execution-info-exit-continuation info))))))) |
| 875 | 872 | ||
| 876 | (defun ert--run-test-internal (ert-test-execution-info) | 873 | (defun ert--run-test-internal (test-execution-info) |
| 877 | "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. | 874 | "Low-level function to run a test according to TEST-EXECUTION-INFO. |
| 878 | 875 | ||
| 879 | This mainly sets up debugger-related bindings." | 876 | This mainly sets up debugger-related bindings." |
| 880 | (lexical-let ((info ert-test-execution-info)) | 877 | (setf (ert--test-execution-info-next-debugger test-execution-info) debugger |
| 881 | (setf (ert--test-execution-info-next-debugger info) debugger | 878 | (ert--test-execution-info-ert-debug-on-error test-execution-info) |
| 882 | (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) | 879 | ert-debug-on-error) |
| 883 | (catch 'ert--pass | 880 | (catch 'ert--pass |
| 884 | ;; For now, each test gets its own temp buffer and its own | 881 | ;; For now, each test gets its own temp buffer and its own |
| 885 | ;; window excursion, just to be safe. If this turns out to be | 882 | ;; window excursion, just to be safe. If this turns out to be |
| 886 | ;; too expensive, we can remove it. | 883 | ;; too expensive, we can remove it. |
| 887 | (with-temp-buffer | 884 | (with-temp-buffer |
| 888 | (save-window-excursion | 885 | (save-window-excursion |
| 889 | (let ((debugger (lambda (&rest debugger-args) | 886 | (let ((debugger (lambda (&rest args) |
| 890 | (ert--run-test-debugger info debugger-args))) | 887 | (ert--run-test-debugger test-execution-info |
| 891 | (debug-on-error t) | 888 | args))) |
| 892 | (debug-on-quit t) | 889 | (debug-on-error t) |
| 893 | ;; FIXME: Do we need to store the old binding of this | 890 | (debug-on-quit t) |
| 894 | ;; and consider it in `ert--run-test-debugger'? | 891 | ;; FIXME: Do we need to store the old binding of this |
| 895 | (debug-ignored-errors nil) | 892 | ;; and consider it in `ert--run-test-debugger'? |
| 896 | (ert--infos '())) | 893 | (debug-ignored-errors nil) |
| 897 | (funcall (ert-test-body (ert--test-execution-info-test info)))))) | 894 | (ert--infos '())) |
| 898 | (ert-pass)) | 895 | (funcall (ert-test-body (ert--test-execution-info-test |
| 899 | (setf (ert--test-execution-info-result info) (make-ert-test-passed))) | 896 | test-execution-info)))))) |
| 897 | (ert-pass)) | ||
| 898 | (setf (ert--test-execution-info-result test-execution-info) | ||
| 899 | (make-ert-test-passed)) | ||
| 900 | nil) | 900 | nil) |
| 901 | 901 | ||
| 902 | (defun ert--force-message-log-buffer-truncation () | 902 | (defun ert--force-message-log-buffer-truncation () |
| @@ -934,18 +934,18 @@ The elements are of type `ert-test'.") | |||
| 934 | 934 | ||
| 935 | Returns the result and stores it in ERT-TEST's `most-recent-result' slot." | 935 | Returns the result and stores it in ERT-TEST's `most-recent-result' slot." |
| 936 | (setf (ert-test-most-recent-result ert-test) nil) | 936 | (setf (ert-test-most-recent-result ert-test) nil) |
| 937 | (block error | 937 | (cl-block error |
| 938 | (lexical-let ((begin-marker | 938 | (let ((begin-marker |
| 939 | (with-current-buffer (get-buffer-create "*Messages*") | 939 | (with-current-buffer (get-buffer-create "*Messages*") |
| 940 | (set-marker (make-marker) (point-max))))) | 940 | (set-marker (make-marker) (point-max))))) |
| 941 | (unwind-protect | 941 | (unwind-protect |
| 942 | (lexical-let ((info (make-ert--test-execution-info | 942 | (let ((info (make-ert--test-execution-info |
| 943 | :test ert-test | 943 | :test ert-test |
| 944 | :result | 944 | :result |
| 945 | (make-ert-test-aborted-with-non-local-exit) | 945 | (make-ert-test-aborted-with-non-local-exit) |
| 946 | :exit-continuation (lambda () | 946 | :exit-continuation (lambda () |
| 947 | (return-from error nil)))) | 947 | (cl-return-from error nil)))) |
| 948 | (should-form-accu (list))) | 948 | (should-form-accu (list))) |
| 949 | (unwind-protect | 949 | (unwind-protect |
| 950 | (let ((ert--should-execution-observer | 950 | (let ((ert--should-execution-observer |
| 951 | (lambda (form-description) | 951 | (lambda (form-description) |
| @@ -987,32 +987,32 @@ t -- Always matches. | |||
| 987 | RESULT." | 987 | RESULT." |
| 988 | ;; It would be easy to add `member' and `eql' types etc., but I | 988 | ;; It would be easy to add `member' and `eql' types etc., but I |
| 989 | ;; haven't bothered yet. | 989 | ;; haven't bothered yet. |
| 990 | (etypecase result-type | 990 | (cl-etypecase result-type |
| 991 | ((member nil) nil) | 991 | ((member nil) nil) |
| 992 | ((member t) t) | 992 | ((member t) t) |
| 993 | ((member :failed) (ert-test-failed-p result)) | 993 | ((member :failed) (ert-test-failed-p result)) |
| 994 | ((member :passed) (ert-test-passed-p result)) | 994 | ((member :passed) (ert-test-passed-p result)) |
| 995 | (cons | 995 | (cons |
| 996 | (destructuring-bind (operator &rest operands) result-type | 996 | (cl-destructuring-bind (operator &rest operands) result-type |
| 997 | (ecase operator | 997 | (cl-ecase operator |
| 998 | (and | 998 | (and |
| 999 | (case (length operands) | 999 | (cl-case (length operands) |
| 1000 | (0 t) | 1000 | (0 t) |
| 1001 | (t | 1001 | (t |
| 1002 | (and (ert-test-result-type-p result (first operands)) | 1002 | (and (ert-test-result-type-p result (car operands)) |
| 1003 | (ert-test-result-type-p result `(and ,@(rest operands))))))) | 1003 | (ert-test-result-type-p result `(and ,@(cdr operands))))))) |
| 1004 | (or | 1004 | (or |
| 1005 | (case (length operands) | 1005 | (cl-case (length operands) |
| 1006 | (0 nil) | 1006 | (0 nil) |
| 1007 | (t | 1007 | (t |
| 1008 | (or (ert-test-result-type-p result (first operands)) | 1008 | (or (ert-test-result-type-p result (car operands)) |
| 1009 | (ert-test-result-type-p result `(or ,@(rest operands))))))) | 1009 | (ert-test-result-type-p result `(or ,@(cdr operands))))))) |
| 1010 | (not | 1010 | (not |
| 1011 | (assert (eql (length operands) 1)) | 1011 | (cl-assert (eql (length operands) 1)) |
| 1012 | (not (ert-test-result-type-p result (first operands)))) | 1012 | (not (ert-test-result-type-p result (car operands)))) |
| 1013 | (satisfies | 1013 | (satisfies |
| 1014 | (assert (eql (length operands) 1)) | 1014 | (cl-assert (eql (length operands) 1)) |
| 1015 | (funcall (first operands) result))))))) | 1015 | (funcall (car operands) result))))))) |
| 1016 | 1016 | ||
| 1017 | (defun ert-test-result-expected-p (test result) | 1017 | (defun ert-test-result-expected-p (test result) |
| 1018 | "Return non-nil if TEST's expected result type matches RESULT." | 1018 | "Return non-nil if TEST's expected result type matches RESULT." |
| @@ -1053,9 +1053,9 @@ set implied by them without checking whether it is really | |||
| 1053 | contained in UNIVERSE." | 1053 | contained in UNIVERSE." |
| 1054 | ;; This code needs to match the etypecase in | 1054 | ;; This code needs to match the etypecase in |
| 1055 | ;; `ert-insert-human-readable-selector'. | 1055 | ;; `ert-insert-human-readable-selector'. |
| 1056 | (etypecase selector | 1056 | (cl-etypecase selector |
| 1057 | ((member nil) nil) | 1057 | ((member nil) nil) |
| 1058 | ((member t) (etypecase universe | 1058 | ((member t) (cl-etypecase universe |
| 1059 | (list universe) | 1059 | (list universe) |
| 1060 | ((member t) (ert-select-tests "" universe)))) | 1060 | ((member t) (ert-select-tests "" universe)))) |
| 1061 | ((member :new) (ert-select-tests | 1061 | ((member :new) (ert-select-tests |
| @@ -1083,7 +1083,7 @@ contained in UNIVERSE." | |||
| 1083 | universe)) | 1083 | universe)) |
| 1084 | ((member :unexpected) (ert-select-tests `(not :expected) universe)) | 1084 | ((member :unexpected) (ert-select-tests `(not :expected) universe)) |
| 1085 | (string | 1085 | (string |
| 1086 | (etypecase universe | 1086 | (cl-etypecase universe |
| 1087 | ((member t) (mapcar #'ert-get-test | 1087 | ((member t) (mapcar #'ert-get-test |
| 1088 | (apropos-internal selector #'ert-test-boundp))) | 1088 | (apropos-internal selector #'ert-test-boundp))) |
| 1089 | (list (ert--remove-if-not (lambda (test) | 1089 | (list (ert--remove-if-not (lambda (test) |
| @@ -1093,51 +1093,51 @@ contained in UNIVERSE." | |||
| 1093 | universe)))) | 1093 | universe)))) |
| 1094 | (ert-test (list selector)) | 1094 | (ert-test (list selector)) |
| 1095 | (symbol | 1095 | (symbol |
| 1096 | (assert (ert-test-boundp selector)) | 1096 | (cl-assert (ert-test-boundp selector)) |
| 1097 | (list (ert-get-test selector))) | 1097 | (list (ert-get-test selector))) |
| 1098 | (cons | 1098 | (cons |
| 1099 | (destructuring-bind (operator &rest operands) selector | 1099 | (cl-destructuring-bind (operator &rest operands) selector |
| 1100 | (ecase operator | 1100 | (cl-ecase operator |
| 1101 | (member | 1101 | (member |
| 1102 | (mapcar (lambda (purported-test) | 1102 | (mapcar (lambda (purported-test) |
| 1103 | (etypecase purported-test | 1103 | (cl-etypecase purported-test |
| 1104 | (symbol (assert (ert-test-boundp purported-test)) | 1104 | (symbol (cl-assert (ert-test-boundp purported-test)) |
| 1105 | (ert-get-test purported-test)) | 1105 | (ert-get-test purported-test)) |
| 1106 | (ert-test purported-test))) | 1106 | (ert-test purported-test))) |
| 1107 | operands)) | 1107 | operands)) |
| 1108 | (eql | 1108 | (eql |
| 1109 | (assert (eql (length operands) 1)) | 1109 | (cl-assert (eql (length operands) 1)) |
| 1110 | (ert-select-tests `(member ,@operands) universe)) | 1110 | (ert-select-tests `(member ,@operands) universe)) |
| 1111 | (and | 1111 | (and |
| 1112 | ;; Do these definitions of AND, NOT and OR satisfy de | 1112 | ;; Do these definitions of AND, NOT and OR satisfy de |
| 1113 | ;; Morgan's laws? Should they? | 1113 | ;; Morgan's laws? Should they? |
| 1114 | (case (length operands) | 1114 | (cl-case (length operands) |
| 1115 | (0 (ert-select-tests 't universe)) | 1115 | (0 (ert-select-tests 't universe)) |
| 1116 | (t (ert-select-tests `(and ,@(rest operands)) | 1116 | (t (ert-select-tests `(and ,@(cdr operands)) |
| 1117 | (ert-select-tests (first operands) | 1117 | (ert-select-tests (car operands) |
| 1118 | universe))))) | 1118 | universe))))) |
| 1119 | (not | 1119 | (not |
| 1120 | (assert (eql (length operands) 1)) | 1120 | (cl-assert (eql (length operands) 1)) |
| 1121 | (let ((all-tests (ert-select-tests 't universe))) | 1121 | (let ((all-tests (ert-select-tests 't universe))) |
| 1122 | (ert--set-difference all-tests | 1122 | (ert--set-difference all-tests |
| 1123 | (ert-select-tests (first operands) | 1123 | (ert-select-tests (car operands) |
| 1124 | all-tests)))) | 1124 | all-tests)))) |
| 1125 | (or | 1125 | (or |
| 1126 | (case (length operands) | 1126 | (cl-case (length operands) |
| 1127 | (0 (ert-select-tests 'nil universe)) | 1127 | (0 (ert-select-tests 'nil universe)) |
| 1128 | (t (ert--union (ert-select-tests (first operands) universe) | 1128 | (t (ert--union (ert-select-tests (car operands) universe) |
| 1129 | (ert-select-tests `(or ,@(rest operands)) | 1129 | (ert-select-tests `(or ,@(cdr operands)) |
| 1130 | universe))))) | 1130 | universe))))) |
| 1131 | (tag | 1131 | (tag |
| 1132 | (assert (eql (length operands) 1)) | 1132 | (cl-assert (eql (length operands) 1)) |
| 1133 | (let ((tag (first operands))) | 1133 | (let ((tag (car operands))) |
| 1134 | (ert-select-tests `(satisfies | 1134 | (ert-select-tests `(satisfies |
| 1135 | ,(lambda (test) | 1135 | ,(lambda (test) |
| 1136 | (member tag (ert-test-tags test)))) | 1136 | (member tag (ert-test-tags test)))) |
| 1137 | universe))) | 1137 | universe))) |
| 1138 | (satisfies | 1138 | (satisfies |
| 1139 | (assert (eql (length operands) 1)) | 1139 | (cl-assert (eql (length operands) 1)) |
| 1140 | (ert--remove-if-not (first operands) | 1140 | (ert--remove-if-not (car operands) |
| 1141 | (ert-select-tests 't universe)))))))) | 1141 | (ert-select-tests 't universe)))))))) |
| 1142 | 1142 | ||
| 1143 | (defun ert--insert-human-readable-selector (selector) | 1143 | (defun ert--insert-human-readable-selector (selector) |
| @@ -1146,26 +1146,27 @@ contained in UNIVERSE." | |||
| 1146 | ;; `backtrace' slot of the result objects in the | 1146 | ;; `backtrace' slot of the result objects in the |
| 1147 | ;; `most-recent-result' slots of test case objects in (eql ...) or | 1147 | ;; `most-recent-result' slots of test case objects in (eql ...) or |
| 1148 | ;; (member ...) selectors. | 1148 | ;; (member ...) selectors. |
| 1149 | (labels ((rec (selector) | 1149 | (cl-labels ((rec (selector) |
| 1150 | ;; This code needs to match the etypecase in `ert-select-tests'. | 1150 | ;; This code needs to match the etypecase in |
| 1151 | (etypecase selector | 1151 | ;; `ert-select-tests'. |
| 1152 | ((or (member nil t | 1152 | (cl-etypecase selector |
| 1153 | :new :failed :passed | 1153 | ((or (member nil t |
| 1154 | :expected :unexpected) | 1154 | :new :failed :passed |
| 1155 | string | 1155 | :expected :unexpected) |
| 1156 | symbol) | 1156 | string |
| 1157 | selector) | 1157 | symbol) |
| 1158 | (ert-test | 1158 | selector) |
| 1159 | (if (ert-test-name selector) | 1159 | (ert-test |
| 1160 | (make-symbol (format "<%S>" (ert-test-name selector))) | 1160 | (if (ert-test-name selector) |
| 1161 | (make-symbol "<unnamed test>"))) | 1161 | (make-symbol (format "<%S>" (ert-test-name selector))) |
| 1162 | (cons | 1162 | (make-symbol "<unnamed test>"))) |
| 1163 | (destructuring-bind (operator &rest operands) selector | 1163 | (cons |
| 1164 | (ecase operator | 1164 | (cl-destructuring-bind (operator &rest operands) selector |
| 1165 | ((member eql and not or) | 1165 | (cl-ecase operator |
| 1166 | `(,operator ,@(mapcar #'rec operands))) | 1166 | ((member eql and not or) |
| 1167 | ((member tag satisfies) | 1167 | `(,operator ,@(mapcar #'rec operands))) |
| 1168 | selector))))))) | 1168 | ((member tag satisfies) |
| 1169 | selector))))))) | ||
| 1169 | (insert (format "%S" (rec selector))))) | 1170 | (insert (format "%S" (rec selector))))) |
| 1170 | 1171 | ||
| 1171 | 1172 | ||
| @@ -1182,21 +1183,21 @@ contained in UNIVERSE." | |||
| 1182 | ;; that corresponds to this run in order to be able to update the | 1183 | ;; that corresponds to this run in order to be able to update the |
| 1183 | ;; statistics correctly when a test is re-run interactively and has a | 1184 | ;; statistics correctly when a test is re-run interactively and has a |
| 1184 | ;; different result than before. | 1185 | ;; different result than before. |
| 1185 | (defstruct ert--stats | 1186 | (cl-defstruct ert--stats |
| 1186 | (selector (assert nil)) | 1187 | (selector (cl-assert nil)) |
| 1187 | ;; The tests, in order. | 1188 | ;; The tests, in order. |
| 1188 | (tests (assert nil) :type vector) | 1189 | (tests (cl-assert nil) :type vector) |
| 1189 | ;; A map of test names (or the test objects themselves for unnamed | 1190 | ;; A map of test names (or the test objects themselves for unnamed |
| 1190 | ;; tests) to indices into the `tests' vector. | 1191 | ;; tests) to indices into the `tests' vector. |
| 1191 | (test-map (assert nil) :type hash-table) | 1192 | (test-map (cl-assert nil) :type hash-table) |
| 1192 | ;; The results of the tests during this run, in order. | 1193 | ;; The results of the tests during this run, in order. |
| 1193 | (test-results (assert nil) :type vector) | 1194 | (test-results (cl-assert nil) :type vector) |
| 1194 | ;; The start times of the tests, in order, as reported by | 1195 | ;; The start times of the tests, in order, as reported by |
| 1195 | ;; `current-time'. | 1196 | ;; `current-time'. |
| 1196 | (test-start-times (assert nil) :type vector) | 1197 | (test-start-times (cl-assert nil) :type vector) |
| 1197 | ;; The end times of the tests, in order, as reported by | 1198 | ;; The end times of the tests, in order, as reported by |
| 1198 | ;; `current-time'. | 1199 | ;; `current-time'. |
| 1199 | (test-end-times (assert nil) :type vector) | 1200 | (test-end-times (cl-assert nil) :type vector) |
| 1200 | (passed-expected 0) | 1201 | (passed-expected 0) |
| 1201 | (passed-unexpected 0) | 1202 | (passed-unexpected 0) |
| 1202 | (failed-expected 0) | 1203 | (failed-expected 0) |
| @@ -1246,21 +1247,25 @@ Also changes the counters in STATS to match." | |||
| 1246 | (results (ert--stats-test-results stats)) | 1247 | (results (ert--stats-test-results stats)) |
| 1247 | (old-test (aref tests pos)) | 1248 | (old-test (aref tests pos)) |
| 1248 | (map (ert--stats-test-map stats))) | 1249 | (map (ert--stats-test-map stats))) |
| 1249 | (flet ((update (d) | 1250 | (cl-flet ((update (d) |
| 1250 | (if (ert-test-result-expected-p (aref tests pos) | 1251 | (if (ert-test-result-expected-p (aref tests pos) |
| 1251 | (aref results pos)) | 1252 | (aref results pos)) |
| 1252 | (etypecase (aref results pos) | 1253 | (cl-etypecase (aref results pos) |
| 1253 | (ert-test-passed (incf (ert--stats-passed-expected stats) d)) | 1254 | (ert-test-passed |
| 1254 | (ert-test-failed (incf (ert--stats-failed-expected stats) d)) | 1255 | (cl-incf (ert--stats-passed-expected stats) d)) |
| 1255 | (null) | 1256 | (ert-test-failed |
| 1256 | (ert-test-aborted-with-non-local-exit) | 1257 | (cl-incf (ert--stats-failed-expected stats) d)) |
| 1257 | (ert-test-quit)) | 1258 | (null) |
| 1258 | (etypecase (aref results pos) | 1259 | (ert-test-aborted-with-non-local-exit) |
| 1259 | (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) | 1260 | (ert-test-quit)) |
| 1260 | (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) | 1261 | (cl-etypecase (aref results pos) |
| 1261 | (null) | 1262 | (ert-test-passed |
| 1262 | (ert-test-aborted-with-non-local-exit) | 1263 | (cl-incf (ert--stats-passed-unexpected stats) d)) |
| 1263 | (ert-test-quit))))) | 1264 | (ert-test-failed |
| 1265 | (cl-incf (ert--stats-failed-unexpected stats) d)) | ||
| 1266 | (null) | ||
| 1267 | (ert-test-aborted-with-non-local-exit) | ||
| 1268 | (ert-test-quit))))) | ||
| 1264 | ;; Adjust counters to remove the result that is currently in stats. | 1269 | ;; Adjust counters to remove the result that is currently in stats. |
| 1265 | (update -1) | 1270 | (update -1) |
| 1266 | ;; Put new test and result into stats. | 1271 | ;; Put new test and result into stats. |
| @@ -1278,11 +1283,11 @@ Also changes the counters in STATS to match." | |||
| 1278 | SELECTOR is the selector that was used to select TESTS." | 1283 | SELECTOR is the selector that was used to select TESTS." |
| 1279 | (setq tests (ert--coerce-to-vector tests)) | 1284 | (setq tests (ert--coerce-to-vector tests)) |
| 1280 | (let ((map (make-hash-table :size (length tests)))) | 1285 | (let ((map (make-hash-table :size (length tests)))) |
| 1281 | (loop for i from 0 | 1286 | (cl-loop for i from 0 |
| 1282 | for test across tests | 1287 | for test across tests |
| 1283 | for key = (ert--stats-test-key test) do | 1288 | for key = (ert--stats-test-key test) do |
| 1284 | (assert (not (gethash key map))) | 1289 | (cl-assert (not (gethash key map))) |
| 1285 | (setf (gethash key map) i)) | 1290 | (setf (gethash key map) i)) |
| 1286 | (make-ert--stats :selector selector | 1291 | (make-ert--stats :selector selector |
| 1287 | :tests tests | 1292 | :tests tests |
| 1288 | :test-map map | 1293 | :test-map map |
| @@ -1324,8 +1329,8 @@ SELECTOR is the selector that was used to select TESTS." | |||
| 1324 | (force-mode-line-update) | 1329 | (force-mode-line-update) |
| 1325 | (unwind-protect | 1330 | (unwind-protect |
| 1326 | (progn | 1331 | (progn |
| 1327 | (loop for test in tests do | 1332 | (cl-loop for test in tests do |
| 1328 | (ert-run-or-rerun-test stats test listener)) | 1333 | (ert-run-or-rerun-test stats test listener)) |
| 1329 | (setq abortedp nil)) | 1334 | (setq abortedp nil)) |
| 1330 | (setf (ert--stats-aborted-p stats) abortedp) | 1335 | (setf (ert--stats-aborted-p stats) abortedp) |
| 1331 | (setf (ert--stats-end-time stats) (current-time)) | 1336 | (setf (ert--stats-end-time stats) (current-time)) |
| @@ -1349,7 +1354,7 @@ SELECTOR is the selector that was used to select TESTS." | |||
| 1349 | "Return a character that represents the test result RESULT. | 1354 | "Return a character that represents the test result RESULT. |
| 1350 | 1355 | ||
| 1351 | EXPECTEDP specifies whether the result was expected." | 1356 | EXPECTEDP specifies whether the result was expected." |
| 1352 | (let ((s (etypecase result | 1357 | (let ((s (cl-etypecase result |
| 1353 | (ert-test-passed ".P") | 1358 | (ert-test-passed ".P") |
| 1354 | (ert-test-failed "fF") | 1359 | (ert-test-failed "fF") |
| 1355 | (null "--") | 1360 | (null "--") |
| @@ -1361,7 +1366,7 @@ EXPECTEDP specifies whether the result was expected." | |||
| 1361 | "Return a string that represents the test result RESULT. | 1366 | "Return a string that represents the test result RESULT. |
| 1362 | 1367 | ||
| 1363 | EXPECTEDP specifies whether the result was expected." | 1368 | EXPECTEDP specifies whether the result was expected." |
| 1364 | (let ((s (etypecase result | 1369 | (let ((s (cl-etypecase result |
| 1365 | (ert-test-passed '("passed" "PASSED")) | 1370 | (ert-test-passed '("passed" "PASSED")) |
| 1366 | (ert-test-failed '("failed" "FAILED")) | 1371 | (ert-test-failed '("failed" "FAILED")) |
| 1367 | (null '("unknown" "UNKNOWN")) | 1372 | (null '("unknown" "UNKNOWN")) |
| @@ -1383,9 +1388,9 @@ Ensures a final newline is inserted." | |||
| 1383 | "Insert `ert-info' infos from RESULT into current buffer. | 1388 | "Insert `ert-info' infos from RESULT into current buffer. |
| 1384 | 1389 | ||
| 1385 | RESULT must be an `ert-test-result-with-condition'." | 1390 | RESULT must be an `ert-test-result-with-condition'." |
| 1386 | (check-type result ert-test-result-with-condition) | 1391 | (cl-check-type result ert-test-result-with-condition) |
| 1387 | (dolist (info (ert-test-result-with-condition-infos result)) | 1392 | (dolist (info (ert-test-result-with-condition-infos result)) |
| 1388 | (destructuring-bind (prefix . message) info | 1393 | (cl-destructuring-bind (prefix . message) info |
| 1389 | (let ((begin (point)) | 1394 | (let ((begin (point)) |
| 1390 | (indentation (make-string (+ (length prefix) 4) ?\s)) | 1395 | (indentation (make-string (+ (length prefix) 4) ?\s)) |
| 1391 | (end nil)) | 1396 | (end nil)) |
| @@ -1421,14 +1426,14 @@ Returns the stats object." | |||
| 1421 | (ert-run-tests | 1426 | (ert-run-tests |
| 1422 | selector | 1427 | selector |
| 1423 | (lambda (event-type &rest event-args) | 1428 | (lambda (event-type &rest event-args) |
| 1424 | (ecase event-type | 1429 | (cl-ecase event-type |
| 1425 | (run-started | 1430 | (run-started |
| 1426 | (destructuring-bind (stats) event-args | 1431 | (cl-destructuring-bind (stats) event-args |
| 1427 | (message "Running %s tests (%s)" | 1432 | (message "Running %s tests (%s)" |
| 1428 | (length (ert--stats-tests stats)) | 1433 | (length (ert--stats-tests stats)) |
| 1429 | (ert--format-time-iso8601 (ert--stats-start-time stats))))) | 1434 | (ert--format-time-iso8601 (ert--stats-start-time stats))))) |
| 1430 | (run-ended | 1435 | (run-ended |
| 1431 | (destructuring-bind (stats abortedp) event-args | 1436 | (cl-destructuring-bind (stats abortedp) event-args |
| 1432 | (let ((unexpected (ert-stats-completed-unexpected stats)) | 1437 | (let ((unexpected (ert-stats-completed-unexpected stats)) |
| 1433 | (expected-failures (ert--stats-failed-expected stats))) | 1438 | (expected-failures (ert--stats-failed-expected stats))) |
| 1434 | (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" | 1439 | (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" |
| @@ -1446,19 +1451,19 @@ Returns the stats object." | |||
| 1446 | (format "\n%s expected failures" expected-failures))) | 1451 | (format "\n%s expected failures" expected-failures))) |
| 1447 | (unless (zerop unexpected) | 1452 | (unless (zerop unexpected) |
| 1448 | (message "%s unexpected results:" unexpected) | 1453 | (message "%s unexpected results:" unexpected) |
| 1449 | (loop for test across (ert--stats-tests stats) | 1454 | (cl-loop for test across (ert--stats-tests stats) |
| 1450 | for result = (ert-test-most-recent-result test) do | 1455 | for result = (ert-test-most-recent-result test) do |
| 1451 | (when (not (ert-test-result-expected-p test result)) | 1456 | (when (not (ert-test-result-expected-p test result)) |
| 1452 | (message "%9s %S" | 1457 | (message "%9s %S" |
| 1453 | (ert-string-for-test-result result nil) | 1458 | (ert-string-for-test-result result nil) |
| 1454 | (ert-test-name test)))) | 1459 | (ert-test-name test)))) |
| 1455 | (message "%s" ""))))) | 1460 | (message "%s" ""))))) |
| 1456 | (test-started | 1461 | (test-started |
| 1457 | ) | 1462 | ) |
| 1458 | (test-ended | 1463 | (test-ended |
| 1459 | (destructuring-bind (stats test result) event-args | 1464 | (cl-destructuring-bind (stats test result) event-args |
| 1460 | (unless (ert-test-result-expected-p test result) | 1465 | (unless (ert-test-result-expected-p test result) |
| 1461 | (etypecase result | 1466 | (cl-etypecase result |
| 1462 | (ert-test-passed | 1467 | (ert-test-passed |
| 1463 | (message "Test %S passed unexpectedly" (ert-test-name test))) | 1468 | (message "Test %S passed unexpectedly" (ert-test-name test))) |
| 1464 | (ert-test-result-with-condition | 1469 | (ert-test-result-with-condition |
| @@ -1484,7 +1489,7 @@ Returns the stats object." | |||
| 1484 | (ert--pp-with-indentation-and-newline | 1489 | (ert--pp-with-indentation-and-newline |
| 1485 | (ert-test-result-with-condition-condition result))) | 1490 | (ert-test-result-with-condition-condition result))) |
| 1486 | (goto-char (1- (point-max))) | 1491 | (goto-char (1- (point-max))) |
| 1487 | (assert (looking-at "\n")) | 1492 | (cl-assert (looking-at "\n")) |
| 1488 | (delete-char 1) | 1493 | (delete-char 1) |
| 1489 | (message "Test %S condition:" (ert-test-name test)) | 1494 | (message "Test %S condition:" (ert-test-name test)) |
| 1490 | (message "%s" (buffer-string)))) | 1495 | (message "%s" (buffer-string)))) |
| @@ -1532,7 +1537,7 @@ the tests)." | |||
| 1532 | (1 font-lock-keyword-face nil t) | 1537 | (1 font-lock-keyword-face nil t) |
| 1533 | (2 font-lock-function-name-face nil t))))) | 1538 | (2 font-lock-function-name-face nil t))))) |
| 1534 | 1539 | ||
| 1535 | (defun* ert--remove-from-list (list-var element &key key test) | 1540 | (cl-defun ert--remove-from-list (list-var element &key key test) |
| 1536 | "Remove ELEMENT from the value of LIST-VAR if present. | 1541 | "Remove ELEMENT from the value of LIST-VAR if present. |
| 1537 | 1542 | ||
| 1538 | This can be used as an inverse of `add-to-list'." | 1543 | This can be used as an inverse of `add-to-list'." |
| @@ -1557,7 +1562,7 @@ If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to | |||
| 1557 | include the default, if any. | 1562 | include the default, if any. |
| 1558 | 1563 | ||
| 1559 | Signals an error if no test name was read." | 1564 | Signals an error if no test name was read." |
| 1560 | (etypecase default | 1565 | (cl-etypecase default |
| 1561 | (string (let ((symbol (intern-soft default))) | 1566 | (string (let ((symbol (intern-soft default))) |
| 1562 | (unless (and symbol (ert-test-boundp symbol)) | 1567 | (unless (and symbol (ert-test-boundp symbol)) |
| 1563 | (setq default nil)))) | 1568 | (setq default nil)))) |
| @@ -1614,11 +1619,11 @@ Nothing more than an interactive interface to `ert-make-test-unbound'." | |||
| 1614 | ;;; Display of test progress and results. | 1619 | ;;; Display of test progress and results. |
| 1615 | 1620 | ||
| 1616 | ;; An entry in the results buffer ewoc. There is one entry per test. | 1621 | ;; An entry in the results buffer ewoc. There is one entry per test. |
| 1617 | (defstruct ert--ewoc-entry | 1622 | (cl-defstruct ert--ewoc-entry |
| 1618 | (test (assert nil)) | 1623 | (test (cl-assert nil)) |
| 1619 | ;; If the result of this test was expected, its ewoc entry is hidden | 1624 | ;; If the result of this test was expected, its ewoc entry is hidden |
| 1620 | ;; initially. | 1625 | ;; initially. |
| 1621 | (hidden-p (assert nil)) | 1626 | (hidden-p (cl-assert nil)) |
| 1622 | ;; An ewoc entry may be collapsed to hide details such as the error | 1627 | ;; An ewoc entry may be collapsed to hide details such as the error |
| 1623 | ;; condition. | 1628 | ;; condition. |
| 1624 | ;; | 1629 | ;; |
| @@ -1694,7 +1699,7 @@ Also sets `ert--results-progress-bar-button-begin'." | |||
| 1694 | ((ert--stats-current-test stats) 'running) | 1699 | ((ert--stats-current-test stats) 'running) |
| 1695 | ((ert--stats-end-time stats) 'finished) | 1700 | ((ert--stats-end-time stats) 'finished) |
| 1696 | (t 'preparing)))) | 1701 | (t 'preparing)))) |
| 1697 | (ecase state | 1702 | (cl-ecase state |
| 1698 | (preparing | 1703 | (preparing |
| 1699 | (insert "")) | 1704 | (insert "")) |
| 1700 | (aborted | 1705 | (aborted |
| @@ -1705,12 +1710,12 @@ Also sets `ert--results-progress-bar-button-begin'." | |||
| 1705 | (t | 1710 | (t |
| 1706 | (insert "Aborted.")))) | 1711 | (insert "Aborted.")))) |
| 1707 | (running | 1712 | (running |
| 1708 | (assert (ert--stats-current-test stats)) | 1713 | (cl-assert (ert--stats-current-test stats)) |
| 1709 | (insert "Running test: ") | 1714 | (insert "Running test: ") |
| 1710 | (ert-insert-test-name-button (ert-test-name | 1715 | (ert-insert-test-name-button (ert-test-name |
| 1711 | (ert--stats-current-test stats)))) | 1716 | (ert--stats-current-test stats)))) |
| 1712 | (finished | 1717 | (finished |
| 1713 | (assert (not (ert--stats-current-test stats))) | 1718 | (cl-assert (not (ert--stats-current-test stats))) |
| 1714 | (insert "Finished."))) | 1719 | (insert "Finished."))) |
| 1715 | (insert "\n") | 1720 | (insert "\n") |
| 1716 | (if (ert--stats-end-time stats) | 1721 | (if (ert--stats-end-time stats) |
| @@ -1813,7 +1818,7 @@ non-nil, returns the face for expected results.." | |||
| 1813 | (defun ert-face-for-stats (stats) | 1818 | (defun ert-face-for-stats (stats) |
| 1814 | "Return a face that represents STATS." | 1819 | "Return a face that represents STATS." |
| 1815 | (cond ((ert--stats-aborted-p stats) 'nil) | 1820 | (cond ((ert--stats-aborted-p stats) 'nil) |
| 1816 | ((plusp (ert-stats-completed-unexpected stats)) | 1821 | ((cl-plusp (ert-stats-completed-unexpected stats)) |
| 1817 | (ert-face-for-test-result nil)) | 1822 | (ert-face-for-test-result nil)) |
| 1818 | ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) | 1823 | ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) |
| 1819 | (ert-face-for-test-result t)) | 1824 | (ert-face-for-test-result t)) |
| @@ -1824,7 +1829,7 @@ non-nil, returns the face for expected results.." | |||
| 1824 | (let* ((test (ert--ewoc-entry-test entry)) | 1829 | (let* ((test (ert--ewoc-entry-test entry)) |
| 1825 | (stats ert--results-stats) | 1830 | (stats ert--results-stats) |
| 1826 | (result (let ((pos (ert--stats-test-pos stats test))) | 1831 | (result (let ((pos (ert--stats-test-pos stats test))) |
| 1827 | (assert pos) | 1832 | (cl-assert pos) |
| 1828 | (aref (ert--stats-test-results stats) pos))) | 1833 | (aref (ert--stats-test-results stats) pos))) |
| 1829 | (hiddenp (ert--ewoc-entry-hidden-p entry)) | 1834 | (hiddenp (ert--ewoc-entry-hidden-p entry)) |
| 1830 | (expandedp (ert--ewoc-entry-expanded-p entry)) | 1835 | (expandedp (ert--ewoc-entry-expanded-p entry)) |
| @@ -1850,7 +1855,7 @@ non-nil, returns the face for expected results.." | |||
| 1850 | (ert--string-first-line (ert-test-documentation test)) | 1855 | (ert--string-first-line (ert-test-documentation test)) |
| 1851 | 'font-lock-face 'font-lock-doc-face) | 1856 | 'font-lock-face 'font-lock-doc-face) |
| 1852 | "\n")) | 1857 | "\n")) |
| 1853 | (etypecase result | 1858 | (cl-etypecase result |
| 1854 | (ert-test-passed | 1859 | (ert-test-passed |
| 1855 | (if (ert-test-result-expected-p test result) | 1860 | (if (ert-test-result-expected-p test result) |
| 1856 | (insert " passed\n") | 1861 | (insert " passed\n") |
| @@ -1908,9 +1913,10 @@ BUFFER-NAME, if non-nil, is the buffer name to use." | |||
| 1908 | (make-string (ert-stats-total stats) | 1913 | (make-string (ert-stats-total stats) |
| 1909 | (ert-char-for-test-result nil t))) | 1914 | (ert-char-for-test-result nil t))) |
| 1910 | (set (make-local-variable 'ert--results-listener) listener) | 1915 | (set (make-local-variable 'ert--results-listener) listener) |
| 1911 | (loop for test across (ert--stats-tests stats) do | 1916 | (cl-loop for test across (ert--stats-tests stats) do |
| 1912 | (ewoc-enter-last ewoc | 1917 | (ewoc-enter-last ewoc |
| 1913 | (make-ert--ewoc-entry :test test :hidden-p t))) | 1918 | (make-ert--ewoc-entry :test test |
| 1919 | :hidden-p t))) | ||
| 1914 | (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) | 1920 | (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) |
| 1915 | (goto-char (1- (point-max))) | 1921 | (goto-char (1- (point-max))) |
| 1916 | buffer))))) | 1922 | buffer))))) |
| @@ -1945,21 +1951,21 @@ and how to display message." | |||
| 1945 | default nil)) | 1951 | default nil)) |
| 1946 | nil)) | 1952 | nil)) |
| 1947 | (unless message-fn (setq message-fn 'message)) | 1953 | (unless message-fn (setq message-fn 'message)) |
| 1948 | (lexical-let ((output-buffer-name output-buffer-name) | 1954 | (let ((output-buffer-name output-buffer-name) |
| 1949 | buffer | 1955 | buffer |
| 1950 | listener | 1956 | listener |
| 1951 | (message-fn message-fn)) | 1957 | (message-fn message-fn)) |
| 1952 | (setq listener | 1958 | (setq listener |
| 1953 | (lambda (event-type &rest event-args) | 1959 | (lambda (event-type &rest event-args) |
| 1954 | (ecase event-type | 1960 | (cl-ecase event-type |
| 1955 | (run-started | 1961 | (run-started |
| 1956 | (destructuring-bind (stats) event-args | 1962 | (cl-destructuring-bind (stats) event-args |
| 1957 | (setq buffer (ert--setup-results-buffer stats | 1963 | (setq buffer (ert--setup-results-buffer stats |
| 1958 | listener | 1964 | listener |
| 1959 | output-buffer-name)) | 1965 | output-buffer-name)) |
| 1960 | (pop-to-buffer buffer))) | 1966 | (pop-to-buffer buffer))) |
| 1961 | (run-ended | 1967 | (run-ended |
| 1962 | (destructuring-bind (stats abortedp) event-args | 1968 | (cl-destructuring-bind (stats abortedp) event-args |
| 1963 | (funcall message-fn | 1969 | (funcall message-fn |
| 1964 | "%sRan %s tests, %s results were as expected%s" | 1970 | "%sRan %s tests, %s results were as expected%s" |
| 1965 | (if (not abortedp) | 1971 | (if (not abortedp) |
| @@ -1976,19 +1982,19 @@ and how to display message." | |||
| 1976 | ert--results-ewoc) | 1982 | ert--results-ewoc) |
| 1977 | stats))) | 1983 | stats))) |
| 1978 | (test-started | 1984 | (test-started |
| 1979 | (destructuring-bind (stats test) event-args | 1985 | (cl-destructuring-bind (stats test) event-args |
| 1980 | (with-current-buffer buffer | 1986 | (with-current-buffer buffer |
| 1981 | (let* ((ewoc ert--results-ewoc) | 1987 | (let* ((ewoc ert--results-ewoc) |
| 1982 | (pos (ert--stats-test-pos stats test)) | 1988 | (pos (ert--stats-test-pos stats test)) |
| 1983 | (node (ewoc-nth ewoc pos))) | 1989 | (node (ewoc-nth ewoc pos))) |
| 1984 | (assert node) | 1990 | (cl-assert node) |
| 1985 | (setf (ert--ewoc-entry-test (ewoc-data node)) test) | 1991 | (setf (ert--ewoc-entry-test (ewoc-data node)) test) |
| 1986 | (aset ert--results-progress-bar-string pos | 1992 | (aset ert--results-progress-bar-string pos |
| 1987 | (ert-char-for-test-result nil t)) | 1993 | (ert-char-for-test-result nil t)) |
| 1988 | (ert--results-update-stats-display-maybe ewoc stats) | 1994 | (ert--results-update-stats-display-maybe ewoc stats) |
| 1989 | (ewoc-invalidate ewoc node))))) | 1995 | (ewoc-invalidate ewoc node))))) |
| 1990 | (test-ended | 1996 | (test-ended |
| 1991 | (destructuring-bind (stats test result) event-args | 1997 | (cl-destructuring-bind (stats test result) event-args |
| 1992 | (with-current-buffer buffer | 1998 | (with-current-buffer buffer |
| 1993 | (let* ((ewoc ert--results-ewoc) | 1999 | (let* ((ewoc ert--results-ewoc) |
| 1994 | (pos (ert--stats-test-pos stats test)) | 2000 | (pos (ert--stats-test-pos stats test)) |
| @@ -2020,28 +2026,28 @@ and how to display message." | |||
| 2020 | (define-derived-mode ert-results-mode special-mode "ERT-Results" | 2026 | (define-derived-mode ert-results-mode special-mode "ERT-Results" |
| 2021 | "Major mode for viewing results of ERT test runs.") | 2027 | "Major mode for viewing results of ERT test runs.") |
| 2022 | 2028 | ||
| 2023 | (loop for (key binding) in | 2029 | (cl-loop for (key binding) in |
| 2024 | '(;; Stuff that's not in the menu. | 2030 | '( ;; Stuff that's not in the menu. |
| 2025 | ("\t" forward-button) | 2031 | ("\t" forward-button) |
| 2026 | ([backtab] backward-button) | 2032 | ([backtab] backward-button) |
| 2027 | ("j" ert-results-jump-between-summary-and-result) | 2033 | ("j" ert-results-jump-between-summary-and-result) |
| 2028 | ("L" ert-results-toggle-printer-limits-for-test-at-point) | 2034 | ("L" ert-results-toggle-printer-limits-for-test-at-point) |
| 2029 | ("n" ert-results-next-test) | 2035 | ("n" ert-results-next-test) |
| 2030 | ("p" ert-results-previous-test) | 2036 | ("p" ert-results-previous-test) |
| 2031 | ;; Stuff that is in the menu. | 2037 | ;; Stuff that is in the menu. |
| 2032 | ("R" ert-results-rerun-all-tests) | 2038 | ("R" ert-results-rerun-all-tests) |
| 2033 | ("r" ert-results-rerun-test-at-point) | 2039 | ("r" ert-results-rerun-test-at-point) |
| 2034 | ("d" ert-results-rerun-test-at-point-debugging-errors) | 2040 | ("d" ert-results-rerun-test-at-point-debugging-errors) |
| 2035 | ("." ert-results-find-test-at-point-other-window) | 2041 | ("." ert-results-find-test-at-point-other-window) |
| 2036 | ("b" ert-results-pop-to-backtrace-for-test-at-point) | 2042 | ("b" ert-results-pop-to-backtrace-for-test-at-point) |
| 2037 | ("m" ert-results-pop-to-messages-for-test-at-point) | 2043 | ("m" ert-results-pop-to-messages-for-test-at-point) |
| 2038 | ("l" ert-results-pop-to-should-forms-for-test-at-point) | 2044 | ("l" ert-results-pop-to-should-forms-for-test-at-point) |
| 2039 | ("h" ert-results-describe-test-at-point) | 2045 | ("h" ert-results-describe-test-at-point) |
| 2040 | ("D" ert-delete-test) | 2046 | ("D" ert-delete-test) |
| 2041 | ("T" ert-results-pop-to-timings) | 2047 | ("T" ert-results-pop-to-timings) |
| 2042 | ) | 2048 | ) |
| 2043 | do | 2049 | do |
| 2044 | (define-key ert-results-mode-map key binding)) | 2050 | (define-key ert-results-mode-map key binding)) |
| 2045 | 2051 | ||
| 2046 | (easy-menu-define ert-results-mode-menu ert-results-mode-map | 2052 | (easy-menu-define ert-results-mode-menu ert-results-mode-map |
| 2047 | "Menu for `ert-results-mode'." | 2053 | "Menu for `ert-results-mode'." |
| @@ -2121,15 +2127,15 @@ To be used in the ERT results buffer." | |||
| 2121 | EWOC-FN specifies the direction and should be either `ewoc-prev' | 2127 | EWOC-FN specifies the direction and should be either `ewoc-prev' |
| 2122 | or `ewoc-next'. If there are no more nodes in that direction, an | 2128 | or `ewoc-next'. If there are no more nodes in that direction, an |
| 2123 | error is signaled with the message ERROR-MESSAGE." | 2129 | error is signaled with the message ERROR-MESSAGE." |
| 2124 | (loop | 2130 | (cl-loop |
| 2125 | (setq node (funcall ewoc-fn ert--results-ewoc node)) | 2131 | (setq node (funcall ewoc-fn ert--results-ewoc node)) |
| 2126 | (when (null node) | 2132 | (when (null node) |
| 2127 | (error "%s" error-message)) | 2133 | (error "%s" error-message)) |
| 2128 | (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) | 2134 | (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) |
| 2129 | (goto-char (ewoc-location node)) | 2135 | (goto-char (ewoc-location node)) |
| 2130 | (return)))) | 2136 | (cl-return)))) |
| 2131 | 2137 | ||
| 2132 | (defun ert--results-expand-collapse-button-action (button) | 2138 | (defun ert--results-expand-collapse-button-action (_button) |
| 2133 | "Expand or collapse the test node BUTTON belongs to." | 2139 | "Expand or collapse the test node BUTTON belongs to." |
| 2134 | (let* ((ewoc ert--results-ewoc) | 2140 | (let* ((ewoc ert--results-ewoc) |
| 2135 | (node (save-excursion | 2141 | (node (save-excursion |
| @@ -2158,11 +2164,11 @@ To be used in the ERT results buffer." | |||
| 2158 | (defun ert--ewoc-position (ewoc node) | 2164 | (defun ert--ewoc-position (ewoc node) |
| 2159 | ;; checkdoc-order: nil | 2165 | ;; checkdoc-order: nil |
| 2160 | "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." | 2166 | "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." |
| 2161 | (loop for i from 0 | 2167 | (cl-loop for i from 0 |
| 2162 | for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) | 2168 | for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) |
| 2163 | do (when (eql node node-here) | 2169 | do (when (eql node node-here) |
| 2164 | (return i)) | 2170 | (cl-return i)) |
| 2165 | finally (return nil))) | 2171 | finally (cl-return nil))) |
| 2166 | 2172 | ||
| 2167 | (defun ert-results-jump-between-summary-and-result () | 2173 | (defun ert-results-jump-between-summary-and-result () |
| 2168 | "Jump back and forth between the test run summary and individual test results. | 2174 | "Jump back and forth between the test run summary and individual test results. |
| @@ -2210,7 +2216,7 @@ To be used in the ERT results buffer." | |||
| 2210 | "Return the test at point, or nil. | 2216 | "Return the test at point, or nil. |
| 2211 | 2217 | ||
| 2212 | To be used in the ERT results buffer." | 2218 | To be used in the ERT results buffer." |
| 2213 | (assert (eql major-mode 'ert-results-mode)) | 2219 | (cl-assert (eql major-mode 'ert-results-mode)) |
| 2214 | (if (ert--results-test-node-or-null-at-point) | 2220 | (if (ert--results-test-node-or-null-at-point) |
| 2215 | (let* ((node (ert--results-test-node-at-point)) | 2221 | (let* ((node (ert--results-test-node-at-point)) |
| 2216 | (test (ert--ewoc-entry-test (ewoc-data node)))) | 2222 | (test (ert--ewoc-entry-test (ewoc-data node)))) |
| @@ -2282,9 +2288,9 @@ definition." | |||
| 2282 | (point)) | 2288 | (point)) |
| 2283 | ((eventp last-command-event) | 2289 | ((eventp last-command-event) |
| 2284 | (posn-point (event-start last-command-event))) | 2290 | (posn-point (event-start last-command-event))) |
| 2285 | (t (assert nil)))) | 2291 | (t (cl-assert nil)))) |
| 2286 | 2292 | ||
| 2287 | (defun ert--results-progress-bar-button-action (button) | 2293 | (defun ert--results-progress-bar-button-action (_button) |
| 2288 | "Jump to details for the test represented by the character clicked in BUTTON." | 2294 | "Jump to details for the test represented by the character clicked in BUTTON." |
| 2289 | (goto-char (ert--button-action-position)) | 2295 | (goto-char (ert--button-action-position)) |
| 2290 | (ert-results-jump-between-summary-and-result)) | 2296 | (ert-results-jump-between-summary-and-result)) |
| @@ -2294,7 +2300,7 @@ definition." | |||
| 2294 | 2300 | ||
| 2295 | To be used in the ERT results buffer." | 2301 | To be used in the ERT results buffer." |
| 2296 | (interactive) | 2302 | (interactive) |
| 2297 | (assert (eql major-mode 'ert-results-mode)) | 2303 | (cl-assert (eql major-mode 'ert-results-mode)) |
| 2298 | (let ((selector (ert--stats-selector ert--results-stats))) | 2304 | (let ((selector (ert--stats-selector ert--results-stats))) |
| 2299 | (ert-run-tests-interactively selector (buffer-name)))) | 2305 | (ert-run-tests-interactively selector (buffer-name)))) |
| 2300 | 2306 | ||
| @@ -2303,13 +2309,13 @@ To be used in the ERT results buffer." | |||
| 2303 | 2309 | ||
| 2304 | To be used in the ERT results buffer." | 2310 | To be used in the ERT results buffer." |
| 2305 | (interactive) | 2311 | (interactive) |
| 2306 | (destructuring-bind (test redefinition-state) | 2312 | (cl-destructuring-bind (test redefinition-state) |
| 2307 | (ert--results-test-at-point-allow-redefinition) | 2313 | (ert--results-test-at-point-allow-redefinition) |
| 2308 | (when (null test) | 2314 | (when (null test) |
| 2309 | (error "No test at point")) | 2315 | (error "No test at point")) |
| 2310 | (let* ((stats ert--results-stats) | 2316 | (let* ((stats ert--results-stats) |
| 2311 | (progress-message (format "Running %stest %S" | 2317 | (progress-message (format "Running %stest %S" |
| 2312 | (ecase redefinition-state | 2318 | (cl-ecase redefinition-state |
| 2313 | ((nil) "") | 2319 | ((nil) "") |
| 2314 | (redefined "new definition of ") | 2320 | (redefined "new definition of ") |
| 2315 | (deleted "deleted ")) | 2321 | (deleted "deleted ")) |
| @@ -2350,7 +2356,7 @@ To be used in the ERT results buffer." | |||
| 2350 | (stats ert--results-stats) | 2356 | (stats ert--results-stats) |
| 2351 | (pos (ert--stats-test-pos stats test)) | 2357 | (pos (ert--stats-test-pos stats test)) |
| 2352 | (result (aref (ert--stats-test-results stats) pos))) | 2358 | (result (aref (ert--stats-test-results stats) pos))) |
| 2353 | (etypecase result | 2359 | (cl-etypecase result |
| 2354 | (ert-test-passed (error "Test passed, no backtrace available")) | 2360 | (ert-test-passed (error "Test passed, no backtrace available")) |
| 2355 | (ert-test-result-with-condition | 2361 | (ert-test-result-with-condition |
| 2356 | (let ((backtrace (ert-test-result-with-condition-backtrace result)) | 2362 | (let ((backtrace (ert-test-result-with-condition-backtrace result)) |
| @@ -2408,13 +2414,14 @@ To be used in the ERT results buffer." | |||
| 2408 | (ert-simple-view-mode) | 2414 | (ert-simple-view-mode) |
| 2409 | (if (null (ert-test-result-should-forms result)) | 2415 | (if (null (ert-test-result-should-forms result)) |
| 2410 | (insert "\n(No should forms during this test.)\n") | 2416 | (insert "\n(No should forms during this test.)\n") |
| 2411 | (loop for form-description in (ert-test-result-should-forms result) | 2417 | (cl-loop for form-description |
| 2412 | for i from 1 do | 2418 | in (ert-test-result-should-forms result) |
| 2413 | (insert "\n") | 2419 | for i from 1 do |
| 2414 | (insert (format "%s: " i)) | 2420 | (insert "\n") |
| 2415 | (let ((begin (point))) | 2421 | (insert (format "%s: " i)) |
| 2416 | (ert--pp-with-indentation-and-newline form-description) | 2422 | (let ((begin (point))) |
| 2417 | (ert--make-xrefs-region begin (point))))) | 2423 | (ert--pp-with-indentation-and-newline form-description) |
| 2424 | (ert--make-xrefs-region begin (point))))) | ||
| 2418 | (goto-char (point-min)) | 2425 | (goto-char (point-min)) |
| 2419 | (insert "`should' forms executed during test `") | 2426 | (insert "`should' forms executed during test `") |
| 2420 | (ert-insert-test-name-button (ert-test-name test)) | 2427 | (ert-insert-test-name-button (ert-test-name test)) |
| @@ -2443,17 +2450,16 @@ To be used in the ERT results buffer." | |||
| 2443 | To be used in the ERT results buffer." | 2450 | To be used in the ERT results buffer." |
| 2444 | (interactive) | 2451 | (interactive) |
| 2445 | (let* ((stats ert--results-stats) | 2452 | (let* ((stats ert--results-stats) |
| 2446 | (start-times (ert--stats-test-start-times stats)) | ||
| 2447 | (end-times (ert--stats-test-end-times stats)) | ||
| 2448 | (buffer (get-buffer-create "*ERT timings*")) | 2453 | (buffer (get-buffer-create "*ERT timings*")) |
| 2449 | (data (loop for test across (ert--stats-tests stats) | 2454 | (data (cl-loop for test across (ert--stats-tests stats) |
| 2450 | for start-time across (ert--stats-test-start-times stats) | 2455 | for start-time across (ert--stats-test-start-times |
| 2451 | for end-time across (ert--stats-test-end-times stats) | 2456 | stats) |
| 2452 | collect (list test | 2457 | for end-time across (ert--stats-test-end-times stats) |
| 2453 | (float-time (subtract-time end-time | 2458 | collect (list test |
| 2454 | start-time)))))) | 2459 | (float-time (subtract-time |
| 2460 | end-time start-time)))))) | ||
| 2455 | (setq data (sort data (lambda (a b) | 2461 | (setq data (sort data (lambda (a b) |
| 2456 | (> (second a) (second b))))) | 2462 | (> (cl-second a) (cl-second b))))) |
| 2457 | (pop-to-buffer buffer) | 2463 | (pop-to-buffer buffer) |
| 2458 | (let ((inhibit-read-only t)) | 2464 | (let ((inhibit-read-only t)) |
| 2459 | (buffer-disable-undo) | 2465 | (buffer-disable-undo) |
| @@ -2462,13 +2468,13 @@ To be used in the ERT results buffer." | |||
| 2462 | (if (null data) | 2468 | (if (null data) |
| 2463 | (insert "(No data)\n") | 2469 | (insert "(No data)\n") |
| 2464 | (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) | 2470 | (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) |
| 2465 | (loop for (test time) in data | 2471 | (cl-loop for (test time) in data |
| 2466 | for cumul-time = time then (+ cumul-time time) | 2472 | for cumul-time = time then (+ cumul-time time) |
| 2467 | for i from 1 do | 2473 | for i from 1 do |
| 2468 | (let ((begin (point))) | 2474 | (progn |
| 2469 | (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) | 2475 | (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) |
| 2470 | (ert-insert-test-name-button (ert-test-name test)) | 2476 | (ert-insert-test-name-button (ert-test-name test)) |
| 2471 | (insert "\n")))) | 2477 | (insert "\n")))) |
| 2472 | (goto-char (point-min)) | 2478 | (goto-char (point-min)) |
| 2473 | (insert "Tests by run time (seconds):\n\n") | 2479 | (insert "Tests by run time (seconds):\n\n") |
| 2474 | (forward-line 1)))) | 2480 | (forward-line 1)))) |
| @@ -2481,7 +2487,7 @@ To be used in the ERT results buffer." | |||
| 2481 | (error "Requires Emacs 24")) | 2487 | (error "Requires Emacs 24")) |
| 2482 | (let (test-name | 2488 | (let (test-name |
| 2483 | test-definition) | 2489 | test-definition) |
| 2484 | (etypecase test-or-test-name | 2490 | (cl-etypecase test-or-test-name |
| 2485 | (symbol (setq test-name test-or-test-name | 2491 | (symbol (setq test-name test-or-test-name |
| 2486 | test-definition (ert-get-test test-or-test-name))) | 2492 | test-definition (ert-get-test test-or-test-name))) |
| 2487 | (ert-test (setq test-name (ert-test-name test-or-test-name) | 2493 | (ert-test (setq test-name (ert-test-name test-or-test-name) |
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 540e0166ec2..d9c5316b1b8 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el | |||
| @@ -402,6 +402,56 @@ of the piece of advice." | |||
| 402 | (if (fboundp function-name) | 402 | (if (fboundp function-name) |
| 403 | (symbol-function function-name)))))) | 403 | (symbol-function function-name)))))) |
| 404 | 404 | ||
| 405 | ;; When code is advised, called-interactively-p needs to be taught to skip | ||
| 406 | ;; the advising frames. | ||
| 407 | ;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p | ||
| 408 | ;; done from the advised function if the deepest advice is an around advice! | ||
| 409 | ;; In other cases (calls from an advice or calls from the advised function when | ||
| 410 | ;; the deepest advice is not an around advice), it should hopefully get | ||
| 411 | ;; it right. | ||
| 412 | (add-hook 'called-interactively-p-functions | ||
| 413 | #'advice--called-interactively-skip) | ||
| 414 | (defun advice--called-interactively-skip (origi frame1 frame2) | ||
| 415 | (let* ((i origi) | ||
| 416 | (get-next-frame | ||
| 417 | (lambda () | ||
| 418 | (setq frame1 frame2) | ||
| 419 | (setq frame2 (internal--called-interactively-p--get-frame i)) | ||
| 420 | ;; (message "Advice Frame %d = %S" i frame2) | ||
| 421 | (setq i (1+ i))))) | ||
| 422 | (when (and (eq (nth 1 frame2) 'apply) | ||
| 423 | (progn | ||
| 424 | (funcall get-next-frame) | ||
| 425 | (advice--p (indirect-function (nth 1 frame2))))) | ||
| 426 | (funcall get-next-frame) | ||
| 427 | ;; If we now have the symbol, this was the head advice and | ||
| 428 | ;; we're done. | ||
| 429 | (while (advice--p (nth 1 frame1)) | ||
| 430 | ;; This was an inner advice called from some earlier advice. | ||
| 431 | ;; The stack frames look different depending on the particular | ||
| 432 | ;; kind of the earlier advice. | ||
| 433 | (let ((inneradvice (nth 1 frame1))) | ||
| 434 | (if (and (eq (nth 1 frame2) 'apply) | ||
| 435 | (progn | ||
| 436 | (funcall get-next-frame) | ||
| 437 | (advice--p (indirect-function | ||
| 438 | (nth 1 frame2))))) | ||
| 439 | ;; The earlier advice was something like a before/after | ||
| 440 | ;; advice where the "next" code is called directly by the | ||
| 441 | ;; advice--p object. | ||
| 442 | (funcall get-next-frame) | ||
| 443 | ;; It's apparently an around advice, where the "next" is | ||
| 444 | ;; called by the body of the advice in any way it sees fit, | ||
| 445 | ;; so we need to skip the frames of that body. | ||
| 446 | (while | ||
| 447 | (progn | ||
| 448 | (funcall get-next-frame) | ||
| 449 | (not (and (eq (nth 1 frame2) 'apply) | ||
| 450 | (eq (nth 3 frame2) inneradvice))))) | ||
| 451 | (funcall get-next-frame) | ||
| 452 | (funcall get-next-frame)))) | ||
| 453 | (- i origi 1)))) | ||
| 454 | |||
| 405 | 455 | ||
| 406 | (provide 'nadvice) | 456 | (provide 'nadvice) |
| 407 | ;;; nadvice.el ends here | 457 | ;;; nadvice.el ends here |
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index c6fff7aa443..722e6270e95 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; trace.el --- tracing facility for Emacs Lisp functions | 1 | ;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -151,18 +151,15 @@ | |||
| 151 | 151 | ||
| 152 | ;;; Code: | 152 | ;;; Code: |
| 153 | 153 | ||
| 154 | (require 'advice) | ||
| 155 | |||
| 156 | (defgroup trace nil | 154 | (defgroup trace nil |
| 157 | "Tracing facility for Emacs Lisp functions." | 155 | "Tracing facility for Emacs Lisp functions." |
| 158 | :prefix "trace-" | 156 | :prefix "trace-" |
| 159 | :group 'lisp) | 157 | :group 'lisp) |
| 160 | 158 | ||
| 161 | ;;;###autoload | 159 | ;;;###autoload |
| 162 | (defcustom trace-buffer (purecopy "*trace-output*") | 160 | (defcustom trace-buffer "*trace-output*" |
| 163 | "Trace output will by default go to that buffer." | 161 | "Trace output will by default go to that buffer." |
| 164 | :type 'string | 162 | :type 'string) |
| 165 | :group 'trace) | ||
| 166 | 163 | ||
| 167 | ;; Current level of traced function invocation: | 164 | ;; Current level of traced function invocation: |
| 168 | (defvar trace-level 0) | 165 | (defvar trace-level 0) |
| @@ -176,78 +173,109 @@ | |||
| 176 | (defvar inhibit-trace nil | 173 | (defvar inhibit-trace nil |
| 177 | "If non-nil, all tracing is temporarily inhibited.") | 174 | "If non-nil, all tracing is temporarily inhibited.") |
| 178 | 175 | ||
| 179 | (defun trace-entry-message (function level argument-bindings) | 176 | (defun trace-entry-message (function level args context) |
| 180 | ;; Generates a string that describes that FUNCTION has been entered at | 177 | "Generate a string that describes that FUNCTION has been entered. |
| 181 | ;; trace LEVEL with ARGUMENT-BINDINGS. | 178 | LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, |
| 182 | (format "%s%s%d -> %s: %s\n" | 179 | and CONTEXT is a string describing the dynamic context (e.g. values of |
| 183 | (mapconcat 'char-to-string (make-string (1- level) ?|) " ") | 180 | some global variables)." |
| 184 | (if (> level 1) " " "") | 181 | (let ((print-circle t)) |
| 185 | level | 182 | (format "%s%s%d -> %S%s\n" |
| 186 | function | 183 | (mapconcat 'char-to-string (make-string (1- level) ?|) " ") |
| 187 | (let ((print-circle t)) | 184 | (if (> level 1) " " "") |
| 188 | (mapconcat (lambda (binding) | 185 | level |
| 189 | (concat | 186 | (cons function args) |
| 190 | (symbol-name (ad-arg-binding-field binding 'name)) | 187 | context))) |
| 191 | "=" | 188 | |
| 192 | ;; do this so we'll see strings: | 189 | (defun trace-exit-message (function level value context) |
| 193 | (prin1-to-string | 190 | "Generate a string that describes that FUNCTION has exited. |
| 194 | (ad-arg-binding-field binding 'value)))) | 191 | LEVEL is the trace level, VALUE value returned by FUNCTION, |
| 195 | argument-bindings | 192 | and CONTEXT is a string describing the dynamic context (e.g. values of |
| 196 | " ")))) | 193 | some global variables)." |
| 197 | 194 | (let ((print-circle t)) | |
| 198 | (defun trace-exit-message (function level value) | 195 | (format "%s%s%d <- %s: %S%s\n" |
| 199 | ;; Generates a string that describes that FUNCTION has been exited at | 196 | (mapconcat 'char-to-string (make-string (1- level) ?|) " ") |
| 200 | ;; trace LEVEL and that it returned VALUE. | 197 | (if (> level 1) " " "") |
| 201 | (format "%s%s%d <- %s: %s\n" | 198 | level |
| 202 | (mapconcat 'char-to-string (make-string (1- level) ?|) " ") | 199 | function |
| 203 | (if (> level 1) " " "") | 200 | ;; Do this so we'll see strings: |
| 204 | level | 201 | value |
| 205 | function | 202 | context))) |
| 206 | ;; do this so we'll see strings: | 203 | |
| 207 | (let ((print-circle t)) (prin1-to-string value)))) | 204 | (defvar trace--timer nil) |
| 208 | 205 | ||
| 209 | (defun trace-make-advice (function buffer background) | 206 | (defun trace-make-advice (function buffer background context) |
| 210 | ;; Builds the piece of advice to be added to FUNCTION's advice info | 207 | "Build the piece of advice to be added to trace FUNCTION. |
| 211 | ;; so that it will generate the proper trace output in BUFFER | 208 | FUNCTION is the name of the traced function. |
| 212 | ;; (quietly if BACKGROUND is t). | 209 | BUFFER is the buffer where the trace should be printed. |
| 213 | (ad-make-advice | 210 | BACKGROUND if nil means to display BUFFER. |
| 214 | trace-advice-name nil t | 211 | CONTEXT if non-nil should be a function that returns extra info that should |
| 215 | `(advice | 212 | be printed along with the arguments in the trace." |
| 216 | lambda () | 213 | (lambda (body &rest args) |
| 217 | (let ((trace-level (1+ trace-level)) | 214 | (let ((trace-level (1+ trace-level)) |
| 218 | (trace-buffer (get-buffer-create ,buffer))) | 215 | (trace-buffer (get-buffer-create buffer)) |
| 219 | (unless inhibit-trace | 216 | (ctx (funcall context))) |
| 220 | (with-current-buffer trace-buffer | 217 | (unless inhibit-trace |
| 221 | (set (make-local-variable 'window-point-insertion-type) t) | 218 | (with-current-buffer trace-buffer |
| 222 | ,(unless background '(display-buffer trace-buffer)) | 219 | (set (make-local-variable 'window-point-insertion-type) t) |
| 223 | (goto-char (point-max)) | 220 | (unless (or background trace--timer |
| 224 | ;; Insert a separator from previous trace output: | 221 | (get-buffer-window trace-buffer 'visible)) |
| 225 | (if (= trace-level 1) (insert trace-separator)) | 222 | (setq trace--timer |
| 226 | (insert | 223 | ;; Postpone the display to some later time, in case we |
| 227 | (trace-entry-message | 224 | ;; can't actually do it now. |
| 228 | ',function trace-level ad-arg-bindings)))) | 225 | (run-with-timer 0 nil |
| 229 | ad-do-it | 226 | (lambda () |
| 230 | (unless inhibit-trace | 227 | (setq trace--timer nil) |
| 231 | (with-current-buffer trace-buffer | 228 | (display-buffer trace-buffer))))) |
| 232 | ,(unless background '(display-buffer trace-buffer)) | 229 | (goto-char (point-max)) |
| 233 | (goto-char (point-max)) | 230 | ;; Insert a separator from previous trace output: |
| 234 | (insert | 231 | (if (= trace-level 1) (insert trace-separator)) |
| 235 | (trace-exit-message | 232 | (insert |
| 236 | ',function trace-level ad-return-value)))))))) | 233 | (trace-entry-message |
| 237 | 234 | function trace-level args ctx)))) | |
| 238 | (defun trace-function-internal (function buffer background) | 235 | (let ((result)) |
| 239 | ;; Adds trace advice for FUNCTION and activates it. | 236 | (unwind-protect |
| 240 | (ad-add-advice | 237 | (setq result (list (apply body args))) |
| 241 | function | 238 | (unless inhibit-trace |
| 242 | (trace-make-advice function (or buffer trace-buffer) background) | 239 | (let ((ctx (funcall context))) |
| 243 | 'around 'last) | 240 | (with-current-buffer trace-buffer |
| 244 | (ad-activate function nil)) | 241 | (unless background (display-buffer trace-buffer)) |
| 242 | (goto-char (point-max)) | ||
| 243 | (insert | ||
| 244 | (trace-exit-message | ||
| 245 | function | ||
| 246 | trace-level | ||
| 247 | (if result (car result) '\!non-local\ exit\!) | ||
| 248 | ctx)))))) | ||
| 249 | (car result))))) | ||
| 250 | |||
| 251 | (defun trace-function-internal (function buffer background context) | ||
| 252 | "Add trace advice for FUNCTION." | ||
| 253 | (advice-add | ||
| 254 | function :around | ||
| 255 | (trace-make-advice function (or buffer trace-buffer) background | ||
| 256 | (or context (lambda () ""))) | ||
| 257 | `((name . ,trace-advice-name)))) | ||
| 245 | 258 | ||
| 246 | (defun trace-is-traced (function) | 259 | (defun trace-is-traced (function) |
| 247 | (ad-find-advice function 'around trace-advice-name)) | 260 | (advice-member-p trace-advice-name function)) |
| 261 | |||
| 262 | (defun trace--read-args (prompt) | ||
| 263 | (cons | ||
| 264 | (intern (completing-read prompt obarray 'fboundp t)) | ||
| 265 | (when current-prefix-arg | ||
| 266 | (list | ||
| 267 | (read-buffer "Output to buffer: " trace-buffer) | ||
| 268 | (let ((exp | ||
| 269 | (let ((minibuffer-completing-symbol t)) | ||
| 270 | (read-from-minibuffer "Context expression: " | ||
| 271 | nil read-expression-map t | ||
| 272 | 'read-expression-history)))) | ||
| 273 | `(lambda () | ||
| 274 | (let ((print-circle t)) | ||
| 275 | (concat " [" (prin1-to-string ,exp) "]")))))))) | ||
| 248 | 276 | ||
| 249 | ;;;###autoload | 277 | ;;;###autoload |
| 250 | (defun trace-function (function &optional buffer) | 278 | (defun trace-function-foreground (function &optional buffer context) |
| 251 | "Traces FUNCTION with trace output going to BUFFER. | 279 | "Traces FUNCTION with trace output going to BUFFER. |
| 252 | For every call of FUNCTION Lisp-style trace messages that display argument | 280 | For every call of FUNCTION Lisp-style trace messages that display argument |
| 253 | and return values will be inserted into BUFFER. This function generates the | 281 | and return values will be inserted into BUFFER. This function generates the |
| @@ -255,14 +283,11 @@ trace advice for FUNCTION and activates it together with any other advice | |||
| 255 | there might be!! The trace BUFFER will popup whenever FUNCTION is called. | 283 | there might be!! The trace BUFFER will popup whenever FUNCTION is called. |
| 256 | Do not use this to trace functions that switch buffers or do any other | 284 | Do not use this to trace functions that switch buffers or do any other |
| 257 | display oriented stuff, use `trace-function-background' instead." | 285 | display oriented stuff, use `trace-function-background' instead." |
| 258 | (interactive | 286 | (interactive (trace--read-args "Trace function: ")) |
| 259 | (list | 287 | (trace-function-internal function buffer nil context)) |
| 260 | (intern (completing-read "Trace function: " obarray 'fboundp t)) | ||
| 261 | (read-buffer "Output to buffer: " trace-buffer))) | ||
| 262 | (trace-function-internal function buffer nil)) | ||
| 263 | 288 | ||
| 264 | ;;;###autoload | 289 | ;;;###autoload |
| 265 | (defun trace-function-background (function &optional buffer) | 290 | (defun trace-function-background (function &optional buffer context) |
| 266 | "Traces FUNCTION with trace output going quietly to BUFFER. | 291 | "Traces FUNCTION with trace output going quietly to BUFFER. |
| 267 | When this tracing is enabled, every call to FUNCTION writes | 292 | When this tracing is enabled, every call to FUNCTION writes |
| 268 | a Lisp-style trace message (showing the arguments and return value) | 293 | a Lisp-style trace message (showing the arguments and return value) |
| @@ -272,12 +297,11 @@ The trace output goes to BUFFER quietly, without changing | |||
| 272 | the window or buffer configuration. | 297 | the window or buffer configuration. |
| 273 | 298 | ||
| 274 | BUFFER defaults to `trace-buffer'." | 299 | BUFFER defaults to `trace-buffer'." |
| 275 | (interactive | 300 | (interactive (trace--read-args "Trace function in background: ")) |
| 276 | (list | 301 | (trace-function-internal function buffer t context)) |
| 277 | (intern | 302 | |
| 278 | (completing-read "Trace function in background: " obarray 'fboundp t)) | 303 | ;;;###autoload |
| 279 | (read-buffer "Output to buffer: " trace-buffer))) | 304 | (defalias 'trace-function 'trace-function-foreground) |
| 280 | (trace-function-internal function buffer t)) | ||
| 281 | 305 | ||
| 282 | (defun untrace-function (function) | 306 | (defun untrace-function (function) |
| 283 | "Untraces FUNCTION and possibly activates all remaining advice. | 307 | "Untraces FUNCTION and possibly activates all remaining advice. |
| @@ -285,16 +309,14 @@ Activation is performed with `ad-update', hence remaining advice will get | |||
| 285 | activated only if the advice of FUNCTION is currently active. If FUNCTION | 309 | activated only if the advice of FUNCTION is currently active. If FUNCTION |
| 286 | was not traced this is a noop." | 310 | was not traced this is a noop." |
| 287 | (interactive | 311 | (interactive |
| 288 | (list (ad-read-advised-function "Untrace function" 'trace-is-traced))) | 312 | (list (intern (completing-read "Untrace function: " |
| 289 | (when (trace-is-traced function) | 313 | obarray #'trace-is-traced t)))) |
| 290 | (ad-remove-advice function 'around trace-advice-name) | 314 | (advice-remove function trace-advice-name)) |
| 291 | (ad-update function))) | ||
| 292 | 315 | ||
| 293 | (defun untrace-all () | 316 | (defun untrace-all () |
| 294 | "Untraces all currently traced functions." | 317 | "Untraces all currently traced functions." |
| 295 | (interactive) | 318 | (interactive) |
| 296 | (ad-do-advised-functions (function) | 319 | (mapatoms #'untrace-function)) |
| 297 | (untrace-function function))) | ||
| 298 | 320 | ||
| 299 | (provide 'trace) | 321 | (provide 'trace) |
| 300 | 322 | ||
diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog index e0a88461dc9..ca7edd1aa88 100644 --- a/lisp/erc/ChangeLog +++ b/lisp/erc/ChangeLog | |||
| @@ -1,3 +1,16 @@ | |||
| 1 | 2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | Use cl-lib instead of cl, and interactive-p => called-interactively-p. | ||
| 4 | * erc-track.el, erc-networks.el, erc-netsplit.el, erc-dcc.el: | ||
| 5 | * erc-backend.el: Use cl-lib, nth, pcase, and called-interactively-p | ||
| 6 | instead of cl. | ||
| 7 | * erc-speedbar.el, erc-services.el, erc-pcomplete.el, erc-notify.el: | ||
| 8 | * erc-match.el, erc-log.el, erc-join.el, erc-ezbounce.el: | ||
| 9 | * erc-capab.el: Don't require cl since we don't use it. | ||
| 10 | * erc.el: Use cl-lib, nth, pcase, and called-interactively-p i.s.o cl. | ||
| 11 | (erc-lurker-ignore-chars, erc-common-server-suffixes): | ||
| 12 | Move before first use. | ||
| 13 | |||
| 1 | 2012-11-16 Glenn Morris <rgm@gnu.org> | 14 | 2012-11-16 Glenn Morris <rgm@gnu.org> |
| 2 | 15 | ||
| 3 | * erc.el (erc-modules): Add "notifications". Tweak "hecomplete" doc. | 16 | * erc.el (erc-modules): Add "notifications". Tweak "hecomplete" doc. |
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 90b96d7c763..a3d0ebe121f 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el | |||
| @@ -98,7 +98,7 @@ | |||
| 98 | ;;; Code: | 98 | ;;; Code: |
| 99 | 99 | ||
| 100 | (require 'erc-compat) | 100 | (require 'erc-compat) |
| 101 | (eval-when-compile (require 'cl)) | 101 | (eval-when-compile (require 'cl-lib)) |
| 102 | ;; There's a fairly strong mutual dependency between erc.el and erc-backend.el. | 102 | ;; There's a fairly strong mutual dependency between erc.el and erc-backend.el. |
| 103 | ;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the | 103 | ;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the |
| 104 | ;; reverse is true: | 104 | ;; reverse is true: |
| @@ -109,7 +109,7 @@ | |||
| 109 | (defvar erc-server-responses (make-hash-table :test #'equal) | 109 | (defvar erc-server-responses (make-hash-table :test #'equal) |
| 110 | "Hashtable mapping server responses to their handler hooks.") | 110 | "Hashtable mapping server responses to their handler hooks.") |
| 111 | 111 | ||
| 112 | (defstruct (erc-response (:conc-name erc-response.)) | 112 | (cl-defstruct (erc-response (:conc-name erc-response.)) |
| 113 | (unparsed "" :type string) | 113 | (unparsed "" :type string) |
| 114 | (sender "" :type string) | 114 | (sender "" :type string) |
| 115 | (command "" :type string) | 115 | (command "" :type string) |
| @@ -950,7 +950,7 @@ PROCs `process-buffer' is `current-buffer' when this function is called." | |||
| 950 | (push str (erc-response.command-args msg)))) | 950 | (push str (erc-response.command-args msg)))) |
| 951 | 951 | ||
| 952 | (setf (erc-response.contents msg) | 952 | (setf (erc-response.contents msg) |
| 953 | (first (erc-response.command-args msg))) | 953 | (car (erc-response.command-args msg))) |
| 954 | 954 | ||
| 955 | (setf (erc-response.command-args msg) | 955 | (setf (erc-response.command-args msg) |
| 956 | (nreverse (erc-response.command-args msg))) | 956 | (nreverse (erc-response.command-args msg))) |
| @@ -1045,7 +1045,7 @@ Finds hooks by looking in the `erc-server-responses' hashtable." | |||
| 1045 | (name &rest name) | 1045 | (name &rest name) |
| 1046 | &optional sexp sexp def-body)) | 1046 | &optional sexp sexp def-body)) |
| 1047 | 1047 | ||
| 1048 | (defmacro* define-erc-response-handler ((name &rest aliases) | 1048 | (cl-defmacro define-erc-response-handler ((name &rest aliases) |
| 1049 | &optional extra-fn-doc extra-var-doc | 1049 | &optional extra-fn-doc extra-var-doc |
| 1050 | &rest fn-body) | 1050 | &rest fn-body) |
| 1051 | "Define an ERC handler hook/function pair. | 1051 | "Define an ERC handler hook/function pair. |
| @@ -1154,11 +1154,11 @@ add things to `%s' instead." | |||
| 1154 | "") | 1154 | "") |
| 1155 | name hook-name)) | 1155 | name hook-name)) |
| 1156 | (fn-alternates | 1156 | (fn-alternates |
| 1157 | (loop for alias in aliases | 1157 | (cl-loop for alias in aliases |
| 1158 | collect (intern (format "erc-server-%s" alias)))) | 1158 | collect (intern (format "erc-server-%s" alias)))) |
| 1159 | (var-alternates | 1159 | (var-alternates |
| 1160 | (loop for alias in aliases | 1160 | (cl-loop for alias in aliases |
| 1161 | collect (intern (format "erc-server-%s-functions" alias))))) | 1161 | collect (intern (format "erc-server-%s-functions" alias))))) |
| 1162 | `(prog2 | 1162 | `(prog2 |
| 1163 | ;; Normal hook variable. | 1163 | ;; Normal hook variable. |
| 1164 | (defvar ,hook-name ',fn-name ,(format hook-doc name)) | 1164 | (defvar ,hook-name ',fn-name ,(format hook-doc name)) |
| @@ -1172,19 +1172,19 @@ add things to `%s' instead." | |||
| 1172 | (put ',hook-name 'definition-name ',name) | 1172 | (put ',hook-name 'definition-name ',name) |
| 1173 | 1173 | ||
| 1174 | ;; Hashtable map of responses to hook variables | 1174 | ;; Hashtable map of responses to hook variables |
| 1175 | ,@(loop for response in (cons name aliases) | 1175 | ,@(cl-loop for response in (cons name aliases) |
| 1176 | for var in (cons hook-name var-alternates) | 1176 | for var in (cons hook-name var-alternates) |
| 1177 | collect `(puthash ,(format "%s" response) ',var | 1177 | collect `(puthash ,(format "%s" response) ',var |
| 1178 | erc-server-responses)) | 1178 | erc-server-responses)) |
| 1179 | ;; Alternates. | 1179 | ;; Alternates. |
| 1180 | ;; Functions are defaliased, hook variables are defvared so we | 1180 | ;; Functions are defaliased, hook variables are defvared so we |
| 1181 | ;; can add hooks to one alias, but not another. | 1181 | ;; can add hooks to one alias, but not another. |
| 1182 | ,@(loop for fn in fn-alternates | 1182 | ,@(cl-loop for fn in fn-alternates |
| 1183 | for var in var-alternates | 1183 | for var in var-alternates |
| 1184 | for a in aliases | 1184 | for a in aliases |
| 1185 | nconc (list `(defalias ',fn ',fn-name) | 1185 | nconc (list `(defalias ',fn ',fn-name) |
| 1186 | `(defvar ,var ',fn-name ,(format hook-doc a)) | 1186 | `(defvar ,var ',fn-name ,(format hook-doc a)) |
| 1187 | `(put ',var 'definition-name ',hook-name)))))) | 1187 | `(put ',var 'definition-name ',hook-name)))))) |
| 1188 | 1188 | ||
| 1189 | (define-erc-response-handler (ERROR) | 1189 | (define-erc-response-handler (ERROR) |
| 1190 | "Handle an ERROR command from the server." nil | 1190 | "Handle an ERROR command from the server." nil |
| @@ -1196,10 +1196,10 @@ add things to `%s' instead." | |||
| 1196 | (define-erc-response-handler (INVITE) | 1196 | (define-erc-response-handler (INVITE) |
| 1197 | "Handle invitation messages." | 1197 | "Handle invitation messages." |
| 1198 | nil | 1198 | nil |
| 1199 | (let ((target (first (erc-response.command-args parsed))) | 1199 | (let ((target (car (erc-response.command-args parsed))) |
| 1200 | (chnl (erc-response.contents parsed))) | 1200 | (chnl (erc-response.contents parsed))) |
| 1201 | (multiple-value-bind (nick login host) | 1201 | (pcase-let ((`(,nick ,login ,host) |
| 1202 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1202 | (erc-parse-user (erc-response.sender parsed)))) |
| 1203 | (setq erc-invitation chnl) | 1203 | (setq erc-invitation chnl) |
| 1204 | (when (string= target (erc-current-nick)) | 1204 | (when (string= target (erc-current-nick)) |
| 1205 | (erc-display-message | 1205 | (erc-display-message |
| @@ -1212,8 +1212,8 @@ add things to `%s' instead." | |||
| 1212 | nil | 1212 | nil |
| 1213 | (let ((chnl (erc-response.contents parsed)) | 1213 | (let ((chnl (erc-response.contents parsed)) |
| 1214 | (buffer nil)) | 1214 | (buffer nil)) |
| 1215 | (multiple-value-bind (nick login host) | 1215 | (pcase-let ((`(,nick ,login ,host) |
| 1216 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1216 | (erc-parse-user (erc-response.sender parsed)))) |
| 1217 | ;; strip the stupid combined JOIN facility (IRC 2.9) | 1217 | ;; strip the stupid combined JOIN facility (IRC 2.9) |
| 1218 | (if (string-match "^\\(.*\\)?\^g.*$" chnl) | 1218 | (if (string-match "^\\(.*\\)?\^g.*$" chnl) |
| 1219 | (setq chnl (match-string 1 chnl))) | 1219 | (setq chnl (match-string 1 chnl))) |
| @@ -1249,12 +1249,12 @@ add things to `%s' instead." | |||
| 1249 | 1249 | ||
| 1250 | (define-erc-response-handler (KICK) | 1250 | (define-erc-response-handler (KICK) |
| 1251 | "Handle kick messages received from the server." nil | 1251 | "Handle kick messages received from the server." nil |
| 1252 | (let* ((ch (first (erc-response.command-args parsed))) | 1252 | (let* ((ch (nth 0 (erc-response.command-args parsed))) |
| 1253 | (tgt (second (erc-response.command-args parsed))) | 1253 | (tgt (nth 1 (erc-response.command-args parsed))) |
| 1254 | (reason (erc-trim-string (erc-response.contents parsed))) | 1254 | (reason (erc-trim-string (erc-response.contents parsed))) |
| 1255 | (buffer (erc-get-buffer ch proc))) | 1255 | (buffer (erc-get-buffer ch proc))) |
| 1256 | (multiple-value-bind (nick login host) | 1256 | (pcase-let ((`(,nick ,login ,host) |
| 1257 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1257 | (erc-parse-user (erc-response.sender parsed)))) |
| 1258 | (erc-remove-channel-member buffer tgt) | 1258 | (erc-remove-channel-member buffer tgt) |
| 1259 | (cond | 1259 | (cond |
| 1260 | ((string= tgt (erc-current-nick)) | 1260 | ((string= tgt (erc-current-nick)) |
| @@ -1277,11 +1277,11 @@ add things to `%s' instead." | |||
| 1277 | 1277 | ||
| 1278 | (define-erc-response-handler (MODE) | 1278 | (define-erc-response-handler (MODE) |
| 1279 | "Handle server mode changes." nil | 1279 | "Handle server mode changes." nil |
| 1280 | (let ((tgt (first (erc-response.command-args parsed))) | 1280 | (let ((tgt (car (erc-response.command-args parsed))) |
| 1281 | (mode (mapconcat 'identity (cdr (erc-response.command-args parsed)) | 1281 | (mode (mapconcat 'identity (cdr (erc-response.command-args parsed)) |
| 1282 | " "))) | 1282 | " "))) |
| 1283 | (multiple-value-bind (nick login host) | 1283 | (pcase-let ((`(,nick ,login ,host) |
| 1284 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1284 | (erc-parse-user (erc-response.sender parsed)))) |
| 1285 | (erc-log (format "MODE: %s -> %s: %s" nick tgt mode)) | 1285 | (erc-log (format "MODE: %s -> %s: %s" nick tgt mode)) |
| 1286 | ;; dirty hack | 1286 | ;; dirty hack |
| 1287 | (let ((buf (cond ((erc-channel-p tgt) | 1287 | (let ((buf (cond ((erc-channel-p tgt) |
| @@ -1305,8 +1305,8 @@ add things to `%s' instead." | |||
| 1305 | "Handle nick change messages." nil | 1305 | "Handle nick change messages." nil |
| 1306 | (let ((nn (erc-response.contents parsed)) | 1306 | (let ((nn (erc-response.contents parsed)) |
| 1307 | bufs) | 1307 | bufs) |
| 1308 | (multiple-value-bind (nick login host) | 1308 | (pcase-let ((`(,nick ,login ,host) |
| 1309 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1309 | (erc-parse-user (erc-response.sender parsed)))) |
| 1310 | (setq bufs (erc-buffer-list-with-nick nick proc)) | 1310 | (setq bufs (erc-buffer-list-with-nick nick proc)) |
| 1311 | (erc-log (format "NICK: %s -> %s" nick nn)) | 1311 | (erc-log (format "NICK: %s -> %s" nick nn)) |
| 1312 | ;; if we had a query with this user, make sure future messages will be | 1312 | ;; if we had a query with this user, make sure future messages will be |
| @@ -1340,11 +1340,11 @@ add things to `%s' instead." | |||
| 1340 | 1340 | ||
| 1341 | (define-erc-response-handler (PART) | 1341 | (define-erc-response-handler (PART) |
| 1342 | "Handle part messages." nil | 1342 | "Handle part messages." nil |
| 1343 | (let* ((chnl (first (erc-response.command-args parsed))) | 1343 | (let* ((chnl (car (erc-response.command-args parsed))) |
| 1344 | (reason (erc-trim-string (erc-response.contents parsed))) | 1344 | (reason (erc-trim-string (erc-response.contents parsed))) |
| 1345 | (buffer (erc-get-buffer chnl proc))) | 1345 | (buffer (erc-get-buffer chnl proc))) |
| 1346 | (multiple-value-bind (nick login host) | 1346 | (pcase-let ((`(,nick ,login ,host) |
| 1347 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1347 | (erc-parse-user (erc-response.sender parsed)))) |
| 1348 | (erc-remove-channel-member buffer nick) | 1348 | (erc-remove-channel-member buffer nick) |
| 1349 | (erc-display-message parsed 'notice buffer | 1349 | (erc-display-message parsed 'notice buffer |
| 1350 | 'PART ?n nick ?u login | 1350 | 'PART ?n nick ?u login |
| @@ -1361,7 +1361,7 @@ add things to `%s' instead." | |||
| 1361 | 1361 | ||
| 1362 | (define-erc-response-handler (PING) | 1362 | (define-erc-response-handler (PING) |
| 1363 | "Handle ping messages." nil | 1363 | "Handle ping messages." nil |
| 1364 | (let ((pinger (first (erc-response.command-args parsed)))) | 1364 | (let ((pinger (car (erc-response.command-args parsed)))) |
| 1365 | (erc-log (format "PING: %s" pinger)) | 1365 | (erc-log (format "PING: %s" pinger)) |
| 1366 | ;; ping response to the server MUST be forced, or you can lose big | 1366 | ;; ping response to the server MUST be forced, or you can lose big |
| 1367 | (erc-server-send (format "PONG :%s" pinger) t) | 1367 | (erc-server-send (format "PONG :%s" pinger) t) |
| @@ -1379,7 +1379,7 @@ add things to `%s' instead." | |||
| 1379 | (when erc-verbose-server-ping | 1379 | (when erc-verbose-server-ping |
| 1380 | (erc-display-message | 1380 | (erc-display-message |
| 1381 | parsed 'notice proc 'PONG | 1381 | parsed 'notice proc 'PONG |
| 1382 | ?h (first (erc-response.command-args parsed)) ?i erc-server-lag | 1382 | ?h (car (erc-response.command-args parsed)) ?i erc-server-lag |
| 1383 | ?s (if (/= erc-server-lag 1) "s" ""))) | 1383 | ?s (if (/= erc-server-lag 1) "s" ""))) |
| 1384 | (erc-update-mode-line)))) | 1384 | (erc-update-mode-line)))) |
| 1385 | 1385 | ||
| @@ -1451,8 +1451,8 @@ add things to `%s' instead." | |||
| 1451 | "Another user has quit IRC." nil | 1451 | "Another user has quit IRC." nil |
| 1452 | (let ((reason (erc-response.contents parsed)) | 1452 | (let ((reason (erc-response.contents parsed)) |
| 1453 | bufs) | 1453 | bufs) |
| 1454 | (multiple-value-bind (nick login host) | 1454 | (pcase-let ((`(,nick ,login ,host) |
| 1455 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1455 | (erc-parse-user (erc-response.sender parsed)))) |
| 1456 | (setq bufs (erc-buffer-list-with-nick nick proc)) | 1456 | (setq bufs (erc-buffer-list-with-nick nick proc)) |
| 1457 | (erc-remove-user nick) | 1457 | (erc-remove-user nick) |
| 1458 | (setq reason (erc-wash-quit-reason reason nick login host)) | 1458 | (setq reason (erc-wash-quit-reason reason nick login host)) |
| @@ -1462,12 +1462,12 @@ add things to `%s' instead." | |||
| 1462 | 1462 | ||
| 1463 | (define-erc-response-handler (TOPIC) | 1463 | (define-erc-response-handler (TOPIC) |
| 1464 | "The channel topic has changed." nil | 1464 | "The channel topic has changed." nil |
| 1465 | (let* ((ch (first (erc-response.command-args parsed))) | 1465 | (let* ((ch (car (erc-response.command-args parsed))) |
| 1466 | (topic (erc-trim-string (erc-response.contents parsed))) | 1466 | (topic (erc-trim-string (erc-response.contents parsed))) |
| 1467 | (time (format-time-string erc-server-timestamp-format | 1467 | (time (format-time-string erc-server-timestamp-format |
| 1468 | (current-time)))) | 1468 | (current-time)))) |
| 1469 | (multiple-value-bind (nick login host) | 1469 | (pcase-let ((`(,nick ,login ,host) |
| 1470 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1470 | (erc-parse-user (erc-response.sender parsed)))) |
| 1471 | (erc-update-channel-member ch nick nick nil nil nil host login) | 1471 | (erc-update-channel-member ch nick nick nil nil nil host login) |
| 1472 | (erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time)) | 1472 | (erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time)) |
| 1473 | (erc-display-message parsed 'notice (erc-get-buffer ch proc) | 1473 | (erc-display-message parsed 'notice (erc-get-buffer ch proc) |
| @@ -1477,8 +1477,8 @@ add things to `%s' instead." | |||
| 1477 | (define-erc-response-handler (WALLOPS) | 1477 | (define-erc-response-handler (WALLOPS) |
| 1478 | "Display a WALLOPS message." nil | 1478 | "Display a WALLOPS message." nil |
| 1479 | (let ((message (erc-response.contents parsed))) | 1479 | (let ((message (erc-response.contents parsed))) |
| 1480 | (multiple-value-bind (nick login host) | 1480 | (pcase-let ((`(,nick ,login ,host) |
| 1481 | (values-list (erc-parse-user (erc-response.sender parsed))) | 1481 | (erc-parse-user (erc-response.sender parsed)))) |
| 1482 | (erc-display-message | 1482 | (erc-display-message |
| 1483 | parsed 'notice nil | 1483 | parsed 'notice nil |
| 1484 | 'WALLOPS ?n nick ?m message)))) | 1484 | 'WALLOPS ?n nick ?m message)))) |
| @@ -1486,7 +1486,7 @@ add things to `%s' instead." | |||
| 1486 | (define-erc-response-handler (001) | 1486 | (define-erc-response-handler (001) |
| 1487 | "Set `erc-server-current-nick' to reflect server settings and display the welcome message." | 1487 | "Set `erc-server-current-nick' to reflect server settings and display the welcome message." |
| 1488 | nil | 1488 | nil |
| 1489 | (erc-set-current-nick (first (erc-response.command-args parsed))) | 1489 | (erc-set-current-nick (car (erc-response.command-args parsed))) |
| 1490 | (erc-update-mode-line) ; needed here? | 1490 | (erc-update-mode-line) ; needed here? |
| 1491 | (setq erc-nick-change-attempt-count 0) | 1491 | (setq erc-nick-change-attempt-count 0) |
| 1492 | (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) | 1492 | (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) |
| @@ -1507,16 +1507,16 @@ add things to `%s' instead." | |||
| 1507 | 1507 | ||
| 1508 | (define-erc-response-handler (004) | 1508 | (define-erc-response-handler (004) |
| 1509 | "Display the server's identification." nil | 1509 | "Display the server's identification." nil |
| 1510 | (multiple-value-bind (server-name server-version) | 1510 | (pcase-let ((`(,server-name ,server-version) |
| 1511 | (values-list (cdr (erc-response.command-args parsed))) | 1511 | (cdr (erc-response.command-args parsed)))) |
| 1512 | (setq erc-server-version server-version) | 1512 | (setq erc-server-version server-version) |
| 1513 | (setq erc-server-announced-name server-name) | 1513 | (setq erc-server-announced-name server-name) |
| 1514 | (erc-update-mode-line-buffer (process-buffer proc)) | 1514 | (erc-update-mode-line-buffer (process-buffer proc)) |
| 1515 | (erc-display-message | 1515 | (erc-display-message |
| 1516 | parsed 'notice proc | 1516 | parsed 'notice proc |
| 1517 | 's004 ?s server-name ?v server-version | 1517 | 's004 ?s server-name ?v server-version |
| 1518 | ?U (fourth (erc-response.command-args parsed)) | 1518 | ?U (nth 3 (erc-response.command-args parsed)) |
| 1519 | ?C (fifth (erc-response.command-args parsed))))) | 1519 | ?C (nth 4 (erc-response.command-args parsed))))) |
| 1520 | 1520 | ||
| 1521 | (define-erc-response-handler (005) | 1521 | (define-erc-response-handler (005) |
| 1522 | "Set the variable `erc-server-parameters' and display the received message. | 1522 | "Set the variable `erc-server-parameters' and display the received message. |
| @@ -1547,7 +1547,7 @@ A server may send more than one 005 message." | |||
| 1547 | 1547 | ||
| 1548 | (define-erc-response-handler (221) | 1548 | (define-erc-response-handler (221) |
| 1549 | "Display the current user modes." nil | 1549 | "Display the current user modes." nil |
| 1550 | (let* ((nick (first (erc-response.command-args parsed))) | 1550 | (let* ((nick (car (erc-response.command-args parsed))) |
| 1551 | (modes (mapconcat 'identity | 1551 | (modes (mapconcat 'identity |
| 1552 | (cdr (erc-response.command-args parsed)) " "))) | 1552 | (cdr (erc-response.command-args parsed)) " "))) |
| 1553 | (erc-set-modes nick modes) | 1553 | (erc-set-modes nick modes) |
| @@ -1576,8 +1576,8 @@ See `erc-display-server-message'." nil | |||
| 1576 | 1576 | ||
| 1577 | (define-erc-response-handler (275) | 1577 | (define-erc-response-handler (275) |
| 1578 | "Display secure connection message." nil | 1578 | "Display secure connection message." nil |
| 1579 | (multiple-value-bind (nick user message) | 1579 | (pcase-let ((`(,nick ,user ,message) |
| 1580 | (values-list (cdr (erc-response.command-args parsed))) | 1580 | (cdr (erc-response.command-args parsed)))) |
| 1581 | (erc-display-message | 1581 | (erc-display-message |
| 1582 | parsed 'notice 'active 's275 | 1582 | parsed 'notice 'active 's275 |
| 1583 | ?n nick | 1583 | ?n nick |
| @@ -1612,8 +1612,8 @@ See `erc-display-server-message'." nil | |||
| 1612 | 1612 | ||
| 1613 | (define-erc-response-handler (307) | 1613 | (define-erc-response-handler (307) |
| 1614 | "Display nick-identified message." nil | 1614 | "Display nick-identified message." nil |
| 1615 | (multiple-value-bind (nick user message) | 1615 | (pcase-let ((`(,nick ,user ,message) |
| 1616 | (values-list (cdr (erc-response.command-args parsed))) | 1616 | (cdr (erc-response.command-args parsed)))) |
| 1617 | (erc-display-message | 1617 | (erc-display-message |
| 1618 | parsed 'notice 'active 's307 | 1618 | parsed 'notice 'active 's307 |
| 1619 | ?n nick | 1619 | ?n nick |
| @@ -1624,8 +1624,8 @@ See `erc-display-server-message'." nil | |||
| 1624 | "WHOIS/WHOWAS notices." nil | 1624 | "WHOIS/WHOWAS notices." nil |
| 1625 | (let ((fname (erc-response.contents parsed)) | 1625 | (let ((fname (erc-response.contents parsed)) |
| 1626 | (catalog-entry (intern (format "s%s" (erc-response.command parsed))))) | 1626 | (catalog-entry (intern (format "s%s" (erc-response.command parsed))))) |
| 1627 | (multiple-value-bind (nick user host) | 1627 | (pcase-let ((`(,nick ,user ,host) |
| 1628 | (values-list (cdr (erc-response.command-args parsed))) | 1628 | (cdr (erc-response.command-args parsed)))) |
| 1629 | (erc-update-user-nick nick nick host nil fname user) | 1629 | (erc-update-user-nick nick nick host nil fname user) |
| 1630 | (erc-display-message | 1630 | (erc-display-message |
| 1631 | parsed 'notice 'active catalog-entry | 1631 | parsed 'notice 'active catalog-entry |
| @@ -1633,8 +1633,8 @@ See `erc-display-server-message'." nil | |||
| 1633 | 1633 | ||
| 1634 | (define-erc-response-handler (312) | 1634 | (define-erc-response-handler (312) |
| 1635 | "Server name response in WHOIS." nil | 1635 | "Server name response in WHOIS." nil |
| 1636 | (multiple-value-bind (nick server-host) | 1636 | (pcase-let ((`(,nick ,server-host)) |
| 1637 | (values-list (cdr (erc-response.command-args parsed))) | 1637 | (cdr (erc-response.command-args parsed))) |
| 1638 | (erc-display-message | 1638 | (erc-display-message |
| 1639 | parsed 'notice 'active 's312 | 1639 | parsed 'notice 'active 's312 |
| 1640 | ?n nick ?s server-host ?c (erc-response.contents parsed)))) | 1640 | ?n nick ?s server-host ?c (erc-response.contents parsed)))) |
| @@ -1655,8 +1655,8 @@ See `erc-display-server-message'." nil | |||
| 1655 | 1655 | ||
| 1656 | (define-erc-response-handler (317) | 1656 | (define-erc-response-handler (317) |
| 1657 | "IDLE notice." nil | 1657 | "IDLE notice." nil |
| 1658 | (multiple-value-bind (nick seconds-idle on-since time) | 1658 | (pcase-let ((`(,nick ,seconds-idle ,on-since ,time) |
| 1659 | (values-list (cdr (erc-response.command-args parsed))) | 1659 | (cdr (erc-response.command-args parsed)))) |
| 1660 | (setq time (when on-since | 1660 | (setq time (when on-since |
| 1661 | (format-time-string erc-server-timestamp-format | 1661 | (format-time-string erc-server-timestamp-format |
| 1662 | (erc-string-to-emacs-time on-since)))) | 1662 | (erc-string-to-emacs-time on-since)))) |
| @@ -1696,16 +1696,16 @@ See `erc-display-server-message'." nil | |||
| 1696 | (define-erc-response-handler (322) | 1696 | (define-erc-response-handler (322) |
| 1697 | "LIST notice." nil | 1697 | "LIST notice." nil |
| 1698 | (let ((topic (erc-response.contents parsed))) | 1698 | (let ((topic (erc-response.contents parsed))) |
| 1699 | (multiple-value-bind (channel num-users) | 1699 | (pcase-let ((`(,channel ,num-users) |
| 1700 | (values-list (cdr (erc-response.command-args parsed))) | 1700 | (cdr (erc-response.command-args parsed)))) |
| 1701 | (add-to-list 'erc-channel-list (list channel)) | 1701 | (add-to-list 'erc-channel-list (list channel)) |
| 1702 | (erc-update-channel-topic channel topic)))) | 1702 | (erc-update-channel-topic channel topic)))) |
| 1703 | 1703 | ||
| 1704 | (defun erc-server-322-message (proc parsed) | 1704 | (defun erc-server-322-message (proc parsed) |
| 1705 | "Display a message for the 322 event." | 1705 | "Display a message for the 322 event." |
| 1706 | (let ((topic (erc-response.contents parsed))) | 1706 | (let ((topic (erc-response.contents parsed))) |
| 1707 | (multiple-value-bind (channel num-users) | 1707 | (pcase-let ((`(,channel ,num-users) |
| 1708 | (values-list (cdr (erc-response.command-args parsed))) | 1708 | (cdr (erc-response.command-args parsed)))) |
| 1709 | (erc-display-message | 1709 | (erc-display-message |
| 1710 | parsed 'notice proc 's322 | 1710 | parsed 'notice proc 's322 |
| 1711 | ?c channel ?u num-users ?t (or topic ""))))) | 1711 | ?c channel ?u num-users ?t (or topic ""))))) |
| @@ -1732,7 +1732,7 @@ See `erc-display-server-message'." nil | |||
| 1732 | "Channel creation date." nil | 1732 | "Channel creation date." nil |
| 1733 | (let ((channel (second (erc-response.command-args parsed))) | 1733 | (let ((channel (second (erc-response.command-args parsed))) |
| 1734 | (time (erc-string-to-emacs-time | 1734 | (time (erc-string-to-emacs-time |
| 1735 | (third (erc-response.command-args parsed))))) | 1735 | (nth 2 (erc-response.command-args parsed))))) |
| 1736 | (erc-display-message | 1736 | (erc-display-message |
| 1737 | parsed 'notice (erc-get-buffer channel proc) | 1737 | parsed 'notice (erc-get-buffer channel proc) |
| 1738 | 's329 ?c channel ?t (format-time-string erc-server-timestamp-format | 1738 | 's329 ?c channel ?t (format-time-string erc-server-timestamp-format |
| @@ -1749,7 +1749,7 @@ See `erc-display-server-message'." nil | |||
| 1749 | ;; authmsg == (aref parsed 5) | 1749 | ;; authmsg == (aref parsed 5) |
| 1750 | ;; The guesses below are, well, just that. -- Lawrence 2004/05/10 | 1750 | ;; The guesses below are, well, just that. -- Lawrence 2004/05/10 |
| 1751 | (let ((nick (second (erc-response.command-args parsed))) | 1751 | (let ((nick (second (erc-response.command-args parsed))) |
| 1752 | (authaccount (third (erc-response.command-args parsed))) | 1752 | (authaccount (nth 2 (erc-response.command-args parsed))) |
| 1753 | (authmsg (erc-response.contents parsed))) | 1753 | (authmsg (erc-response.contents parsed))) |
| 1754 | (erc-display-message parsed 'notice 'active 's330 | 1754 | (erc-display-message parsed 'notice 'active 's330 |
| 1755 | ?n nick ?a authmsg ?i authaccount))) | 1755 | ?n nick ?a authmsg ?i authaccount))) |
| @@ -1771,8 +1771,8 @@ See `erc-display-server-message'." nil | |||
| 1771 | 1771 | ||
| 1772 | (define-erc-response-handler (333) | 1772 | (define-erc-response-handler (333) |
| 1773 | "Who set the topic, and when." nil | 1773 | "Who set the topic, and when." nil |
| 1774 | (multiple-value-bind (channel nick time) | 1774 | (pcase-let ((`(,channel ,nick ,time) |
| 1775 | (values-list (cdr (erc-response.command-args parsed))) | 1775 | (cdr (erc-response.command-args parsed)))) |
| 1776 | (setq time (format-time-string erc-server-timestamp-format | 1776 | (setq time (format-time-string erc-server-timestamp-format |
| 1777 | (erc-string-to-emacs-time time))) | 1777 | (erc-string-to-emacs-time time))) |
| 1778 | (erc-update-channel-topic channel | 1778 | (erc-update-channel-topic channel |
| @@ -1784,15 +1784,15 @@ See `erc-display-server-message'." nil | |||
| 1784 | (define-erc-response-handler (341) | 1784 | (define-erc-response-handler (341) |
| 1785 | "Let user know when an INVITE attempt has been sent successfully." | 1785 | "Let user know when an INVITE attempt has been sent successfully." |
| 1786 | nil | 1786 | nil |
| 1787 | (multiple-value-bind (nick channel) | 1787 | (pcase-let ((`(,nick ,channel) |
| 1788 | (values-list (cdr (erc-response.command-args parsed))) | 1788 | (cdr (erc-response.command-args parsed)))) |
| 1789 | (erc-display-message parsed 'notice (erc-get-buffer channel proc) | 1789 | (erc-display-message parsed 'notice (erc-get-buffer channel proc) |
| 1790 | 's341 ?n nick ?c channel))) | 1790 | 's341 ?n nick ?c channel))) |
| 1791 | 1791 | ||
| 1792 | (define-erc-response-handler (352) | 1792 | (define-erc-response-handler (352) |
| 1793 | "WHO notice." nil | 1793 | "WHO notice." nil |
| 1794 | (multiple-value-bind (channel user host server nick away-flag) | 1794 | (pcase-let ((`(,channel ,user ,host ,server ,nick ,away-flag) |
| 1795 | (values-list (cdr (erc-response.command-args parsed))) | 1795 | (cdr (erc-response.command-args parsed)))) |
| 1796 | (let ((full-name (erc-response.contents parsed)) | 1796 | (let ((full-name (erc-response.contents parsed)) |
| 1797 | hopcount) | 1797 | hopcount) |
| 1798 | (when (string-match "\\(^[0-9]+ \\)\\(.*\\)$" full-name) | 1798 | (when (string-match "\\(^[0-9]+ \\)\\(.*\\)$" full-name) |
| @@ -1806,7 +1806,7 @@ See `erc-display-server-message'." nil | |||
| 1806 | 1806 | ||
| 1807 | (define-erc-response-handler (353) | 1807 | (define-erc-response-handler (353) |
| 1808 | "NAMES notice." nil | 1808 | "NAMES notice." nil |
| 1809 | (let ((channel (third (erc-response.command-args parsed))) | 1809 | (let ((channel (nth 2 (erc-response.command-args parsed))) |
| 1810 | (users (erc-response.contents parsed))) | 1810 | (users (erc-response.contents parsed))) |
| 1811 | (erc-display-message parsed 'notice (or (erc-get-buffer channel proc) | 1811 | (erc-display-message parsed 'notice (or (erc-get-buffer channel proc) |
| 1812 | 'active) | 1812 | 'active) |
| @@ -1821,8 +1821,8 @@ See `erc-display-server-message'." nil | |||
| 1821 | 1821 | ||
| 1822 | (define-erc-response-handler (367) | 1822 | (define-erc-response-handler (367) |
| 1823 | "Channel ban list entries." nil | 1823 | "Channel ban list entries." nil |
| 1824 | (multiple-value-bind (channel banmask setter time) | 1824 | (pcase-let ((`(,channel ,banmask ,setter ,time) |
| 1825 | (values-list (cdr (erc-response.command-args parsed))) | 1825 | (cdr (erc-response.command-args parsed)))) |
| 1826 | ;; setter and time are not standard | 1826 | ;; setter and time are not standard |
| 1827 | (if setter | 1827 | (if setter |
| 1828 | (erc-display-message parsed 'notice 'active 's367-set-by | 1828 | (erc-display-message parsed 'notice 'active 's367-set-by |
| @@ -1845,8 +1845,8 @@ See `erc-display-server-message'." nil | |||
| 1845 | ;; FIXME: Yet more magic numbers in original code, I'm guessing this | 1845 | ;; FIXME: Yet more magic numbers in original code, I'm guessing this |
| 1846 | ;; command takes two arguments, and doesn't have any "contents". -- | 1846 | ;; command takes two arguments, and doesn't have any "contents". -- |
| 1847 | ;; Lawrence 2004/05/10 | 1847 | ;; Lawrence 2004/05/10 |
| 1848 | (multiple-value-bind (from to) | 1848 | (pcase-let ((`(,from ,to) |
| 1849 | (values-list (cdr (erc-response.command-args parsed))) | 1849 | (cdr (erc-response.command-args parsed)))) |
| 1850 | (erc-display-message parsed 'notice 'active | 1850 | (erc-display-message parsed 'notice 'active |
| 1851 | 's379 ?c from ?f to))) | 1851 | 's379 ?c from ?f to))) |
| 1852 | 1852 | ||
| @@ -1855,7 +1855,7 @@ See `erc-display-server-message'." nil | |||
| 1855 | (erc-display-message | 1855 | (erc-display-message |
| 1856 | parsed 'notice 'active | 1856 | parsed 'notice 'active |
| 1857 | 's391 ?s (second (erc-response.command-args parsed)) | 1857 | 's391 ?s (second (erc-response.command-args parsed)) |
| 1858 | ?t (third (erc-response.command-args parsed)))) | 1858 | ?t (nth 2 (erc-response.command-args parsed)))) |
| 1859 | 1859 | ||
| 1860 | (define-erc-response-handler (401) | 1860 | (define-erc-response-handler (401) |
| 1861 | "No such nick/channel." nil | 1861 | "No such nick/channel." nil |
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index 08b9c67f6c0..e8201f2ea43 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el | |||
| @@ -68,7 +68,6 @@ | |||
| 68 | ;;; Code: | 68 | ;;; Code: |
| 69 | 69 | ||
| 70 | (require 'erc) | 70 | (require 'erc) |
| 71 | (eval-when-compile (require 'cl)) | ||
| 72 | 71 | ||
| 73 | ;;; Customization: | 72 | ;;; Customization: |
| 74 | 73 | ||
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index ed8440315eb..e31416f0e1a 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el | |||
| @@ -54,9 +54,7 @@ | |||
| 54 | ;;; Code: | 54 | ;;; Code: |
| 55 | 55 | ||
| 56 | (require 'erc) | 56 | (require 'erc) |
| 57 | (eval-when-compile | 57 | (eval-when-compile (require 'pcomplete)) |
| 58 | (require 'cl) | ||
| 59 | (require 'pcomplete)) | ||
| 60 | 58 | ||
| 61 | ;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") | 59 | ;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") |
| 62 | (define-erc-module dcc nil | 60 | (define-erc-module dcc nil |
| @@ -277,7 +275,7 @@ Argument IP is the address as a string. The result is also a string." | |||
| 277 | (* (nth 1 ips) 65536.0) | 275 | (* (nth 1 ips) 65536.0) |
| 278 | (* (nth 2 ips) 256.0) | 276 | (* (nth 2 ips) 256.0) |
| 279 | (nth 3 ips)))) | 277 | (nth 3 ips)))) |
| 280 | (if (interactive-p) | 278 | (if (called-interactively-p 'interactive) |
| 281 | (message "%s is %.0f" ip res) | 279 | (message "%s is %.0f" ip res) |
| 282 | (format "%.0f" res))))) | 280 | (format "%.0f" res))))) |
| 283 | 281 | ||
| @@ -380,8 +378,8 @@ created subprocess, or nil." | |||
| 380 | (with-no-warnings ; obsolete since 23.1 | 378 | (with-no-warnings ; obsolete since 23.1 |
| 381 | (set-process-filter-multibyte process nil))))) | 379 | (set-process-filter-multibyte process nil))))) |
| 382 | (file-error | 380 | (file-error |
| 383 | (unless (and (string= "Cannot bind server socket" (cadr err)) | 381 | (unless (and (string= "Cannot bind server socket" (nth 1 err)) |
| 384 | (string= "address already in use" (caddr err))) | 382 | (string= "address already in use" (nth 2 err))) |
| 385 | (signal (car err) (cdr err))) | 383 | (signal (car err) (cdr err))) |
| 386 | (setq port (1+ port)) | 384 | (setq port (1+ port)) |
| 387 | (unless (< port upper) | 385 | (unless (< port upper) |
| @@ -434,38 +432,38 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." | |||
| 434 | (pcomplete-here (append '("chat" "close" "get" "list") | 432 | (pcomplete-here (append '("chat" "close" "get" "list") |
| 435 | (when (fboundp 'make-network-process) '("send")))) | 433 | (when (fboundp 'make-network-process) '("send")))) |
| 436 | (pcomplete-here | 434 | (pcomplete-here |
| 437 | (case (intern (downcase (pcomplete-arg 1))) | 435 | (pcase (intern (downcase (pcomplete-arg 1))) |
| 438 | (chat (mapcar (lambda (elt) (plist-get elt :nick)) | 436 | (`chat (mapcar (lambda (elt) (plist-get elt :nick)) |
| 437 | (erc-remove-if-not | ||
| 438 | #'(lambda (elt) | ||
| 439 | (eq (plist-get elt :type) 'CHAT)) | ||
| 440 | erc-dcc-list))) | ||
| 441 | (`close (erc-delete-dups | ||
| 442 | (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) | ||
| 443 | erc-dcc-list))) | ||
| 444 | (`get (mapcar #'erc-dcc-nick | ||
| 439 | (erc-remove-if-not | 445 | (erc-remove-if-not |
| 440 | #'(lambda (elt) | 446 | #'(lambda (elt) |
| 441 | (eq (plist-get elt :type) 'CHAT)) | 447 | (eq (plist-get elt :type) 'GET)) |
| 442 | erc-dcc-list))) | 448 | erc-dcc-list))) |
| 443 | (close (erc-delete-dups | 449 | (`send (pcomplete-erc-all-nicks)))) |
| 444 | (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) | ||
| 445 | erc-dcc-list))) | ||
| 446 | (get (mapcar #'erc-dcc-nick | ||
| 447 | (erc-remove-if-not | ||
| 448 | #'(lambda (elt) | ||
| 449 | (eq (plist-get elt :type) 'GET)) | ||
| 450 | erc-dcc-list))) | ||
| 451 | (send (pcomplete-erc-all-nicks)))) | ||
| 452 | (pcomplete-here | 450 | (pcomplete-here |
| 453 | (case (intern (downcase (pcomplete-arg 2))) | 451 | (pcase (intern (downcase (pcomplete-arg 2))) |
| 454 | (get (mapcar (lambda (elt) (plist-get elt :file)) | 452 | (`get (mapcar (lambda (elt) (plist-get elt :file)) |
| 455 | (erc-remove-if-not | 453 | (erc-remove-if-not |
| 456 | #'(lambda (elt) | 454 | #'(lambda (elt) |
| 457 | (and (eq (plist-get elt :type) 'GET) | 455 | (and (eq (plist-get elt :type) 'GET) |
| 458 | (erc-nick-equal-p (erc-extract-nick | 456 | (erc-nick-equal-p (erc-extract-nick |
| 459 | (plist-get elt :nick)) | 457 | (plist-get elt :nick)) |
| 460 | (pcomplete-arg 1)))) | 458 | (pcomplete-arg 1)))) |
| 461 | erc-dcc-list))) | 459 | erc-dcc-list))) |
| 462 | (close (mapcar #'erc-dcc-nick | 460 | (`close (mapcar #'erc-dcc-nick |
| 463 | (erc-remove-if-not | 461 | (erc-remove-if-not |
| 464 | #'(lambda (elt) | 462 | #'(lambda (elt) |
| 465 | (eq (plist-get elt :type) | 463 | (eq (plist-get elt :type) |
| 466 | (intern (upcase (pcomplete-arg 1))))) | 464 | (intern (upcase (pcomplete-arg 1))))) |
| 467 | erc-dcc-list))) | 465 | erc-dcc-list))) |
| 468 | (send (pcomplete-entries))))) | 466 | (`send (pcomplete-entries))))) |
| 469 | 467 | ||
| 470 | (defun erc-dcc-do-CHAT-command (proc &optional nick) | 468 | (defun erc-dcc-do-CHAT-command (proc &optional nick) |
| 471 | (when nick | 469 | (when nick |
| @@ -1248,7 +1246,7 @@ other client." | |||
| 1248 | 1246 | ||
| 1249 | (defun erc-dcc-no-such-nick (proc parsed) | 1247 | (defun erc-dcc-no-such-nick (proc parsed) |
| 1250 | "Detect and handle no-such-nick replies from the IRC server." | 1248 | "Detect and handle no-such-nick replies from the IRC server." |
| 1251 | (let* ((elt (erc-dcc-member :nick (second (erc-response.command-args parsed)) | 1249 | (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed)) |
| 1252 | :parent proc)) | 1250 | :parent proc)) |
| 1253 | (peer (plist-get elt :peer))) | 1251 | (peer (plist-get elt :peer))) |
| 1254 | (when (or (and (processp peer) (not (eq (process-status peer) 'open))) | 1252 | (when (or (and (processp peer) (not (eq (process-status peer) 'open))) |
diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 5e5d6c2c188..6bcc17e4bc0 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el | |||
| @@ -26,7 +26,6 @@ | |||
| 26 | ;;; Code: | 26 | ;;; Code: |
| 27 | 27 | ||
| 28 | (require 'erc) | 28 | (require 'erc) |
| 29 | (eval-when-compile (require 'cl)) | ||
| 30 | 29 | ||
| 31 | (defgroup erc-ezbounce nil | 30 | (defgroup erc-ezbounce nil |
| 32 | "Interface to the EZBounce IRC bouncer (a virtual IRC server)" | 31 | "Interface to the EZBounce IRC bouncer (a virtual IRC server)" |
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index ac6b311a0c4..e285cfb4ec5 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el | |||
| @@ -34,7 +34,6 @@ | |||
| 34 | 34 | ||
| 35 | (require 'erc) | 35 | (require 'erc) |
| 36 | (require 'auth-source) | 36 | (require 'auth-source) |
| 37 | (eval-when-compile (require 'cl)) | ||
| 38 | 37 | ||
| 39 | (defgroup erc-autojoin nil | 38 | (defgroup erc-autojoin nil |
| 40 | "Enable autojoining." | 39 | "Enable autojoining." |
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index b3f3f5865a1..1ff2951e09e 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el | |||
| @@ -93,9 +93,7 @@ | |||
| 93 | ;;; Code: | 93 | ;;; Code: |
| 94 | 94 | ||
| 95 | (require 'erc) | 95 | (require 'erc) |
| 96 | (eval-when-compile | 96 | (eval-when-compile (require 'erc-networks)) |
| 97 | (require 'erc-networks) | ||
| 98 | (require 'cl)) | ||
| 99 | 97 | ||
| 100 | (defgroup erc-log nil | 98 | (defgroup erc-log nil |
| 101 | "Logging facilities for ERC." | 99 | "Logging facilities for ERC." |
| @@ -429,7 +427,8 @@ You can save every individual message by putting this function on | |||
| 429 | file t 'nomessage)))) | 427 | file t 'nomessage)))) |
| 430 | (let ((coding-system-for-write coding-system)) | 428 | (let ((coding-system-for-write coding-system)) |
| 431 | (write-region start end file t 'nomessage)))) | 429 | (write-region start end file t 'nomessage)))) |
| 432 | (if (and erc-truncate-buffer-on-save (interactive-p)) | 430 | (if (and erc-truncate-buffer-on-save |
| 431 | (called-interactively-p 'interactive)) | ||
| 433 | (progn | 432 | (progn |
| 434 | (let ((inhibit-read-only t)) (erase-buffer)) | 433 | (let ((inhibit-read-only t)) (erase-buffer)) |
| 435 | (move-marker erc-last-saved-position (point-max)) | 434 | (move-marker erc-last-saved-position (point-max)) |
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 8dcdcb9e2e6..f1219427360 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el | |||
| @@ -35,7 +35,6 @@ | |||
| 35 | ;;; Code: | 35 | ;;; Code: |
| 36 | 36 | ||
| 37 | (require 'erc) | 37 | (require 'erc) |
| 38 | (eval-when-compile (require 'cl)) | ||
| 39 | 38 | ||
| 40 | ;; Customization: | 39 | ;; Customization: |
| 41 | 40 | ||
diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el index fc4aeb10c84..cbaf62b1a61 100644 --- a/lisp/erc/erc-netsplit.el +++ b/lisp/erc/erc-netsplit.el | |||
| @@ -31,7 +31,6 @@ | |||
| 31 | ;;; Code: | 31 | ;;; Code: |
| 32 | 32 | ||
| 33 | (require 'erc) | 33 | (require 'erc) |
| 34 | (eval-when-compile (require 'cl)) | ||
| 35 | 34 | ||
| 36 | (defgroup erc-netsplit nil | 35 | (defgroup erc-netsplit nil |
| 37 | "Netsplit detection tries to automatically figure when a | 36 | "Netsplit detection tries to automatically figure when a |
| @@ -107,7 +106,7 @@ join from that split has been detected or not.") | |||
| 107 | (dolist (elt erc-netsplit-list) | 106 | (dolist (elt erc-netsplit-list) |
| 108 | (if (member nick (nthcdr 3 elt)) | 107 | (if (member nick (nthcdr 3 elt)) |
| 109 | (progn | 108 | (progn |
| 110 | (if (not (caddr elt)) | 109 | (if (not (nth 2 elt)) |
| 111 | (progn | 110 | (progn |
| 112 | (erc-display-message | 111 | (erc-display-message |
| 113 | parsed 'notice (process-buffer proc) | 112 | parsed 'notice (process-buffer proc) |
| @@ -149,7 +148,7 @@ join from that split has been detected or not.") | |||
| 149 | ;; element for this netsplit exists already | 148 | ;; element for this netsplit exists already |
| 150 | (progn | 149 | (progn |
| 151 | (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass))) | 150 | (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass))) |
| 152 | (when (caddr ass) | 151 | (when (nth 2 ass) |
| 153 | ;; There was already a netjoin for this netsplit, it | 152 | ;; There was already a netjoin for this netsplit, it |
| 154 | ;; seems like the old one didn't get finished... | 153 | ;; seems like the old one didn't get finished... |
| 155 | (erc-display-message | 154 | (erc-display-message |
| @@ -194,7 +193,7 @@ join from that split has been detected or not.") | |||
| 194 | nil 'notice 'active | 193 | nil 'notice 'active |
| 195 | 'netsplit-wholeft ?s (car elt) | 194 | 'netsplit-wholeft ?s (car elt) |
| 196 | ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ") | 195 | ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ") |
| 197 | ?t (if (caddr elt) | 196 | ?t (if (nth 2 elt) |
| 198 | "(joining)" | 197 | "(joining)" |
| 199 | ""))))) | 198 | ""))))) |
| 200 | t) | 199 | t) |
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 89372555ccc..5089ff6b4ba 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el | |||
| @@ -40,7 +40,7 @@ | |||
| 40 | ;;; Code: | 40 | ;;; Code: |
| 41 | 41 | ||
| 42 | (require 'erc) | 42 | (require 'erc) |
| 43 | (eval-when-compile (require 'cl)) | 43 | (eval-when-compile (require 'cl-lib)) |
| 44 | 44 | ||
| 45 | ;; Variables | 45 | ;; Variables |
| 46 | 46 | ||
| @@ -729,10 +729,10 @@ search for a match in `erc-networks-alist'." | |||
| 729 | (or | 729 | (or |
| 730 | ;; Loop through `erc-networks-alist' looking for a match. | 730 | ;; Loop through `erc-networks-alist' looking for a match. |
| 731 | (let ((server (or erc-server-announced-name erc-session-server))) | 731 | (let ((server (or erc-server-announced-name erc-session-server))) |
| 732 | (loop for (name matcher) in erc-networks-alist | 732 | (cl-loop for (name matcher) in erc-networks-alist |
| 733 | when (and matcher | 733 | when (and matcher |
| 734 | (string-match (concat matcher "\\'") server)) | 734 | (string-match (concat matcher "\\'") server)) |
| 735 | do (return name))) | 735 | do (cl-return name))) |
| 736 | 'Unknown))) | 736 | 'Unknown))) |
| 737 | 737 | ||
| 738 | (defun erc-network () | 738 | (defun erc-network () |
| @@ -789,8 +789,8 @@ As an example: | |||
| 789 | (cond ((numberp p) | 789 | (cond ((numberp p) |
| 790 | (push p result)) | 790 | (push p result)) |
| 791 | ((listp p) | 791 | ((listp p) |
| 792 | (setq result (nconc (loop for i from (cadr p) downto (car p) | 792 | (setq result (nconc (cl-loop for i from (cadr p) downto (car p) |
| 793 | collect i) | 793 | collect i) |
| 794 | result))))) | 794 | result))))) |
| 795 | (nreverse result))) | 795 | (nreverse result))) |
| 796 | 796 | ||
diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index 0b5e99180d6..b9d7ff78cd8 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el | |||
| @@ -30,9 +30,7 @@ | |||
| 30 | 30 | ||
| 31 | (require 'erc) | 31 | (require 'erc) |
| 32 | (require 'erc-networks) | 32 | (require 'erc-networks) |
| 33 | (eval-when-compile | 33 | (eval-when-compile (require 'pcomplete)) |
| 34 | (require 'cl) | ||
| 35 | (require 'pcomplete)) | ||
| 36 | 34 | ||
| 37 | ;;;; Customizable variables | 35 | ;;;; Customizable variables |
| 38 | 36 | ||
diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index bb30fd90066..d6bb8019b15 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el | |||
| @@ -43,7 +43,6 @@ | |||
| 43 | (require 'erc) | 43 | (require 'erc) |
| 44 | (require 'erc-compat) | 44 | (require 'erc-compat) |
| 45 | (require 'time-date) | 45 | (require 'time-date) |
| 46 | (eval-when-compile (require 'cl)) | ||
| 47 | 46 | ||
| 48 | (defgroup erc-pcomplete nil | 47 | (defgroup erc-pcomplete nil |
| 49 | "Programmable completion for ERC" | 48 | "Programmable completion for ERC" |
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index b3b80a5f851..b75ad8e9517 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el | |||
| @@ -62,7 +62,7 @@ | |||
| 62 | 62 | ||
| 63 | (require 'erc) | 63 | (require 'erc) |
| 64 | (require 'erc-networks) | 64 | (require 'erc-networks) |
| 65 | (eval-when-compile (require 'cl)) | 65 | (eval-when-compile (require 'cl-lib)) |
| 66 | 66 | ||
| 67 | ;; Customization: | 67 | ;; Customization: |
| 68 | 68 | ||
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 4b98cf173be..22053945159 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el | |||
| @@ -38,7 +38,6 @@ | |||
| 38 | (require 'erc) | 38 | (require 'erc) |
| 39 | (require 'speedbar) | 39 | (require 'speedbar) |
| 40 | (condition-case nil (require 'dframe) (error nil)) | 40 | (condition-case nil (require 'dframe) (error nil)) |
| 41 | (eval-when-compile (require 'cl)) | ||
| 42 | 41 | ||
| 43 | ;;; Customization: | 42 | ;;; Customization: |
| 44 | 43 | ||
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index a204584b400..976d2a21030 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el | |||
| @@ -34,7 +34,7 @@ | |||
| 34 | ;; * Add extensibility so that custom functions can track | 34 | ;; * Add extensibility so that custom functions can track |
| 35 | ;; custom modification types. | 35 | ;; custom modification types. |
| 36 | 36 | ||
| 37 | (eval-when-compile (require 'cl)) | 37 | (eval-when-compile (require 'cl-lib)) |
| 38 | (require 'erc) | 38 | (require 'erc) |
| 39 | (require 'erc-compat) | 39 | (require 'erc-compat) |
| 40 | (require 'erc-match) | 40 | (require 'erc-match) |
| @@ -484,7 +484,7 @@ START is the minimum length of the name used." | |||
| 484 | 484 | ||
| 485 | ;;; Test: | 485 | ;;; Test: |
| 486 | 486 | ||
| 487 | (assert | 487 | (cl-assert |
| 488 | (and | 488 | (and |
| 489 | ;; verify examples from the doc strings | 489 | ;; verify examples from the doc strings |
| 490 | (equal (let ((erc-track-shorten-aggressively nil)) | 490 | (equal (let ((erc-track-shorten-aggressively nil)) |
| @@ -869,7 +869,7 @@ Use `erc-make-mode-line-buffer-name' to create buttons." | |||
| 869 | (setq erc-modified-channels-alist | 869 | (setq erc-modified-channels-alist |
| 870 | (delete (assq buffer erc-modified-channels-alist) | 870 | (delete (assq buffer erc-modified-channels-alist) |
| 871 | erc-modified-channels-alist)) | 871 | erc-modified-channels-alist)) |
| 872 | (when (interactive-p) | 872 | (when (called-interactively-p 'interactive) |
| 873 | (erc-modified-channels-display))) | 873 | (erc-modified-channels-display))) |
| 874 | 874 | ||
| 875 | (defun erc-track-find-face (faces) | 875 | (defun erc-track-find-face (faces) |
| @@ -980,7 +980,7 @@ is in `erc-mode'." | |||
| 980 | (add-to-list 'faces cur))) | 980 | (add-to-list 'faces cur))) |
| 981 | faces)) | 981 | faces)) |
| 982 | 982 | ||
| 983 | (assert | 983 | (cl-assert |
| 984 | (let ((str "is bold")) | 984 | (let ((str "is bold")) |
| 985 | (put-text-property 3 (length str) | 985 | (put-text-property 3 (length str) |
| 986 | 'face '(bold erc-current-nick-face) | 986 | 'face '(bold erc-current-nick-face) |
| @@ -1030,17 +1030,17 @@ relative to `erc-track-switch-direction'" | |||
| 1030 | (let ((dir erc-track-switch-direction) | 1030 | (let ((dir erc-track-switch-direction) |
| 1031 | offset) | 1031 | offset) |
| 1032 | (when (< arg 0) | 1032 | (when (< arg 0) |
| 1033 | (setq dir (case dir | 1033 | (setq dir (pcase dir |
| 1034 | (oldest 'newest) | 1034 | (`oldest 'newest) |
| 1035 | (newest 'oldest) | 1035 | (`newest 'oldest) |
| 1036 | (mostactive 'leastactive) | 1036 | (`mostactive 'leastactive) |
| 1037 | (leastactive 'mostactive) | 1037 | (`leastactive 'mostactive) |
| 1038 | (importance 'oldest))) | 1038 | (`importance 'oldest))) |
| 1039 | (setq arg (- arg))) | 1039 | (setq arg (- arg))) |
| 1040 | (setq offset (case dir | 1040 | (setq offset (pcase dir |
| 1041 | ((oldest leastactive) | 1041 | ((or `oldest `leastactive) |
| 1042 | (- (length erc-modified-channels-alist) arg)) | 1042 | (- (length erc-modified-channels-alist) arg)) |
| 1043 | (t (1- arg)))) | 1043 | (_ (1- arg)))) |
| 1044 | ;; normalize out of range user input | 1044 | ;; normalize out of range user input |
| 1045 | (cond ((>= offset (length erc-modified-channels-alist)) | 1045 | (cond ((>= offset (length erc-modified-channels-alist)) |
| 1046 | (setq offset (1- (length erc-modified-channels-alist)))) | 1046 | (setq offset (1- (length erc-modified-channels-alist)))) |
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 7cb6fbb595b..cec9718e751 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el | |||
| @@ -67,7 +67,7 @@ | |||
| 67 | (defconst erc-version-string "Version 5.3" | 67 | (defconst erc-version-string "Version 5.3" |
| 68 | "ERC version. This is used by function `erc-version'.") | 68 | "ERC version. This is used by function `erc-version'.") |
| 69 | 69 | ||
| 70 | (eval-when-compile (require 'cl)) | 70 | (eval-when-compile (require 'cl-lib)) |
| 71 | (require 'font-lock) | 71 | (require 'font-lock) |
| 72 | (require 'pp) | 72 | (require 'pp) |
| 73 | (require 'thingatpt) | 73 | (require 'thingatpt) |
| @@ -369,7 +369,7 @@ If no server buffer exists, return nil." | |||
| 369 | (with-current-buffer ,buffer | 369 | (with-current-buffer ,buffer |
| 370 | ,@body))))) | 370 | ,@body))))) |
| 371 | 371 | ||
| 372 | (defstruct (erc-server-user (:type vector) :named) | 372 | (cl-defstruct (erc-server-user (:type vector) :named) |
| 373 | ;; User data | 373 | ;; User data |
| 374 | nickname host login full-name info | 374 | nickname host login full-name info |
| 375 | ;; Buffers | 375 | ;; Buffers |
| @@ -379,7 +379,7 @@ If no server buffer exists, return nil." | |||
| 379 | (buffers nil) | 379 | (buffers nil) |
| 380 | ) | 380 | ) |
| 381 | 381 | ||
| 382 | (defstruct (erc-channel-user (:type vector) :named) | 382 | (cl-defstruct (erc-channel-user (:type vector) :named) |
| 383 | op voice | 383 | op voice |
| 384 | ;; Last message time (in the form of the return value of | 384 | ;; Last message time (in the form of the return value of |
| 385 | ;; (current-time) | 385 | ;; (current-time) |
| @@ -1386,7 +1386,7 @@ If BUFFER is nil, the current buffer is used." | |||
| 1386 | t)) | 1386 | t)) |
| 1387 | (erc-server-send (format "ISON %s" nick)) | 1387 | (erc-server-send (format "ISON %s" nick)) |
| 1388 | (while (eq erc-online-p 'unknown) (accept-process-output)) | 1388 | (while (eq erc-online-p 'unknown) (accept-process-output)) |
| 1389 | (if (interactive-p) | 1389 | (if (called-interactively-p 'interactive) |
| 1390 | (message "%s is %sonline" | 1390 | (message "%s is %sonline" |
| 1391 | (or erc-online-p nick) | 1391 | (or erc-online-p nick) |
| 1392 | (if erc-online-p "" "not ")) | 1392 | (if erc-online-p "" "not ")) |
| @@ -2157,11 +2157,11 @@ functions in here get called with the parameters SERVER and NICK." | |||
| 2157 | (list :server server :port port :nick nick :password passwd))) | 2157 | (list :server server :port port :nick nick :password passwd))) |
| 2158 | 2158 | ||
| 2159 | ;;;###autoload | 2159 | ;;;###autoload |
| 2160 | (defun* erc (&key (server (erc-compute-server)) | 2160 | (cl-defun erc (&key (server (erc-compute-server)) |
| 2161 | (port (erc-compute-port)) | 2161 | (port (erc-compute-port)) |
| 2162 | (nick (erc-compute-nick)) | 2162 | (nick (erc-compute-nick)) |
| 2163 | password | 2163 | password |
| 2164 | (full-name (erc-compute-full-name))) | 2164 | (full-name (erc-compute-full-name))) |
| 2165 | "ERC is a powerful, modular, and extensible IRC client. | 2165 | "ERC is a powerful, modular, and extensible IRC client. |
| 2166 | This function is the main entry point for ERC. | 2166 | This function is the main entry point for ERC. |
| 2167 | 2167 | ||
| @@ -2383,24 +2383,24 @@ If STRING is nil, the function does nothing." | |||
| 2383 | (while list | 2383 | (while list |
| 2384 | (setq elt (car list)) | 2384 | (setq elt (car list)) |
| 2385 | (cond ((integerp elt) ; POSITION | 2385 | (cond ((integerp elt) ; POSITION |
| 2386 | (incf (car list) shift)) | 2386 | (cl-incf (car list) shift)) |
| 2387 | ((or (atom elt) ; nil, EXTENT | 2387 | ((or (atom elt) ; nil, EXTENT |
| 2388 | ;; (eq t (car elt)) ; (t . TIME) | 2388 | ;; (eq t (car elt)) ; (t . TIME) |
| 2389 | (markerp (car elt))) ; (MARKER . DISTANCE) | 2389 | (markerp (car elt))) ; (MARKER . DISTANCE) |
| 2390 | nil) | 2390 | nil) |
| 2391 | ((integerp (car elt)) ; (BEGIN . END) | 2391 | ((integerp (car elt)) ; (BEGIN . END) |
| 2392 | (incf (car elt) shift) | 2392 | (cl-incf (car elt) shift) |
| 2393 | (incf (cdr elt) shift)) | 2393 | (cl-incf (cdr elt) shift)) |
| 2394 | ((stringp (car elt)) ; (TEXT . POSITION) | 2394 | ((stringp (car elt)) ; (TEXT . POSITION) |
| 2395 | (incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) | 2395 | (cl-incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) |
| 2396 | ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) | 2396 | ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) |
| 2397 | (let ((cons (nthcdr 3 elt))) | 2397 | (let ((cons (nthcdr 3 elt))) |
| 2398 | (incf (car cons) shift) | 2398 | (cl-incf (car cons) shift) |
| 2399 | (incf (cdr cons) shift))) | 2399 | (cl-incf (cdr cons) shift))) |
| 2400 | ((and (featurep 'xemacs) | 2400 | ((and (featurep 'xemacs) |
| 2401 | (extentp (car elt))) ; (EXTENT START END) | 2401 | (extentp (car elt))) ; (EXTENT START END) |
| 2402 | (incf (nth 1 elt) shift) | 2402 | (cl-incf (nth 1 elt) shift) |
| 2403 | (incf (nth 2 elt) shift))) | 2403 | (cl-incf (nth 2 elt) shift))) |
| 2404 | (setq list (cdr list)))))) | 2404 | (setq list (cdr list)))))) |
| 2405 | 2405 | ||
| 2406 | (defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*" | 2406 | (defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*" |
| @@ -2477,6 +2477,13 @@ purposes." | |||
| 2477 | :group 'erc-lurker | 2477 | :group 'erc-lurker |
| 2478 | :type 'boolean) | 2478 | :type 'boolean) |
| 2479 | 2479 | ||
| 2480 | (defcustom erc-lurker-ignore-chars "`_" | ||
| 2481 | "Characters at the end of a nick to strip for activity tracking purposes. | ||
| 2482 | |||
| 2483 | See also `erc-lurker-trim-nicks'." | ||
| 2484 | :group 'erc-lurker | ||
| 2485 | :type 'string) | ||
| 2486 | |||
| 2480 | (defun erc-lurker-maybe-trim (nick) | 2487 | (defun erc-lurker-maybe-trim (nick) |
| 2481 | "Maybe trim trailing `erc-lurker-ignore-chars' from NICK. | 2488 | "Maybe trim trailing `erc-lurker-ignore-chars' from NICK. |
| 2482 | 2489 | ||
| @@ -2491,13 +2498,6 @@ non-nil." | |||
| 2491 | "" nick) | 2498 | "" nick) |
| 2492 | nick)) | 2499 | nick)) |
| 2493 | 2500 | ||
| 2494 | (defcustom erc-lurker-ignore-chars "`_" | ||
| 2495 | "Characters at the end of a nick to strip for activity tracking purposes. | ||
| 2496 | |||
| 2497 | See also `erc-lurker-trim-nicks'." | ||
| 2498 | :group 'erc-lurker | ||
| 2499 | :type 'string) | ||
| 2500 | |||
| 2501 | (defcustom erc-lurker-hide-list nil | 2501 | (defcustom erc-lurker-hide-list nil |
| 2502 | "List of IRC type messages to hide when sent by lurkers. | 2502 | "List of IRC type messages to hide when sent by lurkers. |
| 2503 | 2503 | ||
| @@ -2580,7 +2580,8 @@ updates of `erc-lurker-state'." | |||
| 2580 | (server | 2580 | (server |
| 2581 | (erc-canonicalize-server-name erc-server-announced-name))) | 2581 | (erc-canonicalize-server-name erc-server-announced-name))) |
| 2582 | (when (equal command "PRIVMSG") | 2582 | (when (equal command "PRIVMSG") |
| 2583 | (when (>= (incf erc-lurker-cleanup-count) erc-lurker-cleanup-interval) | 2583 | (when (>= (cl-incf erc-lurker-cleanup-count) |
| 2584 | erc-lurker-cleanup-interval) | ||
| 2584 | (setq erc-lurker-cleanup-count 0) | 2585 | (setq erc-lurker-cleanup-count 0) |
| 2585 | (erc-lurker-cleanup)) | 2586 | (erc-lurker-cleanup)) |
| 2586 | (unless (gethash server erc-lurker-state) | 2587 | (unless (gethash server erc-lurker-state) |
| @@ -2605,6 +2606,17 @@ server within `erc-lurker-threshold-time'. See also | |||
| 2605 | (time-subtract (current-time) last-PRIVMSG-time)) | 2606 | (time-subtract (current-time) last-PRIVMSG-time)) |
| 2606 | erc-lurker-threshold-time)))) | 2607 | erc-lurker-threshold-time)))) |
| 2607 | 2608 | ||
| 2609 | (defcustom erc-common-server-suffixes | ||
| 2610 | '(("openprojects.net$" . "OPN") | ||
| 2611 | ("freenode.net$" . "freenode") | ||
| 2612 | ("oftc.net$" . "OFTC")) | ||
| 2613 | "Alist of common server name suffixes. | ||
| 2614 | This variable is used in mode-line display to save screen | ||
| 2615 | real estate. Set it to nil if you want to avoid changing | ||
| 2616 | displayed hostnames." | ||
| 2617 | :group 'erc-mode-line-and-header | ||
| 2618 | :type 'alist) | ||
| 2619 | |||
| 2608 | (defun erc-canonicalize-server-name (server) | 2620 | (defun erc-canonicalize-server-name (server) |
| 2609 | "Returns the canonical network name for SERVER if any, | 2621 | "Returns the canonical network name for SERVER if any, |
| 2610 | otherwise `erc-server-announced-name'. SERVER is matched against | 2622 | otherwise `erc-server-announced-name'. SERVER is matched against |
| @@ -3115,37 +3127,37 @@ If SERVER is non-nil, use that, rather than the current server." | |||
| 3115 | (add-to-list 'symlist | 3127 | (add-to-list 'symlist |
| 3116 | (cons (erc-once-with-server-event | 3128 | (cons (erc-once-with-server-event |
| 3117 | 311 `(string= ,nick | 3129 | 311 `(string= ,nick |
| 3118 | (second | 3130 | (nth 1 |
| 3119 | (erc-response.command-args parsed)))) | 3131 | (erc-response.command-args parsed)))) |
| 3120 | 'erc-server-311-functions)) | 3132 | 'erc-server-311-functions)) |
| 3121 | (add-to-list 'symlist | 3133 | (add-to-list 'symlist |
| 3122 | (cons (erc-once-with-server-event | 3134 | (cons (erc-once-with-server-event |
| 3123 | 312 `(string= ,nick | 3135 | 312 `(string= ,nick |
| 3124 | (second | 3136 | (nth 1 |
| 3125 | (erc-response.command-args parsed)))) | 3137 | (erc-response.command-args parsed)))) |
| 3126 | 'erc-server-312-functions)) | 3138 | 'erc-server-312-functions)) |
| 3127 | (add-to-list 'symlist | 3139 | (add-to-list 'symlist |
| 3128 | (cons (erc-once-with-server-event | 3140 | (cons (erc-once-with-server-event |
| 3129 | 318 `(string= ,nick | 3141 | 318 `(string= ,nick |
| 3130 | (second | 3142 | (nth 1 |
| 3131 | (erc-response.command-args parsed)))) | 3143 | (erc-response.command-args parsed)))) |
| 3132 | 'erc-server-318-functions)) | 3144 | 'erc-server-318-functions)) |
| 3133 | (add-to-list 'symlist | 3145 | (add-to-list 'symlist |
| 3134 | (cons (erc-once-with-server-event | 3146 | (cons (erc-once-with-server-event |
| 3135 | 319 `(string= ,nick | 3147 | 319 `(string= ,nick |
| 3136 | (second | 3148 | (nth 1 |
| 3137 | (erc-response.command-args parsed)))) | 3149 | (erc-response.command-args parsed)))) |
| 3138 | 'erc-server-319-functions)) | 3150 | 'erc-server-319-functions)) |
| 3139 | (add-to-list 'symlist | 3151 | (add-to-list 'symlist |
| 3140 | (cons (erc-once-with-server-event | 3152 | (cons (erc-once-with-server-event |
| 3141 | 320 `(string= ,nick | 3153 | 320 `(string= ,nick |
| 3142 | (second | 3154 | (nth 1 |
| 3143 | (erc-response.command-args parsed)))) | 3155 | (erc-response.command-args parsed)))) |
| 3144 | 'erc-server-320-functions)) | 3156 | 'erc-server-320-functions)) |
| 3145 | (add-to-list 'symlist | 3157 | (add-to-list 'symlist |
| 3146 | (cons (erc-once-with-server-event | 3158 | (cons (erc-once-with-server-event |
| 3147 | 330 `(string= ,nick | 3159 | 330 `(string= ,nick |
| 3148 | (second | 3160 | (nth 1 |
| 3149 | (erc-response.command-args parsed)))) | 3161 | (erc-response.command-args parsed)))) |
| 3150 | 'erc-server-330-functions)) | 3162 | 'erc-server-330-functions)) |
| 3151 | (add-to-list 'symlist | 3163 | (add-to-list 'symlist |
| @@ -4328,8 +4340,8 @@ See also: `erc-echo-notice-in-user-buffers', | |||
| 4328 | 4340 | ||
| 4329 | (defun erc-banlist-store (proc parsed) | 4341 | (defun erc-banlist-store (proc parsed) |
| 4330 | "Record ban entries for a channel." | 4342 | "Record ban entries for a channel." |
| 4331 | (multiple-value-bind (channel mask whoset) | 4343 | (pcase-let ((`(,channel ,mask ,whoset) |
| 4332 | (values-list (cdr (erc-response.command-args parsed))) | 4344 | (cdr (erc-response.command-args parsed)))) |
| 4333 | ;; Determine to which buffer the message corresponds | 4345 | ;; Determine to which buffer the message corresponds |
| 4334 | (let ((buffer (erc-get-buffer channel proc))) | 4346 | (let ((buffer (erc-get-buffer channel proc))) |
| 4335 | (with-current-buffer buffer | 4347 | (with-current-buffer buffer |
| @@ -4340,7 +4352,7 @@ See also: `erc-echo-notice-in-user-buffers', | |||
| 4340 | 4352 | ||
| 4341 | (defun erc-banlist-finished (proc parsed) | 4353 | (defun erc-banlist-finished (proc parsed) |
| 4342 | "Record that we have received the banlist." | 4354 | "Record that we have received the banlist." |
| 4343 | (let* ((channel (second (erc-response.command-args parsed))) | 4355 | (let* ((channel (nth 1 (erc-response.command-args parsed))) |
| 4344 | (buffer (erc-get-buffer channel proc))) | 4356 | (buffer (erc-get-buffer channel proc))) |
| 4345 | (with-current-buffer buffer | 4357 | (with-current-buffer buffer |
| 4346 | (put 'erc-channel-banlist 'received-from-server t))) | 4358 | (put 'erc-channel-banlist 'received-from-server t))) |
| @@ -4349,7 +4361,7 @@ See also: `erc-echo-notice-in-user-buffers', | |||
| 4349 | (defun erc-banlist-update (proc parsed) | 4361 | (defun erc-banlist-update (proc parsed) |
| 4350 | "Check MODE commands for bans and update the banlist appropriately." | 4362 | "Check MODE commands for bans and update the banlist appropriately." |
| 4351 | ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11 | 4363 | ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11 |
| 4352 | (let* ((tgt (first (erc-response.command-args parsed))) | 4364 | (let* ((tgt (car (erc-response.command-args parsed))) |
| 4353 | (mode (erc-response.contents parsed)) | 4365 | (mode (erc-response.contents parsed)) |
| 4354 | (whoset (erc-response.sender parsed)) | 4366 | (whoset (erc-response.sender parsed)) |
| 4355 | (buffer (erc-get-buffer tgt proc))) | 4367 | (buffer (erc-get-buffer tgt proc))) |
| @@ -6000,7 +6012,7 @@ entry of `channel-members'." | |||
| 6000 | (if cuser | 6012 | (if cuser |
| 6001 | (setq op (erc-channel-user-op cuser) | 6013 | (setq op (erc-channel-user-op cuser) |
| 6002 | voice (erc-channel-user-voice cuser))) | 6014 | voice (erc-channel-user-voice cuser))) |
| 6003 | (if (interactive-p) | 6015 | (if (called-interactively-p 'interactive) |
| 6004 | (message "%s is %s@%s%s%s" | 6016 | (message "%s is %s@%s%s%s" |
| 6005 | nick login host | 6017 | nick login host |
| 6006 | (if full-name (format " (%s)" full-name) "") | 6018 | (if full-name (format " (%s)" full-name) "") |
| @@ -6088,17 +6100,6 @@ Otherwise, use the `erc-header-line' face." | |||
| 6088 | :group 'erc-paranoia | 6100 | :group 'erc-paranoia |
| 6089 | :type 'boolean) | 6101 | :type 'boolean) |
| 6090 | 6102 | ||
| 6091 | (defcustom erc-common-server-suffixes | ||
| 6092 | '(("openprojects.net$" . "OPN") | ||
| 6093 | ("freenode.net$" . "freenode") | ||
| 6094 | ("oftc.net$" . "OFTC")) | ||
| 6095 | "Alist of common server name suffixes. | ||
| 6096 | This variable is used in mode-line display to save screen | ||
| 6097 | real estate. Set it to nil if you want to avoid changing | ||
| 6098 | displayed hostnames." | ||
| 6099 | :group 'erc-mode-line-and-header | ||
| 6100 | :type 'alist) | ||
| 6101 | |||
| 6102 | (defcustom erc-mode-line-away-status-format | 6103 | (defcustom erc-mode-line-away-status-format |
| 6103 | "(AWAY since %a %b %d %H:%M) " | 6104 | "(AWAY since %a %b %d %H:%M) " |
| 6104 | "When you're away on a server, this is shown in the mode line. | 6105 | "When you're away on a server, this is shown in the mode line. |
| @@ -6302,7 +6303,7 @@ If optional argument HERE is non-nil, insert version number at point." | |||
| 6302 | (format "ERC %s (GNU Emacs %s)" erc-version-string emacs-version))) | 6303 | (format "ERC %s (GNU Emacs %s)" erc-version-string emacs-version))) |
| 6303 | (if here | 6304 | (if here |
| 6304 | (insert version-string) | 6305 | (insert version-string) |
| 6305 | (if (interactive-p) | 6306 | (if (called-interactively-p 'interactive) |
| 6306 | (message "%s" version-string) | 6307 | (message "%s" version-string) |
| 6307 | version-string)))) | 6308 | version-string)))) |
| 6308 | 6309 | ||
| @@ -6322,7 +6323,7 @@ If optional argument HERE is non-nil, insert version number at point." | |||
| 6322 | ", "))) | 6323 | ", "))) |
| 6323 | (if here | 6324 | (if here |
| 6324 | (insert string) | 6325 | (insert string) |
| 6325 | (if (interactive-p) | 6326 | (if (called-interactively-p 'interactive) |
| 6326 | (message "%s" string) | 6327 | (message "%s" string) |
| 6327 | string)))) | 6328 | string)))) |
| 6328 | 6329 | ||
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index aa8aae2d245..b4c86e39e86 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el | |||
| @@ -297,6 +297,8 @@ to writing a completion function." | |||
| 297 | (define-key eshell-command-map [? ] 'pcomplete-expand) | 297 | (define-key eshell-command-map [? ] 'pcomplete-expand) |
| 298 | (define-key eshell-mode-map [tab] 'eshell-pcomplete) | 298 | (define-key eshell-mode-map [tab] 'eshell-pcomplete) |
| 299 | (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete) | 299 | (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete) |
| 300 | (add-hook 'completion-at-point-functions | ||
| 301 | #'pcomplete-completions-at-point nil t) | ||
| 300 | ;; jww (1999-10-19): Will this work on anything but X? | 302 | ;; jww (1999-10-19): Will this work on anything but X? |
| 301 | (if (featurep 'xemacs) | 303 | (if (featurep 'xemacs) |
| 302 | (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) | 304 | (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) |
| @@ -452,9 +454,9 @@ to writing a completion function." | |||
| 452 | (defun eshell-pcomplete () | 454 | (defun eshell-pcomplete () |
| 453 | "Eshell wrapper for `pcomplete'." | 455 | "Eshell wrapper for `pcomplete'." |
| 454 | (interactive) | 456 | (interactive) |
| 455 | (if eshell-cmpl-ignore-case | 457 | (condition-case nil |
| 456 | (pcomplete-expand-and-complete) ; hack workaround for bug#12838 | 458 | (pcomplete) |
| 457 | (pcomplete))) | 459 | (text-read-only (completion-at-point)))) ; Workaround for bug#12838. |
| 458 | 460 | ||
| 459 | (provide 'em-cmpl) | 461 | (provide 'em-cmpl) |
| 460 | 462 | ||
diff --git a/lisp/faces.el b/lisp/faces.el index 9e0ca962499..f8dc4783cbb 100644 --- a/lisp/faces.el +++ b/lisp/faces.el | |||
| @@ -487,44 +487,44 @@ with the `default' face (which is always completely specified)." | |||
| 487 | (defalias 'face-background-pixmap 'face-stipple) | 487 | (defalias 'face-background-pixmap 'face-stipple) |
| 488 | 488 | ||
| 489 | 489 | ||
| 490 | ;; FIXME all of these -p functions ignore inheritance (cf face-stipple). | 490 | (defun face-underline-p (face &optional frame inherit) |
| 491 | ;; Ie, a face that inherits from an underlined face but does not | ||
| 492 | ;; specify :underline will return nil. | ||
| 493 | ;; So these functions don't actually tell you anything about how the | ||
| 494 | ;; face will _appear_. So not very useful IMO. | ||
| 495 | (defun face-underline-p (face &optional frame) | ||
| 496 | "Return non-nil if FACE specifies a non-nil underlining. | 491 | "Return non-nil if FACE specifies a non-nil underlining. |
| 497 | If the optional argument FRAME is given, report on face FACE in that frame. | 492 | If the optional argument FRAME is given, report on face FACE in that frame. |
| 498 | If FRAME is t, report on the defaults for face FACE (for new frames). | 493 | If FRAME is t, report on the defaults for face FACE (for new frames). |
| 499 | If FRAME is omitted or nil, use the selected frame." | 494 | If FRAME is omitted or nil, use the selected frame. |
| 500 | (face-attribute-specified-or (face-attribute face :underline frame) nil)) | 495 | Optional argument INHERIT is passed to `face-attribute'." |
| 496 | (face-attribute-specified-or | ||
| 497 | (face-attribute face :underline frame inherit) nil)) | ||
| 501 | 498 | ||
| 502 | 499 | ||
| 503 | (defun face-inverse-video-p (face &optional frame) | 500 | (defun face-inverse-video-p (face &optional frame inherit) |
| 504 | "Return non-nil if FACE specifies a non-nil inverse-video. | 501 | "Return non-nil if FACE specifies a non-nil inverse-video. |
| 505 | If the optional argument FRAME is given, report on face FACE in that frame. | 502 | If the optional argument FRAME is given, report on face FACE in that frame. |
| 506 | If FRAME is t, report on the defaults for face FACE (for new frames). | 503 | If FRAME is t, report on the defaults for face FACE (for new frames). |
| 507 | If FRAME is omitted or nil, use the selected frame." | 504 | If FRAME is omitted or nil, use the selected frame. |
| 508 | (eq (face-attribute face :inverse-video frame) t)) | 505 | Optional argument INHERIT is passed to `face-attribute'." |
| 506 | (eq (face-attribute face :inverse-video frame inherit) t)) | ||
| 509 | 507 | ||
| 510 | 508 | ||
| 511 | (defun face-bold-p (face &optional frame) | 509 | (defun face-bold-p (face &optional frame inherit) |
| 512 | "Return non-nil if the font of FACE is bold on FRAME. | 510 | "Return non-nil if the font of FACE is bold on FRAME. |
| 513 | If the optional argument FRAME is given, report on face FACE in that frame. | 511 | If the optional argument FRAME is given, report on face FACE in that frame. |
| 514 | If FRAME is t, report on the defaults for face FACE (for new frames). | 512 | If FRAME is t, report on the defaults for face FACE (for new frames). |
| 515 | If FRAME is omitted or nil, use the selected frame. | 513 | If FRAME is omitted or nil, use the selected frame. |
| 514 | Optional argument INHERIT is passed to `face-attribute'. | ||
| 516 | Use `face-attribute' for finer control." | 515 | Use `face-attribute' for finer control." |
| 517 | (let ((bold (face-attribute face :weight frame))) | 516 | (let ((bold (face-attribute face :weight frame inherit))) |
| 518 | (memq bold '(semi-bold bold extra-bold ultra-bold)))) | 517 | (memq bold '(semi-bold bold extra-bold ultra-bold)))) |
| 519 | 518 | ||
| 520 | 519 | ||
| 521 | (defun face-italic-p (face &optional frame) | 520 | (defun face-italic-p (face &optional frame inherit) |
| 522 | "Return non-nil if the font of FACE is italic on FRAME. | 521 | "Return non-nil if the font of FACE is italic on FRAME. |
| 523 | If the optional argument FRAME is given, report on face FACE in that frame. | 522 | If the optional argument FRAME is given, report on face FACE in that frame. |
| 524 | If FRAME is t, report on the defaults for face FACE (for new frames). | 523 | If FRAME is t, report on the defaults for face FACE (for new frames). |
| 525 | If FRAME is omitted or nil, use the selected frame. | 524 | If FRAME is omitted or nil, use the selected frame. |
| 525 | Optional argument INHERIT is passed to `face-attribute'. | ||
| 526 | Use `face-attribute' for finer control." | 526 | Use `face-attribute' for finer control." |
| 527 | (let ((italic (face-attribute face :slant frame))) | 527 | (let ((italic (face-attribute face :slant frame inherit))) |
| 528 | (memq italic '(italic oblique)))) | 528 | (memq italic '(italic oblique)))) |
| 529 | 529 | ||
| 530 | 530 | ||
| @@ -862,7 +862,7 @@ Use `set-face-attribute' to ``unspecify'' underlining." | |||
| 862 | 'set-face-underline "24.3") | 862 | 'set-face-underline "24.3") |
| 863 | 863 | ||
| 864 | 864 | ||
| 865 | (defun set-face-inverse-video-p (face inverse-video-p &optional frame) | 865 | (defun set-face-inverse-video (face inverse-video-p &optional frame) |
| 866 | "Specify whether face FACE is in inverse video. | 866 | "Specify whether face FACE is in inverse video. |
| 867 | INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video. | 867 | INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video. |
| 868 | INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video. | 868 | INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video. |
| @@ -870,14 +870,13 @@ FRAME nil or not specified means change face on all frames. | |||
| 870 | Use `set-face-attribute' to ``unspecify'' the inverse video attribute." | 870 | Use `set-face-attribute' to ``unspecify'' the inverse video attribute." |
| 871 | (interactive | 871 | (interactive |
| 872 | (let ((list (read-face-and-attribute :inverse-video))) | 872 | (let ((list (read-face-and-attribute :inverse-video))) |
| 873 | (list (car list) (eq (car (cdr list)) t)))) | 873 | (list (car list) (if (cadr list) t)))) |
| 874 | (set-face-attribute face frame :inverse-video inverse-video-p)) | 874 | (set-face-attribute face frame :inverse-video inverse-video-p)) |
| 875 | 875 | ||
| 876 | (define-obsolete-function-alias 'set-face-inverse-video-p | ||
| 877 | 'set-face-inverse-video "24.4") | ||
| 876 | 878 | ||
| 877 | ;; The -p suffix is a hostage to fortune. What if we want to extend | 879 | (defun set-face-bold (face bold-p &optional frame) |
| 878 | ;; this to allow more than boolean options? Exactly this happened | ||
| 879 | ;; to set-face-underline-p. | ||
| 880 | (defun set-face-bold-p (face bold-p &optional frame) | ||
| 881 | "Specify whether face FACE is bold. | 880 | "Specify whether face FACE is bold. |
| 882 | BOLD-P non-nil means FACE should explicitly display bold. | 881 | BOLD-P non-nil means FACE should explicitly display bold. |
| 883 | BOLD-P nil means FACE should explicitly display non-bold. | 882 | BOLD-P nil means FACE should explicitly display non-bold. |
| @@ -887,8 +886,10 @@ Use `set-face-attribute' or `modify-face' for finer control." | |||
| 887 | (make-face-unbold face frame) | 886 | (make-face-unbold face frame) |
| 888 | (make-face-bold face frame))) | 887 | (make-face-bold face frame))) |
| 889 | 888 | ||
| 889 | (define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4") | ||
| 890 | |||
| 890 | 891 | ||
| 891 | (defun set-face-italic-p (face italic-p &optional frame) | 892 | (defun set-face-italic (face italic-p &optional frame) |
| 892 | "Specify whether face FACE is italic. | 893 | "Specify whether face FACE is italic. |
| 893 | ITALIC-P non-nil means FACE should explicitly display italic. | 894 | ITALIC-P non-nil means FACE should explicitly display italic. |
| 894 | ITALIC-P nil means FACE should explicitly display non-italic. | 895 | ITALIC-P nil means FACE should explicitly display non-italic. |
| @@ -898,6 +899,8 @@ Use `set-face-attribute' or `modify-face' for finer control." | |||
| 898 | (make-face-unitalic face frame) | 899 | (make-face-unitalic face frame) |
| 899 | (make-face-italic face frame))) | 900 | (make-face-italic face frame))) |
| 900 | 901 | ||
| 902 | (define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4") | ||
| 903 | |||
| 901 | 904 | ||
| 902 | (defalias 'set-face-background-pixmap 'set-face-stipple) | 905 | (defalias 'set-face-background-pixmap 'set-face-stipple) |
| 903 | 906 | ||
diff --git a/lisp/files.el b/lisp/files.el index 8e8a178caab..496f9bf8fa4 100644 --- a/lisp/files.el +++ b/lisp/files.el | |||
| @@ -730,7 +730,7 @@ The path separator is colon in GNU and GNU-like systems." | |||
| 730 | ;; This is a case where .elc makes a lot of sense. | 730 | ;; This is a case where .elc makes a lot of sense. |
| 731 | (interactive (list (let ((completion-ignored-extensions | 731 | (interactive (list (let ((completion-ignored-extensions |
| 732 | (remove ".elc" completion-ignored-extensions))) | 732 | (remove ".elc" completion-ignored-extensions))) |
| 733 | (read-file-name "Load file: ")))) | 733 | (read-file-name "Load file: " nil nil 'lambda)))) |
| 734 | (load (expand-file-name file) nil nil t)) | 734 | (load (expand-file-name file) nil nil t)) |
| 735 | 735 | ||
| 736 | (defun locate-file (filename path &optional suffixes predicate) | 736 | (defun locate-file (filename path &optional suffixes predicate) |
| @@ -3433,7 +3433,7 @@ DIR is the name of the directory. | |||
| 3433 | CLASS is the name of a variable class (a symbol). | 3433 | CLASS is the name of a variable class (a symbol). |
| 3434 | MTIME is the recorded modification time of the directory-local | 3434 | MTIME is the recorded modification time of the directory-local |
| 3435 | variables file associated with this entry. This time is a list | 3435 | variables file associated with this entry. This time is a list |
| 3436 | of two integers (the same format as `file-attributes'), and is | 3436 | of integers (the same format as `file-attributes'), and is |
| 3437 | used to test whether the cache entry is still valid. | 3437 | used to test whether the cache entry is still valid. |
| 3438 | Alternatively, MTIME can be nil, which means the entry is always | 3438 | Alternatively, MTIME can be nil, which means the entry is always |
| 3439 | considered valid.") | 3439 | considered valid.") |
diff --git a/lisp/find-cmd.el b/lisp/find-cmd.el index 6589bac0c6a..4cf5b85c81a 100644 --- a/lisp/find-cmd.el +++ b/lisp/find-cmd.el | |||
| @@ -63,6 +63,7 @@ | |||
| 63 | (cnewer . (1)) | 63 | (cnewer . (1)) |
| 64 | (ctime . (1)) | 64 | (ctime . (1)) |
| 65 | (empty . (0)) | 65 | (empty . (0)) |
| 66 | (executable . (0)) | ||
| 66 | (false . (0)) | 67 | (false . (0)) |
| 67 | (fstype . (1)) | 68 | (fstype . (1)) |
| 68 | (gid . (1)) | 69 | (gid . (1)) |
| @@ -70,37 +71,43 @@ | |||
| 70 | (ilname . (1)) | 71 | (ilname . (1)) |
| 71 | (iname . (1)) | 72 | (iname . (1)) |
| 72 | (inum . (1)) | 73 | (inum . (1)) |
| 73 | (iwholename . (1)) | 74 | (ipath . (1)) |
| 74 | (iregex . (1)) | 75 | (iregex . (1)) |
| 76 | (iwholename . (1)) | ||
| 75 | (links . (1)) | 77 | (links . (1)) |
| 76 | (lname . (1)) | 78 | (lname . (1)) |
| 77 | (mmin . (1)) | 79 | (mmin . (1)) |
| 78 | (mtime . (1)) | 80 | (mtime . (1)) |
| 79 | (name . (1)) | 81 | (name . (1)) |
| 80 | (newer . (1)) | 82 | (newer . (1)) |
| 81 | (nouser . (0)) | ||
| 82 | (nogroup . (0)) | 83 | (nogroup . (0)) |
| 84 | (nouser . (0)) | ||
| 83 | (path . (1)) | 85 | (path . (1)) |
| 84 | (perm . (0)) | 86 | (perm . (0)) |
| 87 | (readable . (0)) | ||
| 85 | (regex . (1)) | 88 | (regex . (1)) |
| 86 | (wholename . (1)) | 89 | (samefile . (1)) |
| 87 | (size . (1)) | 90 | (size . (1)) |
| 88 | (true . (0)) | 91 | (true . (0)) |
| 89 | (type . (1)) | 92 | (type . (1)) |
| 90 | (uid . (1)) | 93 | (uid . (1)) |
| 91 | (used . (1)) | 94 | (used . (1)) |
| 92 | (user . (1)) | 95 | (user . (1)) |
| 96 | (wholename . (1)) | ||
| 97 | (writable . (0)) | ||
| 93 | (xtype . (nil)) | 98 | (xtype . (nil)) |
| 94 | 99 | ||
| 95 | ;; normal options (always true) | 100 | ;; normal options (always true) |
| 101 | (daystart . (0)) | ||
| 96 | (depth . (0)) | 102 | (depth . (0)) |
| 97 | (maxdepth . (1)) | 103 | (maxdepth . (1)) |
| 98 | (mindepth . (1)) | 104 | (mindepth . (1)) |
| 99 | (mount . (0)) | 105 | (mount . (0)) |
| 100 | (noleaf . (0)) | 106 | (noleaf . (0)) |
| 101 | (xdev . (0)) | ||
| 102 | (ignore_readdir_race . (0)) | 107 | (ignore_readdir_race . (0)) |
| 103 | (noignore_readdir_race . (0)) | 108 | (noignore_readdir_race . (0)) |
| 109 | (regextype . (1)) | ||
| 110 | (xdev . (0)) | ||
| 104 | 111 | ||
| 105 | ;; actions | 112 | ;; actions |
| 106 | (delete . (0)) | 113 | (delete . (0)) |
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index dd493d383a3..d0dfd100f44 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog | |||
| @@ -1,3 +1,8 @@ | |||
| 1 | 2012-11-19 Katsumi Yamaoka <yamaoka@jpl.org> | ||
| 2 | |||
| 3 | * message.el (message-get-reply-headers): | ||
| 4 | Make sure the reply goes to the author if it is a wide reply. | ||
| 5 | |||
| 1 | 2012-11-16 Jan Tatarik <jan.tatarik@gmail.com> | 6 | 2012-11-16 Jan Tatarik <jan.tatarik@gmail.com> |
| 2 | 7 | ||
| 3 | * gnus-score.el (gnus-score-body): | 8 | * gnus-score.el (gnus-score-body): |
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 8905acb9d1f..5a2b4334582 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el | |||
| @@ -6730,11 +6730,16 @@ The function is called with one parameter, a cons cell ..." | |||
| 6730 | ", ")) | 6730 | ", ")) |
| 6731 | mct (message-fetch-field "mail-copies-to") | 6731 | mct (message-fetch-field "mail-copies-to") |
| 6732 | author (or (message-fetch-field "mail-reply-to") | 6732 | author (or (message-fetch-field "mail-reply-to") |
| 6733 | (message-fetch-field "reply-to") | 6733 | (message-fetch-field "reply-to")) |
| 6734 | (message-fetch-field "from") | ||
| 6735 | "") | ||
| 6736 | mft (and message-use-mail-followup-to | 6734 | mft (and message-use-mail-followup-to |
| 6737 | (message-fetch-field "mail-followup-to")))) | 6735 | (message-fetch-field "mail-followup-to"))) |
| 6736 | ;; Make sure this message goes to the author if this is a wide | ||
| 6737 | ;; reply, since Reply-To address may be a list address a mailing | ||
| 6738 | ;; list server added. | ||
| 6739 | (when (and wide author) | ||
| 6740 | (setq cc (concat author ", " cc))) | ||
| 6741 | (when (or wide (not author)) | ||
| 6742 | (setq author (or (message-fetch-field "from") "")))) | ||
| 6738 | 6743 | ||
| 6739 | ;; Handle special values of Mail-Copies-To. | 6744 | ;; Handle special values of Mail-Copies-To. |
| 6740 | (when mct | 6745 | (when mct |
diff --git a/lisp/json.el b/lisp/json.el index 8167bfe93f2..b1ea03120dc 100644 --- a/lisp/json.el +++ b/lisp/json.el | |||
| @@ -51,7 +51,6 @@ | |||
| 51 | 51 | ||
| 52 | ;;; Code: | 52 | ;;; Code: |
| 53 | 53 | ||
| 54 | (eval-when-compile (require 'cl)) | ||
| 55 | 54 | ||
| 56 | ;; Compatibility code | 55 | ;; Compatibility code |
| 57 | 56 | ||
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index ec321d00506..07da0b3dc16 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el | |||
| @@ -1270,9 +1270,10 @@ target of the symlink differ." | |||
| 1270 | res-uid | 1270 | res-uid |
| 1271 | ;; 3. File gid. | 1271 | ;; 3. File gid. |
| 1272 | res-gid | 1272 | res-gid |
| 1273 | ;; 4. Last access time, as a list of two integers. First | 1273 | ;; 4. Last access time, as a list of integers. Normally this |
| 1274 | ;; integer has high-order 16 bits of time, second has low 16 | 1274 | ;; would be in the same format as `current-time', but the |
| 1275 | ;; bits. | 1275 | ;; subseconds part is not currently implemented, and (0 0) |
| 1276 | ;; denotes an unknown time. | ||
| 1276 | ;; 5. Last modification time, likewise. | 1277 | ;; 5. Last modification time, likewise. |
| 1277 | ;; 6. Last status change time, likewise. | 1278 | ;; 6. Last status change time, likewise. |
| 1278 | '(0 0) '(0 0) '(0 0) ;CCC how to find out? | 1279 | '(0 0) '(0 0) '(0 0) ;CCC how to find out? |
| @@ -1980,6 +1981,7 @@ file names." | |||
| 1980 | (error "Unknown operation `%s', must be `copy' or `rename'" op)) | 1981 | (error "Unknown operation `%s', must be `copy' or `rename'" op)) |
| 1981 | (let ((t1 (tramp-tramp-file-p filename)) | 1982 | (let ((t1 (tramp-tramp-file-p filename)) |
| 1982 | (t2 (tramp-tramp-file-p newname)) | 1983 | (t2 (tramp-tramp-file-p newname)) |
| 1984 | (length (nth 7 (file-attributes (file-truename filename)))) | ||
| 1983 | (context (and preserve-selinux-context | 1985 | (context (and preserve-selinux-context |
| 1984 | (apply 'file-selinux-context (list filename)))) | 1986 | (apply 'file-selinux-context (list filename)))) |
| 1985 | pr tm) | 1987 | pr tm) |
| @@ -2009,8 +2011,9 @@ file names." | |||
| 2009 | ok-if-already-exists keep-date preserve-uid-gid)) | 2011 | ok-if-already-exists keep-date preserve-uid-gid)) |
| 2010 | 2012 | ||
| 2011 | ;; Try out-of-band operation. | 2013 | ;; Try out-of-band operation. |
| 2012 | ((tramp-method-out-of-band-p | 2014 | ((and |
| 2013 | v1 (nth 7 (file-attributes (file-truename filename)))) | 2015 | (tramp-method-out-of-band-p v1 length) |
| 2016 | (tramp-method-out-of-band-p v2 length)) | ||
| 2014 | (tramp-do-copy-or-rename-file-out-of-band | 2017 | (tramp-do-copy-or-rename-file-out-of-band |
| 2015 | op filename newname keep-date)) | 2018 | op filename newname keep-date)) |
| 2016 | 2019 | ||
| @@ -2038,8 +2041,7 @@ file names." | |||
| 2038 | 2041 | ||
| 2039 | ;; If the Tramp file has an out-of-band method, the | 2042 | ;; If the Tramp file has an out-of-band method, the |
| 2040 | ;; corresponding copy-program can be invoked. | 2043 | ;; corresponding copy-program can be invoked. |
| 2041 | ((tramp-method-out-of-band-p | 2044 | ((tramp-method-out-of-band-p v length) |
| 2042 | v (nth 7 (file-attributes (file-truename filename)))) | ||
| 2043 | (tramp-do-copy-or-rename-file-out-of-band | 2045 | (tramp-do-copy-or-rename-file-out-of-band |
| 2044 | op filename newname keep-date)) | 2046 | op filename newname keep-date)) |
| 2045 | 2047 | ||
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index caaae5d553e..d6f2177b03b 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el | |||
| @@ -3767,6 +3767,7 @@ Invokes `password-read' if available, `read-passwd' else." | |||
| 3767 | ("oct" . 10) ("nov" . 11) ("dec" . 12)) | 3767 | ("oct" . 10) ("nov" . 11) ("dec" . 12)) |
| 3768 | "Alist mapping month names to integers.") | 3768 | "Alist mapping month names to integers.") |
| 3769 | 3769 | ||
| 3770 | ;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? | ||
| 3770 | ;;;###tramp-autoload | 3771 | ;;;###tramp-autoload |
| 3771 | (defun tramp-time-less-p (t1 t2) | 3772 | (defun tramp-time-less-p (t1 t2) |
| 3772 | "Say whether time value T1 is less than time value T2." | 3773 | "Say whether time value T1 is less than time value T2." |
| @@ -3776,6 +3777,7 @@ Invokes `password-read' if available, `read-passwd' else." | |||
| 3776 | (and (= (car t1) (car t2)) | 3777 | (and (= (car t1) (car t2)) |
| 3777 | (< (nth 1 t1) (nth 1 t2))))) | 3778 | (< (nth 1 t1) (nth 1 t2))))) |
| 3778 | 3779 | ||
| 3780 | ;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? | ||
| 3779 | (defun tramp-time-subtract (t1 t2) | 3781 | (defun tramp-time-subtract (t1 t2) |
| 3780 | "Subtract two time values. | 3782 | "Subtract two time values. |
| 3781 | Return the difference in the format of a time value." | 3783 | Return the difference in the format of a time value." |
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 9e55976a8bd..13cf7356e7f 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el | |||
| @@ -833,7 +833,8 @@ this is `comint-dynamic-complete-functions'." | |||
| 833 | . ,(lambda (comps) | 833 | . ,(lambda (comps) |
| 834 | (sort comps pcomplete-compare-entry-function))) | 834 | (sort comps pcomplete-compare-entry-function))) |
| 835 | ,@(cdr (completion-file-name-table s p a))) | 835 | ,@(cdr (completion-file-name-table s p a))) |
| 836 | (let ((completion-ignored-extensions nil)) | 836 | (let ((completion-ignored-extensions nil) |
| 837 | (completion-ignore-case pcomplete-ignore-case)) | ||
| 837 | (completion-table-with-predicate | 838 | (completion-table-with-predicate |
| 838 | #'comint-completion-file-name-table pred 'strict s p a)))))) | 839 | #'comint-completion-file-name-table pred 'strict s p a)))))) |
| 839 | 840 | ||
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index a3ea4af4651..8af877c7843 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el | |||
| @@ -175,7 +175,7 @@ static unsigned char gamegrid_bits[] = { | |||
| 175 | 175 | ||
| 176 | (defun gamegrid-make-mono-tty-face () | 176 | (defun gamegrid-make-mono-tty-face () |
| 177 | (let ((face (make-face 'gamegrid-mono-tty-face))) | 177 | (let ((face (make-face 'gamegrid-mono-tty-face))) |
| 178 | (set-face-inverse-video-p face t) | 178 | (set-face-inverse-video face t) |
| 179 | face)) | 179 | face)) |
| 180 | 180 | ||
| 181 | (defun gamegrid-make-color-tty-face (color) | 181 | (defun gamegrid-make-color-tty-face (color) |
diff --git a/lisp/profiler.el b/lisp/profiler.el index 38c0c0b83a7..00b51ffe099 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el | |||
| @@ -404,7 +404,6 @@ RET: expand or collapse")) | |||
| 404 | 404 | ||
| 405 | (defvar profiler-report-mode-map | 405 | (defvar profiler-report-mode-map |
| 406 | (let ((map (make-sparse-keymap))) | 406 | (let ((map (make-sparse-keymap))) |
| 407 | ;; FIXME: Add menu. | ||
| 408 | (define-key map "n" 'profiler-report-next-entry) | 407 | (define-key map "n" 'profiler-report-next-entry) |
| 409 | (define-key map "p" 'profiler-report-previous-entry) | 408 | (define-key map "p" 'profiler-report-previous-entry) |
| 410 | ;; I find it annoying more than helpful to not be able to navigate | 409 | ;; I find it annoying more than helpful to not be able to navigate |
| @@ -424,8 +423,43 @@ RET: expand or collapse")) | |||
| 424 | (define-key map "D" 'profiler-report-descending-sort) | 423 | (define-key map "D" 'profiler-report-descending-sort) |
| 425 | (define-key map "=" 'profiler-report-compare-profile) | 424 | (define-key map "=" 'profiler-report-compare-profile) |
| 426 | (define-key map (kbd "C-x C-w") 'profiler-report-write-profile) | 425 | (define-key map (kbd "C-x C-w") 'profiler-report-write-profile) |
| 427 | (define-key map "q" 'quit-window) | 426 | (easy-menu-define profiler-report-menu map "Menu for Profiler Report mode." |
| 428 | map)) | 427 | '("Profiler" |
| 428 | ["Next Entry" profiler-report-next-entry :active t | ||
| 429 | :help "Move to next entry"] | ||
| 430 | ["Previous Entry" profiler-report-previous-entry :active t | ||
| 431 | :help "Move to previous entry"] | ||
| 432 | "--" | ||
| 433 | ["Toggle Entry" profiler-report-toggle-entry | ||
| 434 | :active (profiler-report-calltree-at-point) | ||
| 435 | :help "Expand or collapse the current entry"] | ||
| 436 | ["Find Entry" profiler-report-find-entry | ||
| 437 | ;; FIXME should deactivate if not on a known function. | ||
| 438 | :active (profiler-report-calltree-at-point) | ||
| 439 | :help "Find the definition of the current entry"] | ||
| 440 | ["Describe Entry" profiler-report-describe-entry | ||
| 441 | :active (profiler-report-calltree-at-point) | ||
| 442 | :help "Show the documentation of the current entry"] | ||
| 443 | "--" | ||
| 444 | ["Show Calltree" profiler-report-render-calltree | ||
| 445 | :active profiler-report-reversed | ||
| 446 | :help "Show calltree view"] | ||
| 447 | ["Show Reversed Calltree" profiler-report-render-reversed-calltree | ||
| 448 | :active (not profiler-report-reversed) | ||
| 449 | :help "Show reversed calltree view"] | ||
| 450 | ["Sort Ascending" profiler-report-ascending-sort | ||
| 451 | :active (not (eq profiler-report-order 'ascending)) | ||
| 452 | :help "Sort calltree view in ascending order"] | ||
| 453 | ["Sort Descending" profiler-report-descending-sort | ||
| 454 | :active (not (eq profiler-report-order 'descending)) | ||
| 455 | :help "Sort calltree view in descending order"] | ||
| 456 | "--" | ||
| 457 | ["Compare Profile..." profiler-report-compare-profile :active t | ||
| 458 | :help "Compare current profile with another"] | ||
| 459 | ["Write Profile..." profiler-report-write-profile :active t | ||
| 460 | :help "Write current profile to a file"])) | ||
| 461 | map) | ||
| 462 | "Keymap for `profiler-report-mode'.") | ||
| 429 | 463 | ||
| 430 | (defun profiler-report-make-buffer-name (profile) | 464 | (defun profiler-report-make-buffer-name (profile) |
| 431 | (format "*%s-Profiler-Report %s*" | 465 | (format "*%s-Profiler-Report %s*" |
| @@ -529,11 +563,15 @@ otherwise collapse." | |||
| 529 | (defun profiler-report-find-entry (&optional event) | 563 | (defun profiler-report-find-entry (&optional event) |
| 530 | "Find entry at point." | 564 | "Find entry at point." |
| 531 | (interactive (list last-nonmenu-event)) | 565 | (interactive (list last-nonmenu-event)) |
| 532 | (if event (posn-set-point (event-end event))) | 566 | (with-current-buffer |
| 533 | (let ((tree (profiler-report-calltree-at-point))) | 567 | (if event (window-buffer (posn-window (event-start event))) |
| 534 | (when tree | 568 | (current-buffer)) |
| 535 | (let ((entry (profiler-calltree-entry tree))) | 569 | (and event (setq event (event-end event)) |
| 536 | (find-function entry))))) | 570 | (posn-set-point event)) |
| 571 | (let ((tree (profiler-report-calltree-at-point))) | ||
| 572 | (when tree | ||
| 573 | (let ((entry (profiler-calltree-entry tree))) | ||
| 574 | (find-function entry)))))) | ||
| 537 | 575 | ||
| 538 | (defun profiler-report-describe-entry () | 576 | (defun profiler-report-describe-entry () |
| 539 | "Describe entry at point." | 577 | "Describe entry at point." |
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 949b0252bf1..550c5f5a129 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el | |||
| @@ -202,13 +202,12 @@ | |||
| 202 | 202 | ||
| 203 | (require 'ansi-color) | 203 | (require 'ansi-color) |
| 204 | (require 'comint) | 204 | (require 'comint) |
| 205 | (eval-when-compile (require 'cl-lib)) | ||
| 205 | 206 | ||
| 206 | (eval-when-compile | 207 | ;; Avoid compiler warnings |
| 207 | (require 'cl) | 208 | (defvar view-return-to-alist) |
| 208 | ;; Avoid compiler warnings | 209 | (defvar compilation-error-regexp-alist) |
| 209 | (defvar view-return-to-alist) | 210 | (defvar outline-heading-end-regexp) |
| 210 | (defvar compilation-error-regexp-alist) | ||
| 211 | (defvar outline-heading-end-regexp)) | ||
| 212 | 211 | ||
| 213 | (autoload 'comint-mode "comint") | 212 | (autoload 'comint-mode "comint") |
| 214 | 213 | ||
| @@ -364,12 +363,24 @@ This variant of `rx' supports common python named REGEXPS." | |||
| 364 | "Return non-nil if point is on TYPE using SYNTAX-PPSS. | 363 | "Return non-nil if point is on TYPE using SYNTAX-PPSS. |
| 365 | TYPE can be `comment', `string' or `paren'. It returns the start | 364 | TYPE can be `comment', `string' or `paren'. It returns the start |
| 366 | character address of the specified TYPE." | 365 | character address of the specified TYPE." |
| 366 | (declare (compiler-macro | ||
| 367 | (lambda (form) | ||
| 368 | (pcase type | ||
| 369 | (`'comment | ||
| 370 | `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) | ||
| 371 | (and (nth 4 ppss) (nth 8 ppss)))) | ||
| 372 | (`'string | ||
| 373 | `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) | ||
| 374 | (and (nth 3 ppss) (nth 8 ppss)))) | ||
| 375 | (`'paren | ||
| 376 | `(nth 1 (or ,syntax-ppss (syntax-ppss)))) | ||
| 377 | (_ form))))) | ||
| 367 | (let ((ppss (or syntax-ppss (syntax-ppss)))) | 378 | (let ((ppss (or syntax-ppss (syntax-ppss)))) |
| 368 | (case type | 379 | (pcase type |
| 369 | (comment (and (nth 4 ppss) (nth 8 ppss))) | 380 | (`comment (and (nth 4 ppss) (nth 8 ppss))) |
| 370 | (string (and (not (nth 4 ppss)) (nth 8 ppss))) | 381 | (`string (and (nth 3 ppss) (nth 8 ppss))) |
| 371 | (paren (nth 1 ppss)) | 382 | (`paren (nth 1 ppss)) |
| 372 | (t nil)))) | 383 | (_ nil)))) |
| 373 | 384 | ||
| 374 | (defun python-syntax-context-type (&optional syntax-ppss) | 385 | (defun python-syntax-context-type (&optional syntax-ppss) |
| 375 | "Return the context type using SYNTAX-PPSS. | 386 | "Return the context type using SYNTAX-PPSS. |
| @@ -481,8 +492,8 @@ The type returned can be `comment', `string' or `paren'." | |||
| 481 | (when (re-search-forward re limit t) | 492 | (when (re-search-forward re limit t) |
| 482 | (while (and (python-syntax-context 'paren) | 493 | (while (and (python-syntax-context 'paren) |
| 483 | (re-search-forward re limit t))) | 494 | (re-search-forward re limit t))) |
| 484 | (if (and (not (python-syntax-context 'paren)) | 495 | (if (not (or (python-syntax-context 'paren) |
| 485 | (not (equal (char-after (point-marker)) ?=))) | 496 | (equal (char-after (point-marker)) ?=))) |
| 486 | t | 497 | t |
| 487 | (set-match-data nil))))) | 498 | (set-match-data nil))))) |
| 488 | (1 font-lock-variable-name-face nil nil)) | 499 | (1 font-lock-variable-name-face nil nil)) |
| @@ -516,7 +527,7 @@ is used to limit the scan." | |||
| 516 | (while (and (< i 3) | 527 | (while (and (< i 3) |
| 517 | (or (not limit) (< (+ point i) limit)) | 528 | (or (not limit) (< (+ point i) limit)) |
| 518 | (eq (char-after (+ point i)) quote-char)) | 529 | (eq (char-after (+ point i)) quote-char)) |
| 519 | (incf i)) | 530 | (cl-incf i)) |
| 520 | i)) | 531 | i)) |
| 521 | 532 | ||
| 522 | (defun python-syntax-stringify () | 533 | (defun python-syntax-stringify () |
| @@ -723,17 +734,17 @@ START is the buffer position where the sexp starts." | |||
| 723 | (save-restriction | 734 | (save-restriction |
| 724 | (widen) | 735 | (widen) |
| 725 | (save-excursion | 736 | (save-excursion |
| 726 | (case context-status | 737 | (pcase context-status |
| 727 | ('no-indent 0) | 738 | (`no-indent 0) |
| 728 | ;; When point is after beginning of block just add one level | 739 | ;; When point is after beginning of block just add one level |
| 729 | ;; of indentation relative to the context-start | 740 | ;; of indentation relative to the context-start |
| 730 | ('after-beginning-of-block | 741 | (`after-beginning-of-block |
| 731 | (goto-char context-start) | 742 | (goto-char context-start) |
| 732 | (+ (current-indentation) python-indent-offset)) | 743 | (+ (current-indentation) python-indent-offset)) |
| 733 | ;; When after a simple line just use previous line | 744 | ;; When after a simple line just use previous line |
| 734 | ;; indentation, in the case current line starts with a | 745 | ;; indentation, in the case current line starts with a |
| 735 | ;; `python-indent-dedenters' de-indent one level. | 746 | ;; `python-indent-dedenters' de-indent one level. |
| 736 | ('after-line | 747 | (`after-line |
| 737 | (- | 748 | (- |
| 738 | (save-excursion | 749 | (save-excursion |
| 739 | (goto-char context-start) | 750 | (goto-char context-start) |
| @@ -746,11 +757,11 @@ START is the buffer position where the sexp starts." | |||
| 746 | ;; When inside of a string, do nothing. just use the current | 757 | ;; When inside of a string, do nothing. just use the current |
| 747 | ;; indentation. XXX: perhaps it would be a good idea to | 758 | ;; indentation. XXX: perhaps it would be a good idea to |
| 748 | ;; invoke standard text indentation here | 759 | ;; invoke standard text indentation here |
| 749 | ('inside-string | 760 | (`inside-string |
| 750 | (goto-char context-start) | 761 | (goto-char context-start) |
| 751 | (current-indentation)) | 762 | (current-indentation)) |
| 752 | ;; After backslash we have several possibilities. | 763 | ;; After backslash we have several possibilities. |
| 753 | ('after-backslash | 764 | (`after-backslash |
| 754 | (cond | 765 | (cond |
| 755 | ;; Check if current line is a dot continuation. For this | 766 | ;; Check if current line is a dot continuation. For this |
| 756 | ;; the current line must start with a dot and previous | 767 | ;; the current line must start with a dot and previous |
| @@ -816,7 +827,7 @@ START is the buffer position where the sexp starts." | |||
| 816 | (+ (current-indentation) python-indent-offset))))) | 827 | (+ (current-indentation) python-indent-offset))))) |
| 817 | ;; When inside a paren there's a need to handle nesting | 828 | ;; When inside a paren there's a need to handle nesting |
| 818 | ;; correctly | 829 | ;; correctly |
| 819 | ('inside-paren | 830 | (`inside-paren |
| 820 | (cond | 831 | (cond |
| 821 | ;; If current line closes the outermost open paren use the | 832 | ;; If current line closes the outermost open paren use the |
| 822 | ;; current indentation of the context-start line. | 833 | ;; current indentation of the context-start line. |
| @@ -2164,11 +2175,11 @@ INPUT." | |||
| 2164 | 'default) | 2175 | 'default) |
| 2165 | (t nil))) | 2176 | (t nil))) |
| 2166 | (completion-code | 2177 | (completion-code |
| 2167 | (case completion-context | 2178 | (pcase completion-context |
| 2168 | (pdb python-shell-completion-pdb-string-code) | 2179 | (`pdb python-shell-completion-pdb-string-code) |
| 2169 | (import python-shell-completion-module-string-code) | 2180 | (`import python-shell-completion-module-string-code) |
| 2170 | (default python-shell-completion-string-code) | 2181 | (`default python-shell-completion-string-code) |
| 2171 | (t nil))) | 2182 | (_ nil))) |
| 2172 | (input | 2183 | (input |
| 2173 | (if (eq completion-context 'import) | 2184 | (if (eq completion-context 'import) |
| 2174 | (replace-regexp-in-string "^[ \t]+" "" line) | 2185 | (replace-regexp-in-string "^[ \t]+" "" line) |
| @@ -2492,17 +2503,17 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." | |||
| 2492 | ;; Docstring styles may vary for oneliners and multi-liners. | 2503 | ;; Docstring styles may vary for oneliners and multi-liners. |
| 2493 | (> (count-matches "\n" str-start-pos str-end-pos) 0)) | 2504 | (> (count-matches "\n" str-start-pos str-end-pos) 0)) |
| 2494 | (delimiters-style | 2505 | (delimiters-style |
| 2495 | (case python-fill-docstring-style | 2506 | (pcase python-fill-docstring-style |
| 2496 | ;; delimiters-style is a cons cell with the form | 2507 | ;; delimiters-style is a cons cell with the form |
| 2497 | ;; (START-NEWLINES . END-NEWLINES). When any of the sexps | 2508 | ;; (START-NEWLINES . END-NEWLINES). When any of the sexps |
| 2498 | ;; is NIL means to not add any newlines for start or end | 2509 | ;; is NIL means to not add any newlines for start or end |
| 2499 | ;; of docstring. See `python-fill-docstring-style' for a | 2510 | ;; of docstring. See `python-fill-docstring-style' for a |
| 2500 | ;; graphic idea of each style. | 2511 | ;; graphic idea of each style. |
| 2501 | (django (cons 1 1)) | 2512 | (`django (cons 1 1)) |
| 2502 | (onetwo (and multi-line-p (cons 1 2))) | 2513 | (`onetwo (and multi-line-p (cons 1 2))) |
| 2503 | (pep-257 (and multi-line-p (cons nil 2))) | 2514 | (`pep-257 (and multi-line-p (cons nil 2))) |
| 2504 | (pep-257-nn (and multi-line-p (cons nil 1))) | 2515 | (`pep-257-nn (and multi-line-p (cons nil 1))) |
| 2505 | (symmetric (and multi-line-p (cons 1 1))))) | 2516 | (`symmetric (and multi-line-p (cons 1 1))))) |
| 2506 | (docstring-p (save-excursion | 2517 | (docstring-p (save-excursion |
| 2507 | ;; Consider docstrings those strings which | 2518 | ;; Consider docstrings those strings which |
| 2508 | ;; start on a line by themselves. | 2519 | ;; start on a line by themselves. |
| @@ -2703,7 +2714,7 @@ The skeleton will be bound to python-skeleton-NAME." | |||
| 2703 | (easy-menu-add-item | 2714 | (easy-menu-add-item |
| 2704 | nil '("Python" "Skeletons") | 2715 | nil '("Python" "Skeletons") |
| 2705 | `[,(format | 2716 | `[,(format |
| 2706 | "Insert %s" (caddr (split-string (symbol-name skeleton) "-"))) | 2717 | "Insert %s" (nth 2 (split-string (symbol-name skeleton) "-"))) |
| 2707 | ,skeleton t])))) | 2718 | ,skeleton t])))) |
| 2708 | 2719 | ||
| 2709 | ;;; FFAP | 2720 | ;;; FFAP |
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 64b87d9e436..d84d57cad22 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el | |||
| @@ -736,15 +736,15 @@ this variable is nil, that buffer is shown using | |||
| 736 | 736 | ||
| 737 | (defvar sql-imenu-generic-expression | 737 | (defvar sql-imenu-generic-expression |
| 738 | ;; Items are in reverse order because they are rendered in reverse. | 738 | ;; Items are in reverse order because they are rendered in reverse. |
| 739 | '(("Rules/Defaults" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(rule\\|default\\)\\s-+\\(\\w+\\)" 3) | 739 | '(("Rules/Defaults" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:rule\\|default\\)\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\s-+\\(\\w+\\)" 1) |
| 740 | ("Sequences" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*sequence\\s-+\\(\\w+\\)" 2) | 740 | ("Sequences" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*sequence\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 741 | ("Triggers" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*trigger\\s-+\\(\\w+\\)" 2) | 741 | ("Triggers" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*trigger\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 742 | ("Functions" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?function\\s-+\\(\\w+\\)" 3) | 742 | ("Functions" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?function\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 743 | ("Procedures" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4) | 743 | ("Procedures" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?proc\\(?:edure\\)?\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 744 | ("Packages" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) | 744 | ("Packages" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*package\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 745 | ("Types" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*type\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) | 745 | ("Types" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*type\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 746 | ("Indexes" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*index\\s-+\\(\\w+\\)" 2) | 746 | ("Indexes" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*index\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) |
| 747 | ("Tables/Views" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(table\\|view\\)\\s-+\\(\\w+\\)" 3)) | 747 | ("Tables/Views" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:table\\|view\\)\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)) |
| 748 | "Define interesting points in the SQL buffer for `imenu'. | 748 | "Define interesting points in the SQL buffer for `imenu'. |
| 749 | 749 | ||
| 750 | This is used to set `imenu-generic-expression' when SQL mode is | 750 | This is used to set `imenu-generic-expression' when SQL mode is |
| @@ -1339,6 +1339,7 @@ Based on `comint-mode-map'.") | |||
| 1339 | "\\(?:\\w+\\s-+\\)*" ;; optional intervening keywords | 1339 | "\\(?:\\w+\\s-+\\)*" ;; optional intervening keywords |
| 1340 | "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?" | 1340 | "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?" |
| 1341 | "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+" | 1341 | "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+" |
| 1342 | "\\(?:if\\s-+not\\s-+exists\\s-+\\)?" ;; IF NOT EXISTS | ||
| 1342 | "\\(\\w+\\)") | 1343 | "\\(\\w+\\)") |
| 1343 | 1 'font-lock-function-name-face)) | 1344 | 1 'font-lock-function-name-face)) |
| 1344 | 1345 | ||
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el index a82e03ceda7..477aee1b2da 100644 --- a/lisp/ps-bdf.el +++ b/lisp/ps-bdf.el | |||
| @@ -70,20 +70,15 @@ for BDFNAME." | |||
| 70 | 70 | ||
| 71 | (defsubst bdf-file-mod-time (filename) | 71 | (defsubst bdf-file-mod-time (filename) |
| 72 | "Return modification time of FILENAME. | 72 | "Return modification time of FILENAME. |
| 73 | The value is a list of two integers, the first integer has high-order | 73 | The value is a list of integers in the same format as `current-time'." |
| 74 | 16 bits, the second has low 16 bits." | ||
| 75 | (nth 5 (file-attributes filename))) | 74 | (nth 5 (file-attributes filename))) |
| 76 | 75 | ||
| 77 | (defun bdf-file-newer-than-time (filename mod-time) | 76 | (defun bdf-file-newer-than-time (filename mod-time) |
| 78 | "Return non-nil if and only if FILENAME is newer than MOD-TIME. | 77 | "Return non-nil if and only if FILENAME is newer than MOD-TIME. |
| 79 | MOD-TIME is a modification time as a list of two integers, the first | 78 | MOD-TIME is a modification time as a list of integers in the same |
| 80 | integer has high-order 16 bits, the second has low 16 bits." | 79 | format as `current-time'." |
| 81 | (let* ((new-mod-time (bdf-file-mod-time filename)) | 80 | (let ((new-mod-time (bdf-file-mod-time filename))) |
| 82 | (new-time (car new-mod-time)) | 81 | (time-less-p mod-time new-mod-time))) |
| 83 | (time (car mod-time))) | ||
| 84 | (or (> new-time time) | ||
| 85 | (and (= new-time time) | ||
| 86 | (> (nth 1 new-mod-time) (nth 1 mod-time)))))) | ||
| 87 | 82 | ||
| 88 | (defun bdf-find-file (bdfname) | 83 | (defun bdf-find-file (bdfname) |
| 89 | "Return a buffer visiting a bdf file BDFNAME. | 84 | "Return a buffer visiting a bdf file BDFNAME. |
| @@ -178,8 +173,8 @@ FONT-INFO is a list of the following format: | |||
| 178 | (BDFFILE MOD-TIME FONT-BOUNDING-BOX | 173 | (BDFFILE MOD-TIME FONT-BOUNDING-BOX |
| 179 | RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR) | 174 | RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR) |
| 180 | 175 | ||
| 181 | MOD-TIME is last modification time as a list of two integers, the | 176 | MOD-TIME is last modification time as a list of integers in the |
| 182 | first integer has high-order 16 bits, the second has low 16 bits. | 177 | same format as `current-time'. |
| 183 | 178 | ||
| 184 | SIZE is a size of the font on 72 dpi device. This value is got | 179 | SIZE is a size of the font on 72 dpi device. This value is got |
| 185 | from SIZE record of the font. | 180 | from SIZE record of the font. |
diff --git a/lisp/simple.el b/lisp/simple.el index aed945d6e13..5867561da26 100644 --- a/lisp/simple.el +++ b/lisp/simple.el | |||
| @@ -4583,6 +4583,9 @@ lines." | |||
| 4583 | (unless (and auto-window-vscroll try-vscroll | 4583 | (unless (and auto-window-vscroll try-vscroll |
| 4584 | ;; Only vscroll for single line moves | 4584 | ;; Only vscroll for single line moves |
| 4585 | (= (abs arg) 1) | 4585 | (= (abs arg) 1) |
| 4586 | ;; Under scroll-conservatively, the display engine | ||
| 4587 | ;; does this better. | ||
| 4588 | (zerop scroll-conservatively) | ||
| 4586 | ;; But don't vscroll in a keyboard macro. | 4589 | ;; But don't vscroll in a keyboard macro. |
| 4587 | (not defining-kbd-macro) | 4590 | (not defining-kbd-macro) |
| 4588 | (not executing-kbd-macro) | 4591 | (not executing-kbd-macro) |
diff --git a/lisp/subr.el b/lisp/subr.el index 8410897fd6f..c0479d35987 100644 --- a/lisp/subr.el +++ b/lisp/subr.el | |||
| @@ -1191,8 +1191,6 @@ is converted into a string by expressing it in decimal." | |||
| 1191 | (make-obsolete 'unfocus-frame "it does nothing." "22.1") | 1191 | (make-obsolete 'unfocus-frame "it does nothing." "22.1") |
| 1192 | (make-obsolete 'make-variable-frame-local | 1192 | (make-obsolete 'make-variable-frame-local |
| 1193 | "explicitly check for a frame-parameter instead." "22.2") | 1193 | "explicitly check for a frame-parameter instead." "22.2") |
| 1194 | (make-obsolete 'interactive-p 'called-interactively-p "23.2") | ||
| 1195 | (set-advertised-calling-convention 'called-interactively-p '(kind) "23.1") | ||
| 1196 | (set-advertised-calling-convention | 1194 | (set-advertised-calling-convention |
| 1197 | 'all-completions '(string collection &optional predicate) "23.1") | 1195 | 'all-completions '(string collection &optional predicate) "23.1") |
| 1198 | (set-advertised-calling-convention 'unintern '(name obarray) "23.3") | 1196 | (set-advertised-calling-convention 'unintern '(name obarray) "23.3") |
| @@ -3963,6 +3961,152 @@ The properties used on SYMBOL are `composefunc', `sendfunc', | |||
| 3963 | (put symbol 'abortfunc (or abortfunc 'kill-buffer)) | 3961 | (put symbol 'abortfunc (or abortfunc 'kill-buffer)) |
| 3964 | (put symbol 'hookvar (or hookvar 'mail-send-hook))) | 3962 | (put symbol 'hookvar (or hookvar 'mail-send-hook))) |
| 3965 | 3963 | ||
| 3964 | (defvar called-interactively-p-functions nil | ||
| 3965 | "Special hook called to skip special frames in `called-interactively-p'. | ||
| 3966 | The functions are called with 3 arguments: (I FRAME1 FRAME2), | ||
| 3967 | where FRAME1 is a \"current frame\", FRAME2 is the next frame, | ||
| 3968 | I is the index of the frame after FRAME2. It should return nil | ||
| 3969 | if those frames don't seem special and otherwise, it should return | ||
| 3970 | the number of frames to skip (minus 1).") | ||
| 3971 | |||
| 3972 | (defmacro internal--called-interactively-p--get-frame (n) | ||
| 3973 | ;; `sym' will hold a global variable, which will be used kind of like C's | ||
| 3974 | ;; "static" variables. | ||
| 3975 | (let ((sym (make-symbol "base-index"))) | ||
| 3976 | `(progn | ||
| 3977 | (defvar ,sym | ||
| 3978 | (let ((i 1)) | ||
| 3979 | (while (not (eq (nth 1 (backtrace-frame i)) | ||
| 3980 | 'called-interactively-p)) | ||
| 3981 | (setq i (1+ i))) | ||
| 3982 | i)) | ||
| 3983 | ;; (unless (eq (nth 1 (backtrace-frame ,sym)) 'called-interactively-p) | ||
| 3984 | ;; (error "called-interactively-p: %s is out-of-sync!" ,sym)) | ||
| 3985 | (backtrace-frame (+ ,sym ,n))))) | ||
| 3986 | |||
| 3987 | (defun called-interactively-p (&optional kind) | ||
| 3988 | "Return t if the containing function was called by `call-interactively'. | ||
| 3989 | If KIND is `interactive', then only return t if the call was made | ||
| 3990 | interactively by the user, i.e. not in `noninteractive' mode nor | ||
| 3991 | when `executing-kbd-macro'. | ||
| 3992 | If KIND is `any', on the other hand, it will return t for any kind of | ||
| 3993 | interactive call, including being called as the binding of a key or | ||
| 3994 | from a keyboard macro, even in `noninteractive' mode. | ||
| 3995 | |||
| 3996 | This function is very brittle, it may fail to return the intended result when | ||
| 3997 | the code is debugged, advised, or instrumented in some form. Some macros and | ||
| 3998 | special forms (such as `condition-case') may also sometimes wrap their bodies | ||
| 3999 | in a `lambda', so any call to `called-interactively-p' from those bodies will | ||
| 4000 | indicate whether that lambda (rather than the surrounding function) was called | ||
| 4001 | interactively. | ||
| 4002 | |||
| 4003 | Instead of using this function, it is cleaner and more reliable to give your | ||
| 4004 | function an extra optional argument whose `interactive' spec specifies | ||
| 4005 | non-nil unconditionally (\"p\" is a good way to do this), or via | ||
| 4006 | \(not (or executing-kbd-macro noninteractive)). | ||
| 4007 | |||
| 4008 | The only known proper use of `interactive' for KIND is in deciding | ||
| 4009 | whether to display a helpful message, or how to display it. If you're | ||
| 4010 | thinking of using it for any other purpose, it is quite likely that | ||
| 4011 | you're making a mistake. Think: what do you want to do when the | ||
| 4012 | command is called from a keyboard macro?" | ||
| 4013 | (declare (advertised-calling-convention (kind) "23.1")) | ||
| 4014 | (when (not (and (eq kind 'interactive) | ||
| 4015 | (or executing-kbd-macro noninteractive))) | ||
| 4016 | (let* ((i 1) ;; 0 is the called-interactively-p frame. | ||
| 4017 | frame nextframe | ||
| 4018 | (get-next-frame | ||
| 4019 | (lambda () | ||
| 4020 | (setq frame nextframe) | ||
| 4021 | (setq nextframe (internal--called-interactively-p--get-frame i)) | ||
| 4022 | ;; (message "Frame %d = %S" i nextframe) | ||
| 4023 | (setq i (1+ i))))) | ||
| 4024 | (funcall get-next-frame) ;; Get the first frame. | ||
| 4025 | (while | ||
| 4026 | ;; FIXME: The edebug and advice handling should be made modular and | ||
| 4027 | ;; provided directly by edebug.el and nadvice.el. | ||
| 4028 | (progn | ||
| 4029 | ;; frame =(backtrace-frame i-2) | ||
| 4030 | ;; nextframe=(backtrace-frame i-1) | ||
| 4031 | (funcall get-next-frame) | ||
| 4032 | ;; `pcase' would be a fairly good fit here, but it sometimes moves | ||
| 4033 | ;; branches within local functions, which then messes up the | ||
| 4034 | ;; `backtrace-frame' data we get, | ||
| 4035 | (or | ||
| 4036 | ;; Skip special forms (from non-compiled code). | ||
| 4037 | (and frame (null (car frame))) | ||
| 4038 | ;; Skip also `interactive-p' (because we don't want to know if | ||
| 4039 | ;; interactive-p was called interactively but if it's caller was) | ||
| 4040 | ;; and `byte-code' (idem; this appears in subexpressions of things | ||
| 4041 | ;; like condition-case, which are wrapped in a separate bytecode | ||
| 4042 | ;; chunk). | ||
| 4043 | ;; FIXME: For lexical-binding code, this is much worse, | ||
| 4044 | ;; because the frames look like "byte-code -> funcall -> #[...]", | ||
| 4045 | ;; which is not a reliable signature. | ||
| 4046 | (memq (nth 1 frame) '(interactive-p 'byte-code)) | ||
| 4047 | ;; Skip package-specific stack-frames. | ||
| 4048 | (let ((skip (run-hook-with-args-until-success | ||
| 4049 | 'called-interactively-p-functions | ||
| 4050 | i frame nextframe))) | ||
| 4051 | (pcase skip | ||
| 4052 | (`nil nil) | ||
| 4053 | (`0 t) | ||
| 4054 | (_ (setq i (+ i skip -1)) (funcall get-next-frame))))))) | ||
| 4055 | ;; Now `frame' should be "the function from which we were called". | ||
| 4056 | (pcase (cons frame nextframe) | ||
| 4057 | ;; No subr calls `interactive-p', so we can rule that out. | ||
| 4058 | (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil) | ||
| 4059 | ;; Somehow, I sometimes got `command-execute' rather than | ||
| 4060 | ;; `call-interactively' on my stacktrace !? | ||
| 4061 | ;;(`(,_ . (t command-execute . ,_)) t) | ||
| 4062 | (`(,_ . (t call-interactively . ,_)) t))))) | ||
| 4063 | |||
| 4064 | (defun interactive-p () | ||
| 4065 | "Return t if the containing function was run directly by user input. | ||
| 4066 | This means that the function was called with `call-interactively' | ||
| 4067 | \(which includes being called as the binding of a key) | ||
| 4068 | and input is currently coming from the keyboard (not a keyboard macro), | ||
| 4069 | and Emacs is not running in batch mode (`noninteractive' is nil). | ||
| 4070 | |||
| 4071 | The only known proper use of `interactive-p' is in deciding whether to | ||
| 4072 | display a helpful message, or how to display it. If you're thinking | ||
| 4073 | of using it for any other purpose, it is quite likely that you're | ||
| 4074 | making a mistake. Think: what do you want to do when the command is | ||
| 4075 | called from a keyboard macro or in batch mode? | ||
| 4076 | |||
| 4077 | To test whether your function was called with `call-interactively', | ||
| 4078 | either (i) add an extra optional argument and give it an `interactive' | ||
| 4079 | spec that specifies non-nil unconditionally (such as \"p\"); or (ii) | ||
| 4080 | use `called-interactively-p'." | ||
| 4081 | (declare (obsolete called-interactively-p "23.2")) | ||
| 4082 | (called-interactively-p 'interactive)) | ||
| 4083 | |||
| 4084 | (defun function-arity (f &optional num) | ||
| 4085 | "Return the (MIN . MAX) arity of F. | ||
| 4086 | If the maximum arity is infinite, MAX is `many'. | ||
| 4087 | F can be a function or a macro. | ||
| 4088 | If NUM is non-nil, return non-nil iff F can be called with NUM args." | ||
| 4089 | (if (symbolp f) (setq f (indirect-function f))) | ||
| 4090 | (if (eq (car-safe f) 'macro) (setq f (cdr f))) | ||
| 4091 | (let ((res | ||
| 4092 | (if (subrp f) | ||
| 4093 | (let ((x (subr-arity f))) | ||
| 4094 | (if (eq (cdr x) 'unevalled) (cons (car x) 'many))) | ||
| 4095 | (let* ((args (if (consp f) (cadr f) (aref f 0))) | ||
| 4096 | (max (length args)) | ||
| 4097 | (opt (memq '&optional args)) | ||
| 4098 | (rest (memq '&rest args)) | ||
| 4099 | (min (- max (length opt)))) | ||
| 4100 | (if opt | ||
| 4101 | (cons min (if rest 'many (1- max))) | ||
| 4102 | (if rest | ||
| 4103 | (cons (- max (length rest)) 'many) | ||
| 4104 | (cons min max))))))) | ||
| 4105 | (if (not num) | ||
| 4106 | res | ||
| 4107 | (and (>= num (car res)) | ||
| 4108 | (or (eq 'many (cdr res)) (<= num (cdr res))))))) | ||
| 4109 | |||
| 3966 | (defun set-temporary-overlay-map (map &optional keep-pred) | 4110 | (defun set-temporary-overlay-map (map &optional keep-pred) |
| 3967 | "Set MAP as a temporary keymap taking precedence over most other keymaps. | 4111 | "Set MAP as a temporary keymap taking precedence over most other keymaps. |
| 3968 | Note that this does NOT take precedence over the \"overriding\" maps | 4112 | Note that this does NOT take precedence over the \"overriding\" maps |
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 42e09b65750..95dab10101b 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el | |||
| @@ -91,7 +91,7 @@ | |||
| 91 | (declare-function w32-send-sys-command "w32fns.c") | 91 | (declare-function w32-send-sys-command "w32fns.c") |
| 92 | (declare-function set-message-beep "w32fns.c") | 92 | (declare-function set-message-beep "w32fns.c") |
| 93 | 93 | ||
| 94 | (declare-function cygwin-convert-path-from-windows "cygw32.c" | 94 | (declare-function cygwin-convert-file-name-from-windows "cygw32.c" |
| 95 | (path &optional absolute_p)) | 95 | (path &optional absolute_p)) |
| 96 | 96 | ||
| 97 | ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles | 97 | ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles |
| @@ -108,7 +108,7 @@ | |||
| 108 | 108 | ||
| 109 | (defun w32-handle-dropped-file (window file-name) | 109 | (defun w32-handle-dropped-file (window file-name) |
| 110 | (let ((f (if (eq system-type 'cygwin) | 110 | (let ((f (if (eq system-type 'cygwin) |
| 111 | (cygwin-convert-path-from-windows file-name t) | 111 | (cygwin-convert-file-name-from-windows file-name t) |
| 112 | (subst-char-in-string ?\\ ?/ file-name))) | 112 | (subst-char-in-string ?\\ ?/ file-name))) |
| 113 | (coding (or file-name-coding-system | 113 | (coding (or file-name-coding-system |
| 114 | default-file-name-coding-system))) | 114 | default-file-name-coding-system))) |
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index 3d9f88a43c9..6db15b7ec2a 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el | |||
| @@ -5210,7 +5210,7 @@ instead of the current buffer and returns the OBJECT." | |||
| 5210 | "Update cell face according to the current mode." | 5210 | "Update cell face according to the current mode." |
| 5211 | (if (featurep 'xemacs) | 5211 | (if (featurep 'xemacs) |
| 5212 | (set-face-property 'table-cell 'underline table-fixed-width-mode) | 5212 | (set-face-property 'table-cell 'underline table-fixed-width-mode) |
| 5213 | (set-face-inverse-video-p 'table-cell table-fixed-width-mode))) | 5213 | (set-face-inverse-video 'table-cell table-fixed-width-mode))) |
| 5214 | 5214 | ||
| 5215 | (table--update-cell-face) | 5215 | (table--update-cell-face) |
| 5216 | 5216 | ||
diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 3619d499419..2b4794c9cc2 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el | |||
| @@ -183,10 +183,9 @@ contains the name of the directory which the buffer is visiting.") | |||
| 183 | ;; Internal variables used free | 183 | ;; Internal variables used free |
| 184 | (defvar uniquify-possibly-resolvable nil) | 184 | (defvar uniquify-possibly-resolvable nil) |
| 185 | 185 | ||
| 186 | (defvar uniquify-managed nil | 186 | (defvar-local uniquify-managed nil |
| 187 | "Non-nil if the name of this buffer is managed by uniquify. | 187 | "Non-nil if the name of this buffer is managed by uniquify. |
| 188 | It actually holds the list of `uniquify-item's corresponding to the conflict.") | 188 | It actually holds the list of `uniquify-item's corresponding to the conflict.") |
| 189 | (make-variable-buffer-local 'uniquify-managed) | ||
| 190 | (put 'uniquify-managed 'permanent-local t) | 189 | (put 'uniquify-managed 'permanent-local t) |
| 191 | 190 | ||
| 192 | ;; Used in desktop.el to save the non-uniquified buffer name | 191 | ;; Used in desktop.el to save the non-uniquified buffer name |
| @@ -464,27 +463,34 @@ For use on `kill-buffer-hook'." | |||
| 464 | ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't | 463 | ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't |
| 465 | ;; sufficient.) | 464 | ;; sufficient.) |
| 466 | 465 | ||
| 467 | (defadvice rename-buffer (after rename-buffer-uniquify activate) | 466 | (advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) |
| 467 | (defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args) | ||
| 468 | "Uniquify buffer names with parts of directory name." | 468 | "Uniquify buffer names with parts of directory name." |
| 469 | (let ((retval (apply rb-fun newname unique args))) | ||
| 469 | (uniquify-maybe-rerationalize-w/o-cb) | 470 | (uniquify-maybe-rerationalize-w/o-cb) |
| 470 | (if (null (ad-get-arg 1)) ; no UNIQUE argument. | 471 | (if (null unique) |
| 471 | ;; Mark this buffer so it won't be renamed by uniquify. | 472 | ;; Mark this buffer so it won't be renamed by uniquify. |
| 472 | (setq uniquify-managed nil) | 473 | (setq uniquify-managed nil) |
| 473 | (when uniquify-buffer-name-style | 474 | (when uniquify-buffer-name-style |
| 474 | ;; Rerationalize w.r.t the new name. | 475 | ;; Rerationalize w.r.t the new name. |
| 475 | (uniquify-rationalize-file-buffer-names | 476 | (uniquify-rationalize-file-buffer-names |
| 476 | (ad-get-arg 0) | 477 | newname |
| 477 | (uniquify-buffer-file-name (current-buffer)) | 478 | (uniquify-buffer-file-name (current-buffer)) |
| 478 | (current-buffer)) | 479 | (current-buffer)) |
| 479 | (setq ad-return-value (buffer-name (current-buffer)))))) | 480 | (setq retval (buffer-name (current-buffer))))) |
| 481 | retval)) | ||
| 480 | 482 | ||
| 481 | (defadvice create-file-buffer (after create-file-buffer-uniquify activate) | 483 | |
| 484 | (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) | ||
| 485 | (defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args) | ||
| 482 | "Uniquify buffer names with parts of directory name." | 486 | "Uniquify buffer names with parts of directory name." |
| 487 | (let ((retval (apply cfb-fun filename args))) | ||
| 483 | (if uniquify-buffer-name-style | 488 | (if uniquify-buffer-name-style |
| 484 | (let ((filename (expand-file-name (directory-file-name (ad-get-arg 0))))) | 489 | (let ((filename (expand-file-name (directory-file-name filename)))) |
| 485 | (uniquify-rationalize-file-buffer-names | 490 | (uniquify-rationalize-file-buffer-names |
| 486 | (file-name-nondirectory filename) | 491 | (file-name-nondirectory filename) |
| 487 | (file-name-directory filename) ad-return-value)))) | 492 | (file-name-directory filename) retval))) |
| 493 | retval)) | ||
| 488 | 494 | ||
| 489 | ;;; The End | 495 | ;;; The End |
| 490 | 496 | ||
| @@ -496,9 +502,8 @@ For use on `kill-buffer-hook'." | |||
| 496 | (set-buffer buf) | 502 | (set-buffer buf) |
| 497 | (when uniquify-managed | 503 | (when uniquify-managed |
| 498 | (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) | 504 | (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) |
| 499 | (dolist (fun '(rename-buffer create-file-buffer)) | 505 | (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice) |
| 500 | (ad-remove-advice fun 'after (intern (concat (symbol-name fun) "-uniquify"))) | 506 | (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice) |
| 501 | (ad-update fun)) | ||
| 502 | (dolist (buf buffers) | 507 | (dolist (buf buffers) |
| 503 | (set-buffer (car buf)) | 508 | (set-buffer (car buf)) |
| 504 | (rename-buffer (cdr buf) t)))) | 509 | (rename-buffer (cdr buf) t)))) |
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 26c64ce2ad3..0c023b0f7f4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el | |||
| @@ -575,19 +575,21 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an error." | |||
| 575 | (easy-mmode-define-navigation | 575 | (easy-mmode-define-navigation |
| 576 | diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view | 576 | diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view |
| 577 | (when diff-auto-refine-mode | 577 | (when diff-auto-refine-mode |
| 578 | (setq diff--auto-refine-data (cons (current-buffer) (point-marker))) | 578 | (unless (prog1 diff--auto-refine-data |
| 579 | (run-at-time 0.0 nil | 579 | (setq diff--auto-refine-data |
| 580 | (lambda () | 580 | (cons (current-buffer) (point-marker)))) |
| 581 | (when diff--auto-refine-data | 581 | (run-at-time 0.0 nil |
| 582 | (let ((buffer (car diff--auto-refine-data)) | 582 | (lambda () |
| 583 | (point (cdr diff--auto-refine-data))) | 583 | (when diff--auto-refine-data |
| 584 | (setq diff--auto-refine-data nil) | 584 | (let ((buffer (car diff--auto-refine-data)) |
| 585 | (with-local-quit | 585 | (point (cdr diff--auto-refine-data))) |
| 586 | (when (buffer-live-p buffer) | 586 | (setq diff--auto-refine-data nil) |
| 587 | (with-current-buffer buffer | 587 | (with-local-quit |
| 588 | (save-excursion | 588 | (when (buffer-live-p buffer) |
| 589 | (goto-char point) | 589 | (with-current-buffer buffer |
| 590 | (diff-refine-hunk))))))))))) | 590 | (save-excursion |
| 591 | (goto-char point) | ||
| 592 | (diff-refine-hunk)))))))))))) | ||
| 591 | 593 | ||
| 592 | (easy-mmode-define-navigation | 594 | (easy-mmode-define-navigation |
| 593 | diff-file diff-file-header-re "file" diff-end-of-file) | 595 | diff-file diff-file-header-re "file" diff-end-of-file) |
diff --git a/lisp/window.el b/lisp/window.el index d378ea5ff14..52909fa9e5f 100644 --- a/lisp/window.el +++ b/lisp/window.el | |||
| @@ -5870,7 +5870,12 @@ the selected window or never appeared in it before, or if | |||
| 5870 | :version "24.3") | 5870 | :version "24.3") |
| 5871 | 5871 | ||
| 5872 | (defun switch-to-buffer (buffer-or-name &optional norecord force-same-window) | 5872 | (defun switch-to-buffer (buffer-or-name &optional norecord force-same-window) |
| 5873 | "Switch to buffer BUFFER-OR-NAME in the selected window. | 5873 | "Display buffer BUFFER-OR-NAME in the selected window. |
| 5874 | |||
| 5875 | WARNING: This is NOT the way to work on another buffer temporarily | ||
| 5876 | within a Lisp program! Use `set-buffer' instead. That avoids | ||
| 5877 | messing with the window-buffer correspondences. | ||
| 5878 | |||
| 5874 | If the selected window cannot display the specified | 5879 | If the selected window cannot display the specified |
| 5875 | buffer (e.g. if it is a minibuffer window or strongly dedicated | 5880 | buffer (e.g. if it is a minibuffer window or strongly dedicated |
| 5876 | to another buffer), call `pop-to-buffer' to select the buffer in | 5881 | to another buffer), call `pop-to-buffer' to select the buffer in |