Now on revision 113971. ------------------------------------------------------------ revno: 113971 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2013-08-22 00:06:45 -0400 message: * lisp/erc/erc.el: Use lexical-binding. (erc-user-full-name): Minor CSE simplification. (erc-mode-map): Assume command-remapping is available. (erc-once-with-server-event): Replace `forms' arg with a function arg. (erc-once-with-server-event-global): Remove. (erc-ison-p): Adjust to change in erc-once-with-server-event. (erc-get-buffer-create): Remove arg `proc'. (iswitchb-make-buflist-hook): Declare. (erc-setup-buffer): Use pcase; avoid ((lambda ..) ..). (read-passwd): Assume it exists. (erc-display-line, erc-cmd-IDLE): Avoid add-to-list, adjust to change in erc-once-with-server-event. (erc-cmd-JOIN, erc-set-channel-limit, erc-set-channel-key) (erc-add-query): Minor CSE simplification. (erc-cmd-BANLIST, erc-cmd-MASSUNBAN): Adjust to change in erc-once-with-server-event. (erc-echo-notice-in-user-and-target-buffers): Avoid add-to-list. * lisp/erc/erc-track.el: Use lexical-binding. (erc-make-mode-line-buffer-name): Use closures instead of `(lambda...). (erc-faces-in): Avoid add-to-list. * lisp/erc/erc-notify.el: Use lexical-binding. (erc-notify-timer): Adjust to change in erc-once-with-server-event. (erc-notify-QUIT): Use a closure instead of `(lambda...). * lisp/erc/erc-list.el: Use lexical-binding. (erc-list-install-322-handler, erc-cmd-LIST): Adjust to change in erc-once-with-server-event. * lisp/erc/erc-button.el: Use lexical-binding. (erc-button-next-function): Use a closure instead of `(lambda...). diff: === modified file 'lisp/erc/ChangeLog' --- lisp/erc/ChangeLog 2013-06-19 20:10:57 +0000 +++ lisp/erc/ChangeLog 2013-08-22 04:06:45 +0000 @@ -1,3 +1,34 @@ +2013-08-22 Stefan Monnier + + * erc.el: Use lexical-binding. + (erc-user-full-name): Minor CSE simplification. + (erc-mode-map): Assume command-remapping is available. + (erc-once-with-server-event): Replace `forms' arg with a function arg. + (erc-once-with-server-event-global): Remove. + (erc-ison-p): Adjust to change in erc-once-with-server-event. + (erc-get-buffer-create): Remove arg `proc'. + (iswitchb-make-buflist-hook): Declare. + (erc-setup-buffer): Use pcase; avoid ((lambda ..) ..). + (read-passwd): Assume it exists. + (erc-display-line, erc-cmd-IDLE): Avoid add-to-list, adjust to change + in erc-once-with-server-event. + (erc-cmd-JOIN, erc-set-channel-limit, erc-set-channel-key) + (erc-add-query): Minor CSE simplification. + (erc-cmd-BANLIST, erc-cmd-MASSUNBAN): Adjust to change + in erc-once-with-server-event. + (erc-echo-notice-in-user-and-target-buffers): Avoid add-to-list. + * erc-track.el: Use lexical-binding. + (erc-make-mode-line-buffer-name): Use closures instead of `(lambda...). + (erc-faces-in): Avoid add-to-list. + * erc-notify.el: Use lexical-binding. + (erc-notify-timer): Adjust to change in erc-once-with-server-event. + (erc-notify-QUIT): Use a closure instead of `(lambda...). + * erc-list.el: Use lexical-binding. + (erc-list-install-322-handler, erc-cmd-LIST): Adjust to change in + erc-once-with-server-event. + * erc-button.el: Use lexical-binding. + (erc-button-next-function): Use a closure instead of `(lambda...). + 2013-05-30 Glenn Morris * erc-backend.el: Require erc at run-time too. === modified file 'lisp/erc/erc-button.el' --- lisp/erc/erc-button.el 2013-01-01 09:11:05 +0000 +++ lisp/erc/erc-button.el 2013-08-22 04:06:45 +0000 @@ -1,4 +1,4 @@ -;; erc-button.el --- A way of buttonizing certain things in ERC buffers +;; erc-button.el --- A way of buttonizing certain things in ERC buffers -*- lexical-binding:t -*- ;; Copyright (C) 1996-2004, 2006-2013 Free Software Foundation, Inc. @@ -432,19 +432,22 @@ (defun erc-button-next-function () "Pseudo completion function that actually jumps to the next button. For use on `completion-at-point-functions'." - (when (< (point) (erc-beg-of-input-line)) - `(lambda () - (let ((here ,(point))) - (while (and (get-text-property here 'erc-callback) - (not (= here (point-max)))) - (setq here (1+ here))) - (while (and (not (get-text-property here 'erc-callback)) - (not (= here (point-max)))) - (setq here (1+ here))) - (if (< here (point-max)) - (goto-char here) - (error "No next button")) - t)))) + ;; FIXME: This is an abuse of completion-at-point-functions. + (when (< (point) (erc-beg-of-input-line)) + (let ((start (point))) + (lambda () + (let ((here start)) + ;; FIXME: Use next-single-property-change. + (while (and (get-text-property here 'erc-callback) + (not (= here (point-max)))) + (setq here (1+ here))) + (while (not (or (get-text-property here 'erc-callback) + (= here (point-max)))) + (setq here (1+ here))) + (if (< here (point-max)) + (goto-char here) + (error "No next button")) + t))))) (defun erc-button-next () "Go to the next button in this buffer." === modified file 'lisp/erc/erc-list.el' --- lisp/erc/erc-list.el 2013-05-15 23:55:41 +0000 +++ lisp/erc/erc-list.el 2013-08-22 04:06:45 +0000 @@ -1,4 +1,4 @@ -;;; erc-list.el --- /list support for ERC +;;; erc-list.el --- /list support for ERC -*- lexical-binding:t -*- ;; Copyright (C) 2008-2013 Free Software Foundation, Inc. @@ -183,7 +183,7 @@ ;; Arrange for 323 (end of list) to end this. (erc-once-with-server-event 323 - '(progn + (lambda (_proc _parsed) (remove-hook 'erc-server-322-functions 'erc-list-handle-322 t))) ;; Find the list buffer, empty it, and display it. (set (make-local-variable 'erc-list-buffer) @@ -209,11 +209,12 @@ Please note that this function only works with IRC servers which conform to RFC and send the LIST header (#321) at start of list transmission." (erc-with-server-buffer - (set (make-local-variable 'erc-list-last-argument) line) - (erc-once-with-server-event - 321 - (list 'progn - (list 'erc-list-install-322-handler (current-buffer))))) + (set (make-local-variable 'erc-list-last-argument) line) + (erc-once-with-server-event + 321 + (let ((buf (current-buffer))) + (lambda (_proc _parsed) + (erc-list-install-322-handler buf))))) (erc-server-send (concat "LIST :" (or (and line (substring line 1)) "")))) (put 'erc-cmd-LIST 'do-not-parse-args t) === modified file 'lisp/erc/erc-notify.el' --- lisp/erc/erc-notify.el 2013-05-21 07:25:14 +0000 +++ lisp/erc/erc-notify.el 2013-08-22 04:06:45 +0000 @@ -1,4 +1,4 @@ -;;; erc-notify.el --- Online status change notification +;;; erc-notify.el --- Online status change notification -*- lexical-binding:t -*- ;; Copyright (C) 2002-2004, 2006-2013 Free Software Foundation, Inc. @@ -115,27 +115,28 @@ erc-notify-interval)) (erc-once-with-server-event 303 - '(let* ((server (erc-response.sender parsed)) - (ison-list (delete "" (split-string - (erc-response.contents parsed)))) - (new-list ison-list) - (old-list (erc-with-server-buffer erc-last-ison))) - (while new-list - (when (not (erc-member-ignore-case (car new-list) old-list)) - (run-hook-with-args 'erc-notify-signon-hook server (car new-list)) - (erc-display-message - parsed 'notice proc - 'notify_on ?n (car new-list) ?m (erc-network-name))) - (setq new-list (cdr new-list))) - (while old-list - (when (not (erc-member-ignore-case (car old-list) ison-list)) - (run-hook-with-args 'erc-notify-signoff-hook server (car old-list)) - (erc-display-message - parsed 'notice proc - 'notify_off ?n (car old-list) ?m (erc-network-name))) - (setq old-list (cdr old-list))) - (setq erc-last-ison ison-list) - t)) + (lambda (proc parsed) + (let* ((server (erc-response.sender parsed)) + (ison-list (delete "" (split-string + (erc-response.contents parsed)))) + (new-list ison-list) + (old-list (erc-with-server-buffer erc-last-ison))) + (while new-list + (when (not (erc-member-ignore-case (car new-list) old-list)) + (run-hook-with-args 'erc-notify-signon-hook server (car new-list)) + (erc-display-message + parsed 'notice proc + 'notify_on ?n (car new-list) ?m (erc-network-name))) + (setq new-list (cdr new-list))) + (while old-list + (when (not (erc-member-ignore-case (car old-list) ison-list)) + (run-hook-with-args 'erc-notify-signoff-hook server (car old-list)) + (erc-display-message + parsed 'notice proc + 'notify_off ?n (car old-list) ?m (erc-network-name))) + (setq old-list (cdr old-list))) + (setq erc-last-ison ison-list) + t))) (erc-server-send (concat "ISON " (mapconcat 'identity erc-notify-list " "))) (setq erc-last-ison-time now))) @@ -179,10 +180,11 @@ (let ((nick (erc-extract-nick (erc-response.sender parsed)))) (when (and (erc-member-ignore-case nick erc-notify-list) (erc-member-ignore-case nick erc-last-ison)) - (setq erc-last-ison (erc-delete-if `(lambda (el) - (string= ,(erc-downcase nick) - (erc-downcase el))) - erc-last-ison)) + (setq erc-last-ison (erc-delete-if + (let ((nick-down (erc-downcase nick))) + (lambda (el) + (string= nick-down (erc-downcase el)))) + erc-last-ison)) (run-hook-with-args 'erc-notify-signoff-hook (or erc-server-announced-name erc-session-server) nick) === modified file 'lisp/erc/erc-track.el' --- lisp/erc/erc-track.el 2013-01-02 16:13:04 +0000 +++ lisp/erc/erc-track.el 2013-08-22 04:06:45 +0000 @@ -1,4 +1,4 @@ -;;; erc-track.el --- Track modified channel buffers +;;; erc-track.el --- Track modified channel buffers -*- lexical-binding:t -*- ;; Copyright (C) 2002-2013 Free Software Foundation, Inc. @@ -710,7 +710,7 @@ to consider when `erc-track-visibility' is set to only consider active buffers visible.") -(defun erc-user-is-active (&rest ignore) +(defun erc-user-is-active (&rest _ignore) "Set `erc-buffer-activity'." (when erc-server-connected (setq erc-buffer-activity (erc-current-time)) @@ -745,7 +745,7 @@ times. Without it, you cannot debug `erc-modified-channels-display', because the debugger also cases changes to the window-configuration.") -(defun erc-modified-channels-update (&rest args) +(defun erc-modified-channels-update (&rest _args) "This function updates the information in `erc-modified-channels-alist' according to buffer visibility. It calls `erc-modified-channels-display' at the end. This should usually be @@ -791,19 +791,19 @@ (int-to-string count)) (copy-sequence string)))) (define-key map (vector 'mode-line 'mouse-2) - `(lambda (e) - (interactive "e") - (save-selected-window - (select-window - (posn-window (event-start e))) - (switch-to-buffer ,buffer)))) + (lambda (e) + (interactive "e") + (save-selected-window + (select-window + (posn-window (event-start e))) + (switch-to-buffer buffer)))) (define-key map (vector 'mode-line 'mouse-3) - `(lambda (e) - (interactive "e") - (save-selected-window - (select-window - (posn-window (event-start e))) - (switch-to-buffer-other-window ,buffer)))) + (lambda (e) + (interactive "e") + (save-selected-window + (select-window + (posn-window (event-start e))) + (switch-to-buffer-other-window buffer)))) (put-text-property 0 (length name) 'local-map map name) (put-text-property 0 (length name) @@ -976,8 +976,9 @@ cur) (while (and (setq i (next-single-property-change i 'face str m)) (not (= i m))) - (when (setq cur (get-text-property i 'face str)) - (add-to-list 'faces cur))) + (and (setq cur (get-text-property i 'face str)) + (not (member cur faces)) + (push cur faces))) faces)) (cl-assert === modified file 'lisp/erc/erc.el' --- lisp/erc/erc.el 2013-05-21 07:15:59 +0000 +++ lisp/erc/erc.el 2013-08-22 04:06:45 +0000 @@ -1,4 +1,4 @@ -;; erc.el --- An Emacs Internet Relay Chat client +;; erc.el --- An Emacs Internet Relay Chat client -*- lexical-binding:t -*- ;; Copyright (C) 1997-2013 Free Software Foundation, Inc. @@ -125,20 +125,11 @@ ;; compatibility with older ERC releases -(if (fboundp 'defvaralias) - (progn - (defvaralias 'erc-announced-server-name 'erc-server-announced-name) - (erc-make-obsolete-variable 'erc-announced-server-name - 'erc-server-announced-name - "ERC 5.1") - (defvaralias 'erc-process 'erc-server-process) - (erc-make-obsolete-variable 'erc-process 'erc-server-process "ERC 5.1") - (defvaralias 'erc-default-coding-system 'erc-server-coding-system) - (erc-make-obsolete-variable 'erc-default-coding-system - 'erc-server-coding-system - "ERC 5.1")) - (message (concat "ERC: The function `defvaralias' is not bound. See the " - "NEWS file for variable name changes since ERC 5.0.4."))) +(define-obsolete-variable-alias 'erc-announced-server-name + 'erc-server-announced-name "ERC 5.1") +(define-obsolete-variable-alias 'erc-process 'erc-server-process "ERC 5.1") +(define-obsolete-variable-alias 'erc-default-coding-system + 'erc-server-coding-system "ERC 5.1") (define-obsolete-function-alias 'erc-send-command 'erc-server-send "ERC 5.1") @@ -201,9 +192,7 @@ (string :tag "Name") (function :tag "Get from function")) :set (lambda (sym val) - (if (functionp val) - (set sym (funcall val)) - (set sym val)))) + (set sym (if (functionp val) (funcall val) val)))) (defvar erc-password nil "Password to use when authenticating to an IRC server. @@ -388,12 +377,12 @@ (last-message-time nil)) (defsubst erc-get-channel-user (nick) - "Finds the (USER . CHANNEL-DATA) element corresponding to NICK + "Find the (USER . CHANNEL-DATA) element corresponding to NICK in the current buffer's `erc-channel-users' hash table." (gethash (erc-downcase nick) erc-channel-users)) (defsubst erc-get-server-user (nick) - "Finds the USER corresponding to NICK in the current server's + "Find the USER corresponding to NICK in the current server's `erc-server-users' hash table." (erc-with-server-buffer (gethash (erc-downcase nick) erc-server-users))) @@ -480,7 +469,7 @@ (when (and erc-server-connected (erc-server-process-alive) (hash-table-p erc-channel-users)) - (maphash (lambda (nick cdata) + (maphash (lambda (nick _cdata) (erc-remove-channel-user nick)) erc-channel-users) (clrhash erc-channel-users))) @@ -502,25 +491,25 @@ (erc-channel-user-voice (cdr cdata)))))) (defun erc-get-channel-user-list () - "Returns a list of users in the current channel. Each element + "Return a list of users in the current channel. Each element of the list is of the form (USER . CHANNEL-DATA), where USER is -an erc-server-user struct, and CHANNEL-DATA is either `nil' or an +an erc-server-user struct, and CHANNEL-DATA is either nil or an erc-channel-user struct. See also: `erc-sort-channel-users-by-activity'" (let (users) (if (hash-table-p erc-channel-users) - (maphash (lambda (nick cdata) + (maphash (lambda (_nick cdata) (setq users (cons cdata users))) erc-channel-users)) users)) (defun erc-get-server-nickname-list () - "Returns a list of known nicknames on the current server." + "Return a list of known nicknames on the current server." (erc-with-server-buffer (let (nicks) (when (hash-table-p erc-server-users) - (maphash (lambda (n user) + (maphash (lambda (_n user) (setq nicks (cons (erc-server-user-nickname user) nicks))) @@ -528,10 +517,10 @@ nicks)))) (defun erc-get-channel-nickname-list () - "Returns a list of known nicknames on the current channel." + "Return a list of known nicknames on the current channel." (let (nicks) (when (hash-table-p erc-channel-users) - (maphash (lambda (n cdata) + (maphash (lambda (_n cdata) (setq nicks (cons (erc-server-user-nickname (car cdata)) nicks))) @@ -539,11 +528,11 @@ nicks))) (defun erc-get-server-nickname-alist () - "Returns an alist of known nicknames on the current server." + "Return an alist of known nicknames on the current server." (erc-with-server-buffer (let (nicks) (when (hash-table-p erc-server-users) - (maphash (lambda (n user) + (maphash (lambda (_n user) (setq nicks (cons (cons (erc-server-user-nickname user) nil) nicks))) @@ -551,10 +540,10 @@ nicks)))) (defun erc-get-channel-nickname-alist () - "Returns an alist of known nicknames on the current channel." + "Return an alist of known nicknames on the current channel." (let (nicks) (when (hash-table-p erc-channel-users) - (maphash (lambda (n cdata) + (maphash (lambda (_n cdata) (setq nicks (cons (cons (erc-server-user-nickname (car cdata)) nil) nicks))) @@ -562,21 +551,18 @@ nicks))) (defun erc-sort-channel-users-by-activity (list) - "Sorts LIST such that users which have spoken most recently are -listed first. LIST must be of the form (USER . CHANNEL-DATA). + "Sort LIST such that users which have spoken most recently are listed first. +LIST must be of the form (USER . CHANNEL-DATA). See also: `erc-get-channel-user-list'." (sort list (lambda (x y) - (when (and - (cdr x) (cdr y)) + (when (and (cdr x) (cdr y)) (let ((tx (erc-channel-user-last-message-time (cdr x))) (ty (erc-channel-user-last-message-time (cdr y)))) - (if tx - (if ty - (time-less-p ty tx) - t) - nil)))))) + (and tx + (or (not ty) + (time-less-p ty tx)))))))) (defun erc-sort-channel-users-alphabetically (list) "Sort LIST so that users' nicknames are in alphabetical order. @@ -585,15 +571,12 @@ See also: `erc-get-channel-user-list'." (sort list (lambda (x y) - (when (and - (cdr x) (cdr y)) + (when (and (cdr x) (cdr y)) (let ((nickx (downcase (erc-server-user-nickname (car x)))) (nicky (downcase (erc-server-user-nickname (car y))))) - (if nickx - (if nicky - (string-lessp nickx nicky) - t) - nil)))))) + (and nickx + (or (not nicky) + (string-lessp nickx nicky)))))))) (defvar erc-channel-topic nil "A topic string for the channel. Should only be used in channel-buffers.") @@ -678,8 +661,8 @@ (const :tag "don't highlight notices at all" nil))) (defcustom erc-echo-notice-hook nil - "Specifies a list of functions to call to echo a private -notice. Each function is called with four arguments, the string + "List of functions to call to echo a private notice. +Each function is called with four arguments, the string to display, the parsed server message, the target buffer (or nil), and the sender. The functions are called in order, until a function evaluates to non-nil. These hooks are called after @@ -709,8 +692,8 @@ (defcustom erc-echo-notice-always-hook '(erc-echo-notice-in-default-buffer) - "Specifies a list of functions to call to echo a private -notice. Each function is called with four arguments, the string + "List of functions to call to echo a private notice. +Each function is called with four arguments, the string to display, the parsed server message, the target buffer (or nil), and the sender. The functions are called in order, and all functions are called. These hooks are called before those @@ -1062,9 +1045,9 @@ :options '(erc-make-read-only)) (defcustom erc-send-completed-hook - (when (featurep 'emacspeak) + (when (fboundp 'emacspeak-auditory-icon) (list (byte-compile - (lambda (str) + (lambda (_str) (emacspeak-auditory-icon 'select-object))))) "Hook called after a message has been parsed by ERC. @@ -1115,10 +1098,7 @@ ;; Suppress `font-lock-fontify-block' key binding since it ;; destroys face properties. - (if (fboundp 'command-remapping) - (define-key map [remap font-lock-fontify-block] 'undefined) - (substitute-key-definition - 'font-lock-fontify-block 'undefined map global-map)) + (define-key map [remap font-lock-fontify-block] 'undefined) map) "ERC keymap.") @@ -1277,14 +1257,14 @@ (put ',enable 'definition-name ',name) (put ',disable 'definition-name ',name)))) -(defun erc-once-with-server-event (event &rest forms) - "Execute FORMS the next time EVENT occurs in the `current-buffer'. +(defun erc-once-with-server-event (event f) + "Run function F the next time EVENT occurs in the `current-buffer'. You should make sure that `current-buffer' is a server buffer. -This function temporarily adds a function to EVENT's hook to -execute FORMS. After FORMS are run, the function is removed from -EVENT's hook. The last expression of FORMS should be either nil +This function temporarily adds a function to EVENT's hook to call F with +two arguments (`proc' and `parsed'). After F is called, the function is +removed from EVENT's hook. F should return either nil or t, where nil indicates that the other functions on EVENT's hook should be run too, and t indicates that other functions should not be run. @@ -1298,35 +1278,14 @@ "You should only run `erc-once-with-server-event' in a server buffer")) (let ((fun (make-symbol "fun")) (hook (erc-get-hook event))) - (put fun 'erc-original-buffer (current-buffer)) - (fset fun `(lambda (proc parsed) - (with-current-buffer (get ',fun 'erc-original-buffer) - (remove-hook ',hook ',fun t)) - (fmakunbound ',fun) - ,@forms)) - (add-hook hook fun nil t) - fun)) - -(defun erc-once-with-server-event-global (event &rest forms) - "Execute FORMS the next time EVENT occurs in any server buffer. - -This function temporarily prepends a function to EVENT's hook to -execute FORMS. After FORMS are run, the function is removed from -EVENT's hook. The last expression of FORMS should be either nil -or t, where nil indicates that the other functions on EVENT's hook -should be run too, and t indicates that other functions should -not be run. - -When FORMS execute, the current buffer is the server buffer associated with the -connection over which the data was received that triggered EVENT." - (let ((fun (make-symbol "fun")) - (hook (erc-get-hook event))) - (fset fun `(lambda (proc parsed) - (remove-hook ',hook ',fun) - (fmakunbound ',fun) - ,@forms)) - (add-hook hook fun nil nil) - fun)) + (put fun 'erc-original-buffer (current-buffer)) + (fset fun (lambda (proc parsed) + (with-current-buffer (get fun 'erc-original-buffer) + (remove-hook hook fun t)) + (fmakunbound fun) + (funcall f proc parsed))) + (add-hook hook fun nil t) + fun)) (defsubst erc-log (string) "Logs STRING if logging is on (see `erc-log-p')." @@ -1353,7 +1312,7 @@ (and (eq major-mode 'erc-mode) (null (erc-default-target))))) -(defun erc-open-server-buffer-p (&optional buffer) +(defun erc-open-server-buffer-p (&optional buffer) ;FIXME: `buffer' is ignored! "Return non-nil if argument BUFFER is an ERC server buffer that has an open IRC process. @@ -1377,9 +1336,10 @@ (let ((erc-online-p 'unknown)) (erc-once-with-server-event 303 - `(let ((ison (split-string (aref parsed 3)))) - (setq erc-online-p (car (erc-member-ignore-case ,nick ison))) - t)) + (lambda (_proc parsed) + (let ((ison (split-string (aref parsed 3)))) + (setq erc-online-p (car (erc-member-ignore-case nick ison))) + t))) (erc-server-send (format "ISON %s" nick)) (while (eq erc-online-p 'unknown) (accept-process-output)) (if (called-interactively-p 'interactive) @@ -1551,7 +1511,7 @@ "Check whether ports A and B are equal." (= (erc-normalize-port a) (erc-normalize-port b))) -(defun erc-generate-new-buffer-name (server port target &optional proc) +(defun erc-generate-new-buffer-name (server port target) "Create a new buffer name based on the arguments." (when (numberp port) (setq port (number-to-string port))) (let ((buf-name (or target @@ -1582,9 +1542,9 @@ ;; fallback to the old uniquification method: (or buffer-name (generate-new-buffer-name buf-name)) )) -(defun erc-get-buffer-create (server port target &optional proc) +(defun erc-get-buffer-create (server port target) "Create a new buffer based on the arguments." - (get-buffer-create (erc-generate-new-buffer-name server port target proc))) + (get-buffer-create (erc-generate-new-buffer-name server port target))) (defun erc-member-ignore-case (string list) @@ -1700,6 +1660,7 @@ (defvar iswitchb-temp-buflist) (declare-function iswitchb-read-buffer "iswitchb" (prompt &optional default require-match start matches-set)) +(defvar iswitchb-make-buflist-hook) (defun erc-iswitchb (&optional arg) "Use `iswitchb-read-buffer' to prompt for a ERC buffer to switch to. @@ -1906,29 +1867,29 @@ (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." - (cond ((eq erc-join-buffer 'window) - (if (active-minibuffer-window) - (display-buffer buffer) - (switch-to-buffer-other-window buffer))) - ((eq erc-join-buffer 'window-noselect) - (display-buffer buffer)) - ((eq erc-join-buffer 'bury) - nil) - ((eq erc-join-buffer 'frame) - (when (or (not erc-reuse-frames) - (not (get-buffer-window buffer t))) - ((lambda (frame) - (raise-frame frame) - (select-frame frame)) - (make-frame (or erc-frame-alist - default-frame-alist))) - (switch-to-buffer buffer) - (when erc-frame-dedicated-flag - (set-window-dedicated-p (selected-window) t)))) - (t - (if (active-minibuffer-window) - (display-buffer buffer) - (switch-to-buffer buffer))))) + (pcase erc-join-buffer + (`window + (if (active-minibuffer-window) + (display-buffer buffer) + (switch-to-buffer-other-window buffer))) + (`window-noselect + (display-buffer buffer)) + (`bury + nil) + (`frame + (when (or (not erc-reuse-frames) + (not (get-buffer-window buffer t))) + (let ((frame (make-frame (or erc-frame-alist + default-frame-alist)))) + (raise-frame frame) + (select-frame frame)) + (switch-to-buffer buffer) + (when erc-frame-dedicated-flag + (set-window-dedicated-p (selected-window) t)))) + (_ + (if (active-minibuffer-window) + (display-buffer buffer) + (switch-to-buffer buffer))))) (defun erc-open (&optional server port nick full-name connect passwd tgt-list channel process) @@ -2006,19 +1967,20 @@ ;; The local copy of `erc-nick' - the list of nicks to choose (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) ;; password stuff - (setq erc-session-password (or passwd - (let ((secret - (plist-get - (nth 0 - (auth-source-search :host server - :max 1 - :user nick - :port port - :require '(:secret))) - :secret))) - (if (functionp secret) - (funcall secret) - secret)))) + (setq erc-session-password + (or passwd + (let ((secret + (plist-get + (nth 0 + (auth-source-search :host server + :max 1 + :user nick + :port port + :require '(:secret))) + :secret))) + (if (functionp secret) + (funcall secret) + secret)))) ;; debug output buffer (setq erc-dbuf (when erc-log-p @@ -2080,11 +2042,6 @@ (erc-port-equal erc-session-port port) (erc-current-nick-p nick))))) -(if (not (fboundp 'read-passwd)) - (defun read-passwd (prompt) - "Substitute for `read-passwd' in early emacsen." - (read-from-minibuffer prompt))) - (defcustom erc-before-connect nil "Hook called before connecting to a server. This hook gets executed before `erc' actually invokes `erc-mode' @@ -2433,11 +2390,11 @@ (t (list (current-buffer))))) (when (buffer-live-p buf) (erc-display-line-1 string buf) - (add-to-list 'new-bufs buf))) + (push buf new-bufs))) (when (null new-bufs) - (if (erc-server-buffer-live-p) - (erc-display-line-1 string (process-buffer erc-server-process)) - (erc-display-line-1 string (current-buffer)))))) + (erc-display-line-1 string (if (erc-server-buffer-live-p) + (process-buffer erc-server-process) + (current-buffer)))))) (defun erc-display-message-highlight (type string) "Highlight STRING according to TYPE, where erc-TYPE-face is an ERC face. @@ -2544,7 +2501,7 @@ "Internal counter variable for use with `erc-lurker-cleanup-interval'.") (defvar erc-lurker-cleanup-interval 100 - "Specifies frequency of cleaning up stale erc-lurker state. + "Frequency of cleaning up stale erc-lurker state. `erc-lurker-update-status' calls `erc-lurker-cleanup' once for every `erc-lurker-cleanup-interval' updates to @@ -2552,7 +2509,7 @@ consumption of lurker state during long Emacs sessions and/or ERC sessions with large numbers of incoming PRIVMSGs.") -(defun erc-lurker-update-status (message) +(defun erc-lurker-update-status (_message) "Update `erc-lurker-state' if necessary. This function is called from `erc-insert-pre-hook'. If the @@ -2614,7 +2571,7 @@ :type 'alist) (defun erc-canonicalize-server-name (server) - "Returns the canonical network name for SERVER if any, + "Return the canonical network name for SERVER if any, otherwise `erc-server-announced-name'. SERVER is matched against `erc-common-server-suffixes'." (when server @@ -2877,7 +2834,7 @@ (interactive) (let ((ops nil)) (if erc-channel-users - (maphash (lambda (nick user-data) + (maphash (lambda (_nick user-data) (let ((cuser (cdr user-data))) (if (and cuser (erc-channel-user-op cuser)) @@ -3007,9 +2964,9 @@ (switch-to-buffer (car (erc-member-ignore-case chnl joined-channels))) (erc-log (format "cmd: JOIN: %s" chnl)) - (if (and chnl key) - (erc-server-send (format "JOIN %s %s" chnl key)) - (erc-server-send (format "JOIN %s" chnl))))))) + (erc-server-send (if (and chnl key) + (format "JOIN %s %s" chnl key) + (format "JOIN %s" chnl))))))) t) (defalias 'erc-cmd-CHANNEL 'erc-cmd-JOIN) @@ -3120,68 +3077,76 @@ (let ((origbuf (current-buffer)) symlist) (erc-with-server-buffer - (add-to-list 'symlist - (cons (erc-once-with-server-event - 311 `(string= ,nick - (nth 1 - (erc-response.command-args parsed)))) - 'erc-server-311-functions)) - (add-to-list 'symlist - (cons (erc-once-with-server-event - 312 `(string= ,nick - (nth 1 - (erc-response.command-args parsed)))) - 'erc-server-312-functions)) - (add-to-list 'symlist - (cons (erc-once-with-server-event - 318 `(string= ,nick - (nth 1 - (erc-response.command-args parsed)))) - 'erc-server-318-functions)) - (add-to-list 'symlist - (cons (erc-once-with-server-event - 319 `(string= ,nick - (nth 1 - (erc-response.command-args parsed)))) - 'erc-server-319-functions)) - (add-to-list 'symlist - (cons (erc-once-with-server-event - 320 `(string= ,nick - (nth 1 - (erc-response.command-args parsed)))) - 'erc-server-320-functions)) - (add-to-list 'symlist - (cons (erc-once-with-server-event - 330 `(string= ,nick - (nth 1 - (erc-response.command-args parsed)))) - 'erc-server-330-functions)) - (add-to-list 'symlist - (cons (erc-once-with-server-event - 317 - `(let ((idleseconds - (string-to-number - (third - (erc-response.command-args parsed))))) - (erc-display-line - (erc-make-notice - (format "%s has been idle for %s." - (erc-string-no-properties ,nick) - (erc-seconds-to-string idleseconds))) - ,origbuf)) - t) - 'erc-server-317-functions)) - - ;; Send the WHOIS command. - (erc-cmd-WHOIS nick) - - ;; Remove the uninterned symbols from the server hooks that did not run. - (run-at-time 20 nil `(lambda () - (with-current-buffer ,(current-buffer) - (dolist (sym ',symlist) - (let ((hooksym (cdr sym)) - (funcsym (car sym))) - (remove-hook hooksym funcsym t)))))))) + (push (cons (erc-once-with-server-event + 311 (lambda (_proc parsed) + (string= nick + (nth 1 (erc-response.command-args + parsed))))) + 'erc-server-311-functions) + symlist) + (push (cons (erc-once-with-server-event + 312 (lambda (_proc parsed) + (string= nick + (nth 1 (erc-response.command-args + parsed))))) + 'erc-server-312-functions) + symlist) + (push (cons (erc-once-with-server-event + 318 (lambda (_proc parsed) + (string= nick + (nth 1 (erc-response.command-args + parsed))))) + 'erc-server-318-functions) + symlist) + (push (cons (erc-once-with-server-event + 319 (lambda (_proc parsed) + (string= nick + (nth 1 (erc-response.command-args + parsed))))) + 'erc-server-319-functions) + symlist) + (push (cons (erc-once-with-server-event + 320 (lambda (_proc parsed) + (string= nick + (nth 1 (erc-response.command-args + parsed))))) + 'erc-server-320-functions) + symlist) + (push (cons (erc-once-with-server-event + 330 (lambda (_proc parsed) + (string= nick + (nth 1 (erc-response.command-args + parsed))))) + 'erc-server-330-functions) + symlist) + (push (cons (erc-once-with-server-event + 317 + (lambda (_proc parsed) + (let ((idleseconds + (string-to-number + (cl-third + (erc-response.command-args parsed))))) + (erc-display-line + (erc-make-notice + (format "%s has been idle for %s." + (erc-string-no-properties nick) + (erc-seconds-to-string idleseconds))) + origbuf) + t))) + 'erc-server-317-functions) + symlist) + + ;; Send the WHOIS command. + (erc-cmd-WHOIS nick) + + ;; Remove the uninterned symbols from the server hooks that did not run. + (run-at-time 20 nil (lambda (buf symlist) + (with-current-buffer buf + (dolist (sym symlist) + (let ((hooksym (cdr sym)) + (funcsym (car sym))) + (remove-hook hooksym funcsym t))))) + (current-buffer) symlist))) t) (defun erc-cmd-DESCRIBE (line) @@ -3690,11 +3655,12 @@ (erc-with-server-buffer (erc-once-with-server-event 368 - `(with-current-buffer ,chnl-name + (lambda (_proc _parsed) + (with-current-buffer chnl-name (put 'erc-channel-banlist 'received-from-server t) - (setq erc-server-367-functions ',old-367-hook) + (setq erc-server-367-functions old-367-hook) (erc-cmd-BANLIST) - t)) + t))) (erc-server-send (format "MODE %s b" chnl))))) ((null erc-channel-banlist) @@ -3756,28 +3722,29 @@ ((not (get 'erc-channel-banlist 'received-from-server)) (let ((old-367-hook erc-server-367-functions)) (setq erc-server-367-functions 'erc-banlist-store) - ;; fetch the ban list then callback - (erc-with-server-buffer - (erc-once-with-server-event - 368 - `(with-current-buffer ,chnl - (put 'erc-channel-banlist 'received-from-server t) - (setq erc-server-367-functions ,old-367-hook) - (erc-cmd-MASSUNBAN) - t)) - (erc-server-send (format "MODE %s b" chnl))))) + ;; fetch the ban list then callback + (erc-with-server-buffer + (erc-once-with-server-event + 368 + (lambda (_proc _parsed) + (with-current-buffer chnl + (put 'erc-channel-banlist 'received-from-server t) + (setq erc-server-367-functions old-367-hook) + (erc-cmd-MASSUNBAN) + t))) + (erc-server-send (format "MODE %s b" chnl))))) (t (let ((bans (mapcar 'cdr erc-channel-banlist))) - (when bans - ;; Glob the bans into groups of three, and carry out the unban. - ;; eg. /mode #foo -bbb a*!*@* b*!*@* c*!*@* - (mapc - (lambda (x) - (erc-server-send - (format "MODE %s -%s %s" (erc-default-target) - (make-string (length x) ?b) + (when bans + ;; Glob the bans into groups of three, and carry out the unban. + ;; eg. /mode #foo -bbb a*!*@* b*!*@* c*!*@* + (mapc + (lambda (x) + (erc-server-send + (format "MODE %s -%s %s" (erc-default-target) + (make-string (length x) ?b) (mapconcat 'identity x " ")))) - (erc-group-list bans 3)))) + (erc-group-list bans 3)))) t)))) (defalias 'erc-cmd-MUB 'erc-cmd-MASSUNBAN) @@ -3933,9 +3900,9 @@ (format "Limit for %s (RET to remove limit): " (erc-default-target))))) (let ((tgt (erc-default-target))) - (if (and limit (>= (length limit) 1)) - (erc-server-send (format "MODE %s +l %s" tgt limit)) - (erc-server-send (format "MODE %s -l" tgt))))) + (erc-server-send (if (and limit (>= (length limit) 1)) + (format "MODE %s +l %s" tgt limit) + (format "MODE %s -l" tgt))))) (defun erc-set-channel-key (&optional key) "Set a KEY for the current channel. Remove key if nil. @@ -3944,9 +3911,9 @@ (format "Key for %s (RET to remove key): " (erc-default-target))))) (let ((tgt (erc-default-target))) - (if (and key (>= (length key) 1)) - (erc-server-send (format "MODE %s +k %s" tgt key)) - (erc-server-send (format "MODE %s -k" tgt))))) + (erc-server-send (if (and key (>= (length key) 1)) + (format "MODE %s +k %s" tgt key) + (format "MODE %s -k" tgt))))) (defun erc-quit-server (reason) "Disconnect from current server after prompting for REASON. @@ -4023,7 +3990,7 @@ See `erc-debug-missing-hooks'.") ;(make-variable-buffer-local 'erc-server-vectors) -(defun erc-debug-missing-hooks (proc parsed) +(defun erc-debug-missing-hooks (_proc parsed) "Add PARSED server message ERC does not yet handle to `erc-server-vectors'. These vectors can be helpful when adding new server message handlers to ERC. See `erc-default-server-hook'." @@ -4163,7 +4130,7 @@ and as second argument the event parsed as a vector." :group 'erc-hooks) -(defun erc-display-server-message (proc parsed) +(defun erc-display-server-message (_proc parsed) "Display the message sent by the server as a notice." (erc-display-message parsed 'notice 'active (erc-response.contents parsed))) @@ -4219,7 +4186,7 @@ :group 'erc-display :type 'function) -(defun erc-format-nick (&optional user channel-data) +(defun erc-format-nick (&optional user _channel-data) "Return the nickname of USER. See also `erc-format-nick-function'." (when user (erc-server-user-nickname user))) @@ -4247,7 +4214,7 @@ (let ((prefix "> ")) (erc-propertize prefix 'face 'erc-default-face)))) -(defun erc-echo-notice-in-default-buffer (s parsed buffer sender) +(defun erc-echo-notice-in-default-buffer (s parsed buffer _sender) "Echos a private notice in the default buffer, namely the target buffer specified by BUFFER, or there is no target buffer, the server buffer. This function is designed to be added to @@ -4256,7 +4223,7 @@ (erc-display-message parsed nil buffer s) t) -(defun erc-echo-notice-in-target-buffer (s parsed buffer sender) +(defun erc-echo-notice-in-target-buffer (s parsed buffer _sender) "Echos a private notice in BUFFER, if BUFFER is non-nil. This function is designed to be added to either `erc-echo-notice-hook' or `erc-echo-notice-always-hook', and returns non-nil if BUFFER @@ -4265,21 +4232,21 @@ (progn (erc-display-message parsed nil buffer s) t) nil)) -(defun erc-echo-notice-in-minibuffer (s parsed buffer sender) +(defun erc-echo-notice-in-minibuffer (s _parsed _buffer _sender) "Echos a private notice in the minibuffer. This function is designed to be added to either `erc-echo-notice-hook' or `erc-echo-notice-always-hook', and always returns t." (message "%s" (concat "NOTICE: " s)) t) -(defun erc-echo-notice-in-server-buffer (s parsed buffer sender) +(defun erc-echo-notice-in-server-buffer (s parsed _buffer _sender) "Echos a private notice in the server buffer. This function is designed to be added to either `erc-echo-notice-hook' or `erc-echo-notice-always-hook', and always returns t." (erc-display-message parsed nil nil s) t) -(defun erc-echo-notice-in-active-non-server-buffer (s parsed buffer sender) +(defun erc-echo-notice-in-active-non-server-buffer (s parsed _buffer _sender) "Echos a private notice in the active buffer if the active buffer is not the server buffer. This function is designed to be added to either `erc-echo-notice-hook' or @@ -4289,14 +4256,14 @@ (progn (erc-display-message parsed nil 'active s) t) nil)) -(defun erc-echo-notice-in-active-buffer (s parsed buffer sender) +(defun erc-echo-notice-in-active-buffer (s parsed _buffer _sender) "Echos a private notice in the active buffer. This function is designed to be added to either `erc-echo-notice-hook' or `erc-echo-notice-always-hook', and always returns t." (erc-display-message parsed nil 'active s) t) -(defun erc-echo-notice-in-user-buffers (s parsed buffer sender) +(defun erc-echo-notice-in-user-buffers (s parsed _buffer sender) "Echos a private notice in all of the buffers for which SENDER is a member. This function is designed to be added to either `erc-echo-notice-hook' or `erc-echo-notice-always-hook', and @@ -4321,12 +4288,12 @@ See also: `erc-echo-notice-in-user-buffers', `erc-buffer-list-with-nick'." (let ((buffers (erc-buffer-list-with-nick sender erc-server-process))) - (add-to-list 'buffers buffer) - (if buffers + (unless (memq buffer buffers) (push buffer buffers)) + (if buffers ;FIXME: How could it be nil? (progn (erc-display-message parsed nil buffers s) t) nil))) -(defun erc-echo-notice-in-first-user-buffer (s parsed buffer sender) +(defun erc-echo-notice-in-first-user-buffer (s parsed _buffer sender) "Echos a private notice in one of the buffers for which SENDER is a member. This function is designed to be added to either `erc-echo-notice-hook' or `erc-echo-notice-always-hook', and @@ -4504,7 +4471,7 @@ (defvar erc-ctcp-query-CLIENTINFO-hook '(erc-ctcp-query-CLIENTINFO)) -(defun erc-ctcp-query-CLIENTINFO (proc nick login host to msg) +(defun erc-ctcp-query-CLIENTINFO (_proc nick _login _host _to msg) "Respond to a CTCP CLIENTINFO query." (when (string-match "^CLIENTINFO\\(\\s-*\\|\\s-+.*\\)$" msg) (let ((s (erc-client-info (erc-trim-string (match-string 1 msg))))) @@ -4513,7 +4480,7 @@ nil) (defvar erc-ctcp-query-ECHO-hook '(erc-ctcp-query-ECHO)) -(defun erc-ctcp-query-ECHO (proc nick login host to msg) +(defun erc-ctcp-query-ECHO (_proc nick _login _host _to msg) "Respond to a CTCP ECHO query." (when (string-match "^ECHO\\s-+\\(.*\\)\\s-*$" msg) (let ((s (match-string 1 msg))) @@ -4522,7 +4489,7 @@ nil) (defvar erc-ctcp-query-FINGER-hook '(erc-ctcp-query-FINGER)) -(defun erc-ctcp-query-FINGER (proc nick login host to msg) +(defun erc-ctcp-query-FINGER (_proc nick _login _host _to _msg) "Respond to a CTCP FINGER query." (unless erc-disable-ctcp-replies (let ((s (if erc-anonymous-login @@ -4538,7 +4505,7 @@ nil) (defvar erc-ctcp-query-PING-hook '(erc-ctcp-query-PING)) -(defun erc-ctcp-query-PING (proc nick login host to msg) +(defun erc-ctcp-query-PING (_proc nick _login _host _to msg) "Respond to a CTCP PING query." (when (string-match "^PING\\s-+\\(.*\\)" msg) (unless erc-disable-ctcp-replies @@ -4547,21 +4514,21 @@ nil) (defvar erc-ctcp-query-TIME-hook '(erc-ctcp-query-TIME)) -(defun erc-ctcp-query-TIME (proc nick login host to msg) +(defun erc-ctcp-query-TIME (_proc nick _login _host _to _msg) "Respond to a CTCP TIME query." (unless erc-disable-ctcp-replies (erc-send-ctcp-notice nick (format "TIME %s" (current-time-string)))) nil) (defvar erc-ctcp-query-USERINFO-hook '(erc-ctcp-query-USERINFO)) -(defun erc-ctcp-query-USERINFO (proc nick login host to msg) +(defun erc-ctcp-query-USERINFO (_proc nick _login _host _to _msg) "Respond to a CTCP USERINFO query." (unless erc-disable-ctcp-replies (erc-send-ctcp-notice nick (format "USERINFO %s" erc-user-information))) nil) (defvar erc-ctcp-query-VERSION-hook '(erc-ctcp-query-VERSION)) -(defun erc-ctcp-query-VERSION (proc nick login host to msg) +(defun erc-ctcp-query-VERSION (_proc nick _login _host _to _msg) "Respond to a CTCP VERSION query." (unless erc-disable-ctcp-replies (erc-send-ctcp-notice @@ -4584,7 +4551,7 @@ 'CTCP-UNKNOWN ?n nick ?u login ?h host ?m msg)))) (defvar erc-ctcp-reply-ECHO-hook '(erc-ctcp-reply-ECHO)) -(defun erc-ctcp-reply-ECHO (proc nick login host to msg) +(defun erc-ctcp-reply-ECHO (_proc nick _login _host _to msg) "Handle a CTCP ECHO reply." (when (string-match "^ECHO\\s-+\\(.*\\)\\s-*$" msg) (let ((message (match-string 1 msg))) @@ -4594,7 +4561,7 @@ nil) (defvar erc-ctcp-reply-CLIENTINFO-hook '(erc-ctcp-reply-CLIENTINFO)) -(defun erc-ctcp-reply-CLIENTINFO (proc nick login host to msg) +(defun erc-ctcp-reply-CLIENTINFO (_proc nick _login _host _to msg) "Handle a CTCP CLIENTINFO reply." (when (string-match "^CLIENTINFO\\s-+\\(.*\\)\\s-*$" msg) (let ((message (match-string 1 msg))) @@ -4604,7 +4571,7 @@ nil) (defvar erc-ctcp-reply-FINGER-hook '(erc-ctcp-reply-FINGER)) -(defun erc-ctcp-reply-FINGER (proc nick login host to msg) +(defun erc-ctcp-reply-FINGER (_proc nick _login _host _to msg) "Handle a CTCP FINGER reply." (when (string-match "^FINGER\\s-+\\(.*\\)\\s-*$" msg) (let ((message (match-string 1 msg))) @@ -4614,7 +4581,7 @@ nil) (defvar erc-ctcp-reply-PING-hook '(erc-ctcp-reply-PING)) -(defun erc-ctcp-reply-PING (proc nick login host to msg) +(defun erc-ctcp-reply-PING (_proc nick _login _host _to msg) "Handle a CTCP PING reply." (if (not (string-match "^PING\\s-+\\([0-9.]+\\)" msg)) nil @@ -4632,7 +4599,7 @@ 'bad-ping-response ?n nick ?t time)))))) (defvar erc-ctcp-reply-TIME-hook '(erc-ctcp-reply-TIME)) -(defun erc-ctcp-reply-TIME (proc nick login host to msg) +(defun erc-ctcp-reply-TIME (_proc nick _login _host _to msg) "Handle a CTCP TIME reply." (when (string-match "^TIME\\s-+\\(.*\\)\\s-*$" msg) (let ((message (match-string 1 msg))) @@ -4642,7 +4609,7 @@ nil) (defvar erc-ctcp-reply-VERSION-hook '(erc-ctcp-reply-VERSION)) -(defun erc-ctcp-reply-VERSION (proc nick login host to msg) +(defun erc-ctcp-reply-VERSION (_proc nick _login _host _to msg) "Handle a CTCP VERSION reply." (when (string-match "^VERSION\\s-+\\(.*\\)\\s-*$" msg) (let ((message (match-string 1 msg))) @@ -4705,7 +4672,7 @@ channel buffer. See also `erc-channel-begin-receiving-names'." - (maphash (lambda (nick user) + (maphash (lambda (nick _user) (if (null (gethash nick erc-channel-new-member-names)) (erc-remove-channel-user nick))) erc-channel-users) @@ -4746,8 +4713,7 @@ (setq names (delete "" (split-string names-string))) (let ((erc-channel-members-changed-hook nil)) (dolist (item names) - (let ((updatep t) - ch) + (let ((updatep t)) (if (rassq (elt item 0) prefix) (cond ((= (length item) 1) (setq updatep nil)) @@ -4780,8 +4746,7 @@ (defun erc-update-user-nick (nick &optional new-nick host login full-name info) - "Updates the stored user information for the user with nickname -NICK. + "Update the stored user information for the user with nickname NICK. See also: `erc-update-user'." (erc-update-user (erc-get-server-user nick) new-nick @@ -4831,8 +4796,8 @@ (defun erc-update-current-channel-member (nick new-nick &optional add op voice host login full-name info update-message-time) - "Updates the stored user information for the user with nickname -NICK. `erc-update-user' is called to handle changes to nickname, + "Update the stored user information for the user with nickname NICK. +`erc-update-user' is called to handle changes to nickname, HOST, LOGIN, FULL-NAME, and INFO. If OP or VOICE are non-nil, they must be equal to either `on' or `off', in which case the operator or voice status of the user in the current channel is @@ -4850,7 +4815,7 @@ See also: `erc-update-user' and `erc-update-channel-member'." (let* (changed user-changed (channel-data (erc-get-channel-user nick)) - (cuser (if channel-data (cdr channel-data))) + (cuser (cdr channel-data)) (user (if channel-data (car channel-data) (erc-get-server-user nick)))) (if cuser @@ -4908,7 +4873,7 @@ (defun erc-update-channel-member (channel nick new-nick &optional add op voice host login full-name info update-message-time) - "Updates user and channel information for the user with + "Update user and channel information for the user with nickname NICK in channel CHANNEL. See also: `erc-update-current-channel-member'." @@ -4951,7 +4916,6 @@ "Set the modes for the TGT provided as MODE-STRING." (let* ((modes (erc-parse-modes mode-string)) (add-modes (nth 0 modes)) - (remove-modes (nth 1 modes)) ;; list of triples: (mode-char 'on/'off argument) (arg-modes (nth 2 modes))) (cond ((erc-channel-p tgt); channel modes @@ -5040,6 +5004,7 @@ "Update the mode information for TGT, provided as MODE-STRING. Optional arguments: NICK, HOST and LOGIN - the attributes of the person who changed the modes." + ;; FIXME: neither of nick, host, and login are used! (let* ((modes (erc-parse-modes mode-string)) (add-modes (nth 0 modes)) (remove-modes (nth 1 modes)) @@ -5197,8 +5162,7 @@ If VALUE-LIST is nil, set each property in PROPERTIES to t, else set each property to the corresponding value in VALUE-LIST." (unless value-list - (setq value-list (mapcar (lambda (x) - t) + (setq value-list (mapcar (lambda (_x) t) properties))) (while (and properties value-list) (erc-put-text-property @@ -5290,7 +5254,7 @@ "Regular expression used for matching commands in ERC.") (defun erc-send-input (input) - "Treat INPUT as typed in by the user. It is assumed that the input + "Treat INPUT as typed in by the user. It is assumed that the input and the prompt is already deleted. This returns non-nil only if we actually send anything." ;; Handle different kinds of inputs @@ -5380,8 +5344,8 @@ (when (string-match erc-command-regexp line) (let* ((cmd (erc-command-symbol (match-string 1 line))) ;; note: return is nil, we apply this simply for side effects - (canon-defun (while (and cmd (symbolp (symbol-function cmd))) - (setq cmd (symbol-function cmd)))) + (_canon-defun (while (and cmd (symbolp (symbol-function cmd))) + (setq cmd (symbol-function cmd)))) (cmd-fun (or cmd #'erc-cmd-default)) (arg (if cmd (if (get cmd-fun 'do-not-parse-args) @@ -5449,22 +5413,18 @@ (defun erc-add-default-channel (channel) "Add CHANNEL to the default channel list." - - (let ((d1 (car erc-default-recipients)) - (d2 (cdr erc-default-recipients)) - (chl (downcase channel))) + (let ((chl (downcase channel))) (setq erc-default-recipients (cons chl erc-default-recipients)))) (defun erc-delete-default-channel (channel &optional buffer) "Delete CHANNEL from the default channel list." - (let ((ob (current-buffer))) - (with-current-buffer (if (and buffer - (bufferp buffer)) - buffer - (current-buffer)) - (setq erc-default-recipients (delete (downcase channel) - erc-default-recipients))))) + (with-current-buffer (if (and buffer + (bufferp buffer)) + buffer + (current-buffer)) + (setq erc-default-recipients (delete (downcase channel) + erc-default-recipients)))) (defun erc-add-query (nickname) "Add QUERY'd NICKNAME to the default channel list. @@ -5473,10 +5433,10 @@ (let ((d1 (car erc-default-recipients)) (d2 (cdr erc-default-recipients)) (qt (cons 'QUERY (downcase nickname)))) - (if (and (listp d1) - (eq (car d1) 'QUERY)) - (setq erc-default-recipients (cons qt d2)) - (setq erc-default-recipients (cons qt erc-default-recipients))))) + (setq erc-default-recipients (cons qt (if (and (listp d1) + (eq (car d1) 'QUERY)) + d2 + erc-default-recipients))))) (defun erc-delete-query () "Delete the topmost target if it is a QUERY." @@ -5527,17 +5487,11 @@ (let ((nick (erc-server-user-nickname user)) (host (erc-server-user-host user)) (login (erc-server-user-login user))) - (concat (if nick - nick - "") + (concat (or nick "") "!" - (if login - login - "") + (or login "") "@" - (if host - host - "")))) + (or host "")))) (defun erc-list-match (lst str) "Return non-nil if any regexp in LST matches STR." @@ -5588,7 +5542,7 @@ (interactive "P") (erc-set-active-buffer (current-buffer)) (let ((tgt (erc-default-target)) - (erc-force-send t)) + (erc-force-send t)) ;FIXME: Not used anywhere! (cond ((or (not tgt) (not (erc-channel-p tgt))) (erc-display-message nil 'error (current-buffer) 'no-target)) (arg (erc-load-irc-script-lines (list (concat "/mode " tgt " -i")) @@ -5626,7 +5580,7 @@ (interactive "P") (erc-set-active-buffer (current-buffer)) (let ((tgt (or channel (erc-default-target))) - (erc-force-send t)) + (erc-force-send t)) ;FIXME: Not used anywhere! (cond ((or (null tgt) (null (erc-channel-p tgt))) (erc-display-message nil 'error 'active 'no-target)) ((member mode erc-channel-modes) @@ -5670,12 +5624,11 @@ If FILE is found, return the path to it." (let ((filepath file)) (if (file-readable-p filepath) filepath - (progn - (while (and path - (progn (setq filepath (expand-file-name file (car path))) - (not (file-readable-p filepath)))) - (setq path (cdr path))) - (if path filepath nil))))) + (while (and path + (progn (setq filepath (expand-file-name file (car path))) + (not (file-readable-p filepath)))) + (setq path (cdr path))) + (if path filepath nil)))) (defun erc-select-startup-file () "Select an ERC startup file. @@ -5789,7 +5742,6 @@ sequences, process the lines verbatim. Use this for multiline user input." (let* ((cb (current-buffer)) - (pnt (point)) (s "") (sp (or (erc-command-indicator) (erc-prompt))) (args (and (boundp 'erc-script-args) erc-script-args))) @@ -6030,13 +5982,12 @@ (user (if channel-data (car channel-data) (erc-get-server-user word))) - host login full-name info nick op voice) + host login full-name nick op voice) (when user (setq nick (erc-server-user-nickname user) host (erc-server-user-host user) login (erc-server-user-login user) - full-name (erc-server-user-full-name user) - info (erc-server-user-info user)) + full-name (erc-server-user-full-name user)) (if cuser (setq op (erc-channel-user-op cuser) voice (erc-channel-user-voice cuser))) @@ -6048,7 +5999,7 @@ (format " and is +%s%s on %s" (if op "o" "") (if voice "v" "") - (erc-default-target)) + (erc-default-target)) "")) user)))) @@ -6597,7 +6548,7 @@ (add-hook 'kill-buffer-hook 'erc-kill-buffer-function) (defcustom erc-kill-server-hook '(erc-kill-server) - "Invoked whenever a server-buffer is killed via `kill-buffer'." + "Invoked whenever a server buffer is killed via `kill-buffer'." :group 'erc-hooks :type 'hook) @@ -6702,9 +6653,9 @@ (provide 'erc) -;;; Deprecated. We might eventually stop requiring the goodies automatically. -;;; IMPORTANT: This require must appear _after_ the above (provide 'erc) to -;;; avoid a recursive require error when byte-compiling the entire package. +;; Deprecated. We might eventually stop requiring the goodies automatically. +;; IMPORTANT: This require must appear _after_ the above (provide 'erc) to +;; avoid a recursive require error when byte-compiling the entire package. (require 'erc-goodies) ;;; erc.el ends here ------------------------------------------------------------ revno: 113970 committer: Stefan Monnier branch nick: trunk timestamp: Wed 2013-08-21 21:09:08 -0400 message: * lisp/calendar/timeclock.el: Minor cleanups. (timeclock-ask-before-exiting, timeclock-use-display-time): Use `symbol'. (timeclock-modeline-display): Define as alias before the actual definition. (timeclock-mode-line-display): Use define-minor-mode. (timeclock-day-list-template): Make it a function, add an argument. (timeclock-day-list-required, timeclock-day-list-length) (timeclock-day-list-debt, timeclock-day-list-span) (timeclock-day-list-break): Adjust calls accordingly. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-08-21 18:26:15 +0000 +++ lisp/ChangeLog 2013-08-22 01:09:08 +0000 @@ -1,3 +1,16 @@ +2013-08-22 Stefan Monnier + + * calendar/timeclock.el: Minor cleanups. + (timeclock-ask-before-exiting, timeclock-use-display-time): + Use `symbol'. + (timeclock-modeline-display): Define as alias before the + actual definition. + (timeclock-mode-line-display): Use define-minor-mode. + (timeclock-day-list-template): Make it a function, add an argument. + (timeclock-day-list-required, timeclock-day-list-length) + (timeclock-day-list-debt, timeclock-day-list-span) + (timeclock-day-list-break): Adjust calls accordingly. + 2013-08-21 Stefan Monnier * emacs-lisp/pp.el (pp-eval-expression, pp-macroexpand-expression): === modified file 'lisp/calendar/timeclock.el' --- lisp/calendar/timeclock.el 2013-03-12 02:08:21 +0000 +++ lisp/calendar/timeclock.el 2013-08-22 01:09:08 +0000 @@ -136,7 +136,7 @@ (if value (add-hook 'kill-emacs-query-functions 'timeclock-query-out) (remove-hook 'kill-emacs-query-functions 'timeclock-query-out)) - (setq timeclock-ask-before-exiting value)) + (set symbol value)) :type 'boolean :group 'timeclock) @@ -174,11 +174,12 @@ timeclock-update-timer))) (setq currently-displaying nil)) (and currently-displaying - (set-variable 'timeclock-mode-line-display nil)) - (setq timeclock-use-display-time value) + (setq timeclock-mode-line-display nil)) + (set symbol value) (and currently-displaying - (set-variable 'timeclock-mode-line-display t)) - timeclock-use-display-time)) + (setq timeclock-mode-line-display t)) + ;; FIXME: The return value isn't used, AFAIK! + value)) :type 'boolean :group 'timeclock :require 'time) @@ -269,9 +270,11 @@ (define-obsolete-function-alias 'timeclock-modeline-display 'timeclock-mode-line-display "24.3") +(define-obsolete-variable-alias 'timeclock-modeline-display + 'timeclock-mode-line-display "24.3") ;;;###autoload -(defun timeclock-mode-line-display (&optional arg) +(define-minor-mode timeclock-mode-line-display "Toggle display of the amount of time left today in the mode line. If `timeclock-use-display-time' is non-nil (the default), then the function `display-time-mode' must be active, and the mode line @@ -280,61 +283,41 @@ updating. With prefix ARG, turn mode line display on if and only if ARG is positive. Returns the new status of timeclock mode line display (non-nil means on)." - (interactive "P") + :global t ;; cf display-time-mode. (setq timeclock-mode-string "") (or global-mode-string (setq global-mode-string '(""))) - (let ((on-p (if arg - (> (prefix-numeric-value arg) 0) - (not timeclock-mode-line-display)))) - (if on-p - (progn - (or (memq 'timeclock-mode-string global-mode-string) - (setq global-mode-string - (append global-mode-string '(timeclock-mode-string)))) - (add-hook 'timeclock-event-hook 'timeclock-update-mode-line) - (when timeclock-update-timer - (cancel-timer timeclock-update-timer) - (setq timeclock-update-timer nil)) - (if (boundp 'display-time-hook) - (remove-hook 'display-time-hook 'timeclock-update-mode-line)) - (if timeclock-use-display-time - (progn - ;; Update immediately so there is a visible change - ;; on calling this function. - (if display-time-mode - (timeclock-update-mode-line) - (message "Activate `display-time-mode' or turn off \ + (if timeclock-mode-line-display + (progn + (or (memq 'timeclock-mode-string global-mode-string) + (setq global-mode-string + (append global-mode-string '(timeclock-mode-string)))) + (add-hook 'timeclock-event-hook 'timeclock-update-mode-line) + (when timeclock-update-timer + (cancel-timer timeclock-update-timer) + (setq timeclock-update-timer nil)) + (if (boundp 'display-time-hook) + (remove-hook 'display-time-hook 'timeclock-update-mode-line)) + (if timeclock-use-display-time + (progn + ;; Update immediately so there is a visible change + ;; on calling this function. + (if display-time-mode + (timeclock-update-mode-line) + (message "Activate `display-time-mode' or turn off \ `timeclock-use-display-time' to see timeclock information")) - (add-hook 'display-time-hook 'timeclock-update-mode-line)) - (setq timeclock-update-timer - (run-at-time nil 60 'timeclock-update-mode-line)))) - (setq global-mode-string - (delq 'timeclock-mode-string global-mode-string)) - (remove-hook 'timeclock-event-hook 'timeclock-update-mode-line) - (if (boundp 'display-time-hook) - (remove-hook 'display-time-hook - 'timeclock-update-mode-line)) - (when timeclock-update-timer - (cancel-timer timeclock-update-timer) - (setq timeclock-update-timer nil))) - (force-mode-line-update) - (setq timeclock-mode-line-display on-p))) - -(define-obsolete-variable-alias 'timeclock-modeline-display - 'timeclock-mode-line-display "24.3") - -;; This has to be here so that the function definition of -;; `timeclock-mode-line-display' is known to the "set" function. -(defcustom timeclock-mode-line-display nil - "Toggle mode line display of time remaining. -You must modify via \\[customize] for this variable to have an effect." - :set (lambda (symbol value) - (setq timeclock-mode-line-display - (timeclock-mode-line-display (or value 0)))) - :type 'boolean - :group 'timeclock - :require 'timeclock) + (add-hook 'display-time-hook 'timeclock-update-mode-line)) + (setq timeclock-update-timer + (run-at-time nil 60 'timeclock-update-mode-line)))) + (setq global-mode-string + (delq 'timeclock-mode-string global-mode-string)) + (remove-hook 'timeclock-event-hook 'timeclock-update-mode-line) + (if (boundp 'display-time-hook) + (remove-hook 'display-time-hook + 'timeclock-update-mode-line)) + (when timeclock-update-timer + (cancel-timer timeclock-update-timer) + (setq timeclock-update-timer nil)))) (defsubst timeclock-time-to-date (time) "Convert the TIME value to a textual date string." @@ -835,25 +818,24 @@ "Return a list of all the projects in DAY." (timeclock-entry-list-projects (cddr day))) -(defmacro timeclock-day-list-template (func) +(defun timeclock-day-list-template (func day-list) "Template for summing the result of FUNC on each element of DAY-LIST." - `(let ((length 0)) - (while day-list - (setq length (+ length (,(eval func) (car day-list))) - day-list (cdr day-list))) - length)) + (let ((length 0)) + (dolist (day day-list) + (setq length (+ length (funcall func day)))) + length)) (defun timeclock-day-list-required (day-list) "Return total required length of DAY-LIST, in seconds." - (timeclock-day-list-template 'timeclock-day-required)) + (timeclock-day-list-template #'timeclock-day-required day-list)) (defun timeclock-day-list-length (day-list) "Return actual length of DAY-LIST, in seconds." - (timeclock-day-list-template 'timeclock-day-length)) + (timeclock-day-list-template #'timeclock-day-length day-list)) (defun timeclock-day-list-debt (day-list) "Return total debt (required - actual) of DAY-LIST." - (timeclock-day-list-template 'timeclock-day-debt)) + (timeclock-day-list-template #'timeclock-day-debt day-list)) (defsubst timeclock-day-list-begin (day-list) "Return the start time of DAY-LIST." @@ -865,11 +847,11 @@ (defun timeclock-day-list-span (day-list) "Return the span of DAY-LIST." - (timeclock-day-list-template 'timeclock-day-span)) + (timeclock-day-list-template #'timeclock-day-span day-list)) (defun timeclock-day-list-break (day-list) "Return the total break of DAY-LIST." - (timeclock-day-list-template 'timeclock-day-break)) + (timeclock-day-list-template #'timeclock-day-break day-list)) (defun timeclock-day-list-projects (day-list) "Return a list of all the projects in DAY-LIST." ------------------------------------------------------------ revno: 113969 fixes bug: http://debbugs.gnu.org/15144 committer: Paul Eggert branch nick: trunk timestamp: Wed 2013-08-21 14:27:30 -0700 message: * callproc.c: Fix race that killed background processes. (call_process): New arg TEMPFILE_INDEX. Callers changed. Record deleted process-id in critical section, not afterwards. Don't mistakenly kill process created by a call-process invocation that discards output and does not wait. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-08-21 07:02:45 +0000 +++ src/ChangeLog 2013-08-21 21:27:30 +0000 @@ -1,3 +1,11 @@ +2013-08-21 Paul Eggert + + * callproc.c: Fix race that killed background processes (Bug#15144). + (call_process): New arg TEMPFILE_INDEX. Callers changed. + Record deleted process-id in critical section, not afterwards. + Don't mistakenly kill process created by a call-process invocation + that discards output and does not wait. + 2013-08-21 Dmitry Antipov Fix compilation with GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE === modified file 'src/callproc.c' --- src/callproc.c 2013-08-12 07:12:07 +0000 +++ src/callproc.c 2013-08-21 21:27:30 +0000 @@ -102,7 +102,7 @@ CALLPROC_FDS }; -static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int); +static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int, ptrdiff_t); /* Block SIGCHLD. */ @@ -248,14 +248,20 @@ report_file_error ("Opening process input file", infile); record_unwind_protect_int (close_file_unwind, filefd); UNGCPRO; - return unbind_to (count, call_process (nargs, args, filefd)); + return unbind_to (count, call_process (nargs, args, filefd, -1)); } /* Like Fcall_process (NARGS, ARGS), except use FILEFD as the input file. + + If TEMPFILE_INDEX is nonnegative, it is the specpdl index of an + unwinder that is intended to remove the input temporary file; in + this case NARGS must be at least 2 and ARGS[1] is the file's name. + At entry, the specpdl stack top entry must be close_file_unwind (FILEFD). */ static Lisp_Object -call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd) +call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, + ptrdiff_t tempfile_index) { Lisp_Object buffer, current_dir, path; bool display_p; @@ -661,7 +667,22 @@ child_errno = errno; if (pid > 0) - synch_process_pid = pid; + { + synch_process_pid = pid; + + if (INTEGERP (buffer)) + { + if (tempfile_index < 0) + record_deleted_pid (pid, Qnil); + else + { + eassert (1 < nargs); + record_deleted_pid (pid, args[1]); + clear_unwind_protect (tempfile_index); + } + synch_process_pid = 0; + } + } unblock_child_signal (); unblock_input (); @@ -1030,7 +1051,7 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { - struct gcpro gcpro1, gcpro2; + struct gcpro gcpro1; Lisp_Object infile, val; ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object start = args[0]; @@ -1061,8 +1082,7 @@ record_unwind_protect_int (close_file_unwind, fd); } - val = infile; - GCPRO2 (infile, val); + GCPRO1 (infile); if (nargs > 3 && !NILP (args[3])) Fdelete_region (start, end); @@ -1079,16 +1099,7 @@ } args[1] = infile; - val = call_process (nargs, args, fd); - - if (!empty_input && 4 < nargs - && (INTEGERP (CONSP (args[4]) ? XCAR (args[4]) : args[4]))) - { - record_deleted_pid (synch_process_pid, infile); - synch_process_pid = 0; - clear_unwind_protect (count); - } - + val = call_process (nargs, args, fd, empty_input ? -1 : count); RETURN_UNGCPRO (unbind_to (count, val)); } ------------------------------------------------------------ revno: 113968 committer: David Engster branch nick: trunk timestamp: Wed 2013-08-21 21:42:52 +0200 message: Imported EIEIO test suite from CEDET upstream * automated/eieio-tests.el, automated/eieio-test-persist.el: * automated/eieio-test-methodinvoke.el: EIEIO tests from CEDET upstream. Changed to use ERT. diff: === modified file 'test/ChangeLog' --- test/ChangeLog 2013-08-14 00:56:58 +0000 +++ test/ChangeLog 2013-08-21 19:42:52 +0000 @@ -1,3 +1,9 @@ +2013-08-21 David Engster + + * automated/eieio-tests.el, automated/eieio-test-persist.el: + * automated/eieio-test-methodinvoke.el: EIEIO tests from CEDET + upstream. Changed to use ERT. + 2013-08-14 Daniel Hackney * package-test.el: Remove tar-package-building functions. Tar file === added file 'test/automated/eieio-test-methodinvoke.el' --- test/automated/eieio-test-methodinvoke.el 1970-01-01 00:00:00 +0000 +++ test/automated/eieio-test-methodinvoke.el 2013-08-21 19:42:52 +0000 @@ -0,0 +1,379 @@ +;;; eieio-testsinvoke.el -- eieio tests for method invokation + +;; Copyright (C) 2005, 2008, 2010, 2013 Free Software Foundation, Inc. + +;; Author: Eric. M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Test method invocation order. From the common lisp reference +;; manual: +;; +;; QUOTE: +;; - All the :before methods are called, in most-specific-first +;; order. Their values are ignored. An error is signaled if +;; call-next-method is used in a :before method. +;; +;; - The most specific primary method is called. Inside the body of a +;; primary method, call-next-method may be used to call the next +;; most specific primary method. When that method returns, the +;; previous primary method can execute more code, perhaps based on +;; the returned value or values. The generic function no-next-method +;; is invoked if call-next-method is used and there are no more +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If +;; call-next-method is not used, only the most specific primary +;; method is called. +;; +;; - All the :after methods are called, in most-specific-last order. +;; Their values are ignored. An error is signaled if +;; call-next-method is used in a :after method. +;; +;; +;; Also test behavior of `call-next-method'. From clos.org: +;; +;; QUOTE: +;; When call-next-method is called with no arguments, it passes the +;; current method's original arguments to the next method. + +(require 'eieio) +(require 'ert) + +(defvar eieio-test-method-order-list nil + "List of symbols stored during method invocation.") + +(defun eieio-test-method-store () + "Store current invocation class symbol in the invocation order list." + (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ] + (or eieio-generic-call-key 0))) + (c (list eieio-generic-call-methodname keysym (eieio--scoped-class)))) + (setq eieio-test-method-order-list + (cons c eieio-test-method-order-list)))) + +(defun eieio-test-match (rightanswer) + "Do a test match." + (if (equal rightanswer eieio-test-method-order-list) + t + (error "eieio-test-methodinvoke.el: Test Failed!"))) + +(defvar eieio-test-call-next-method-arguments nil + "List of passed to methods during execution of `call-next-method'.") + +(defun eieio-test-arguments-for (class) + "Returns arguments passed to method of CLASS during `call-next-method'." + (cdr (assoc class eieio-test-call-next-method-arguments))) + +(defclass eitest-A () ()) +(defclass eitest-AA (eitest-A) ()) +(defclass eitest-AAA (eitest-AA) ()) +(defclass eitest-B-base1 () ()) +(defclass eitest-B-base2 () ()) +(defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) + +(defmethod eitest-F :BEFORE ((p eitest-B-base1)) + (eieio-test-method-store)) + +(defmethod eitest-F :BEFORE ((p eitest-B-base2)) + (eieio-test-method-store)) + +(defmethod eitest-F :BEFORE ((p eitest-B)) + (eieio-test-method-store)) + +(defmethod eitest-F ((p eitest-B)) + (eieio-test-method-store) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base1)) + (eieio-test-method-store) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base2)) + (eieio-test-method-store) + (when (next-method-p) + (call-next-method)) + ) + +(defmethod eitest-F :AFTER ((p eitest-B-base1)) + (eieio-test-method-store)) + +(defmethod eitest-F :AFTER ((p eitest-B-base2)) + (eieio-test-method-store)) + +(defmethod eitest-F :AFTER ((p eitest-B)) + (eieio-test-method-store)) + +(ert-deftest eieio-test-method-order-list-3 () + (let ((eieio-test-method-order-list nil) + (ans '( + (eitest-F :BEFORE eitest-B) + (eitest-F :BEFORE eitest-B-base1) + (eitest-F :BEFORE eitest-B-base2) + + (eitest-F :PRIMARY eitest-B) + (eitest-F :PRIMARY eitest-B-base1) + (eitest-F :PRIMARY eitest-B-base2) + + (eitest-F :AFTER eitest-B-base2) + (eitest-F :AFTER eitest-B-base1) + (eitest-F :AFTER eitest-B) + ))) + (eitest-F (eitest-B nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Test static invokation +;; +(defmethod eitest-H :STATIC ((class eitest-A)) + "No need to do work in here." + 'moose) + +(ert-deftest eieio-test-method-order-list-4 () + ;; Both of these situations should succeed. + (should (eitest-H eitest-A)) + (should (eitest-H (eitest-A nil)))) + +;;; Return value from :PRIMARY +;; +(defmethod eitest-I :BEFORE ((a eitest-A)) + (eieio-test-method-store) + ":before") + +(defmethod eitest-I :PRIMARY ((a eitest-A)) + (eieio-test-method-store) + ":primary") + +(defmethod eitest-I :AFTER ((a eitest-A)) + (eieio-test-method-store) + ":after") + +(ert-deftest eieio-test-method-order-list-5 () + (let ((eieio-test-method-order-list nil) + (ans (eitest-I (eitest-A nil)))) + (should (string= ans ":primary")))) + +;;; Multiple inheritance and the 'constructor' method. +;; +;; Constructor is a static method, so this is really testing +;; static method invocation and multiple inheritance. +;; +(defclass C-base1 () ()) +(defclass C-base2 () ()) +(defclass C (C-base1 C-base2) ()) + +(defmethod constructor :STATIC ((p C-base1) &rest args) + (eieio-test-method-store) + (if (next-method-p) (call-next-method)) + ) + +(defmethod constructor :STATIC ((p C-base2) &rest args) + (eieio-test-method-store) + (if (next-method-p) (call-next-method)) + ) + +(defmethod constructor :STATIC ((p C) &rest args) + (eieio-test-method-store) + (call-next-method) + ) + +(ert-deftest eieio-test-method-order-list-6 () + (let ((eieio-test-method-order-list nil) + (ans '( + (constructor :STATIC C) + (constructor :STATIC C-base1) + (constructor :STATIC C-base2) + ))) + (C nil) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Diamond Test +;; +;; For a diamond shaped inheritance structure, (call-next-method) can break. +;; As such, there are two possible orders. + +(defclass D-base0 () () :method-invocation-order :depth-first) +(defclass D-base1 (D-base0) () :method-invocation-order :depth-first) +(defclass D-base2 (D-base0) () :method-invocation-order :depth-first) +(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) + +(defmethod eitest-F ((p D)) + "D" + (eieio-test-method-store) + (call-next-method)) + +(defmethod eitest-F ((p D-base0)) + "D-base0" + (eieio-test-method-store) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p D-base1)) + "D-base1" + (eieio-test-method-store) + (call-next-method)) + +(defmethod eitest-F ((p D-base2)) + "D-base2" + (eieio-test-method-store) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-7 () + (let ((eieio-test-method-order-list nil) + (ans '( + (eitest-F :PRIMARY D) + (eitest-F :PRIMARY D-base1) + ;; (eitest-F :PRIMARY D-base2) + (eitest-F :PRIMARY D-base0) + ))) + (eitest-F (D nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Other invocation order + +(defclass E-base0 () () :method-invocation-order :breadth-first) +(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first) +(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) +(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) + +(defmethod eitest-F ((p E)) + (eieio-test-method-store) + (call-next-method)) + +(defmethod eitest-F ((p E-base0)) + (eieio-test-method-store) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p E-base1)) + (eieio-test-method-store) + (call-next-method)) + +(defmethod eitest-F ((p E-base2)) + (eieio-test-method-store) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-8 () + (let ((eieio-test-method-order-list nil) + (ans '( + (eitest-F :PRIMARY E) + (eitest-F :PRIMARY E-base1) + (eitest-F :PRIMARY E-base2) + (eitest-F :PRIMARY E-base0) + ))) + (eitest-F (E nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Jan's methodinvoke order w/ multiple inheritance and :after methods. +;; +(defclass eitest-Ja () + ()) + +(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) + ;(message "+Ja") + (when (next-method-p) + (call-next-method)) + ;(message "-Ja") + ) + +(defclass eitest-Jb () + ()) + +(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) + ;(message "+Jb") + (when (next-method-p) + (call-next-method)) + ;(message "-Jb") + ) + +(defclass eitest-Jc (eitest-Jb) + ()) + +(defclass eitest-Jd (eitest-Jc eitest-Ja) + ()) + +(defmethod initialize-instance ((this eitest-Jd) &rest slots) + ;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;(message "-Jd") + ) + +(ert-deftest eieio-test-method-order-list-9 () + (should (eitest-Jd "test"))) + +;;; call-next-method with replacement arguments across a simple class hierarchy. +;; + +(defclass CNM-0 () + ()) + +(defclass CNM-1-1 (CNM-0) + ()) + +(defclass CNM-1-2 (CNM-0) + ()) + +(defclass CNM-2 (CNM-1-1 CNM-1-2) + ()) + +(defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + +(defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + +(defmethod CNM-M ((this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + +(defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args)))) + +(ert-deftest eieio-test-method-order-list-10 () + (let ((eieio-test-call-next-method-arguments nil)) + (CNM-M (CNM-2 "") '(INIT)) + (should (equal (eieio-test-arguments-for 'CNM-0) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-1) + '(CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-2) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-2) + '(INIT))))) === added file 'test/automated/eieio-test-persist.el' --- test/automated/eieio-test-persist.el 1970-01-01 00:00:00 +0000 +++ test/automated/eieio-test-persist.el 2013-08-21 19:42:52 +0000 @@ -0,0 +1,213 @@ +;;; eieio-persist.el --- Tests for eieio-persistent class + +;; Copyright (C) 2011-2013 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; The eieio-persistent base-class provides a vital service, that +;; could be used to accidentally load in malicious code. As such, +;; something as simple as calling eval on the generated code can't be +;; used. These tests exercises various flavors of data that might be +;; in a persistent object, and tries to save/load them. + +;;; Code: +(require 'eieio) +(require 'eieio-base) +(require 'ert) + +(defun persist-test-save-and-compare (original) + "Compare the object ORIGINAL against the one read fromdisk." + + (eieio-persistent-save original) + + (let* ((file (oref original :file)) + (class (eieio-object-class original)) + (fromdisk (eieio-persistent-read file class)) + (cv (class-v class)) + (slot-names (eieio--class-public-a cv)) + (slot-deflt (eieio--class-public-d cv)) + ) + (unless (object-of-class-p fromdisk class) + (error "Persistent class %S != original class %S" + (eieio-object-class fromdisk) + class)) + + (while slot-names + (let* ((oneslot (car slot-names)) + (origvalue (eieio-oref original oneslot)) + (fromdiskvalue (eieio-oref fromdisk oneslot)) + (initarg-p (eieio-attribute-to-initarg class oneslot)) + ) + + (if initarg-p + (unless (equal origvalue fromdiskvalue) + (error "Slot %S Original Val %S != Persistent Val %S" + oneslot origvalue fromdiskvalue)) + ;; Else !initarg-p + (unless (equal (car slot-deflt) fromdiskvalue) + (error "Slot %S Persistent Val %S != Default Value %S" + oneslot fromdiskvalue (car slot-deflt)))) + + (setq slot-names (cdr slot-names) + slot-deflt (cdr slot-deflt)) + )))) + +;;; Simple Case +;; +;; Simplest case is a mix of slots with and without initargs. + +(defclass persist-simple (eieio-persistent) + ((slot1 :initarg :slot1 + :type symbol + :initform moose) + (slot2 :initarg :slot2 + :initform "foo") + (slot3 :initform 2)) + "A Persistent object with two initializable slots, and one not.") + +(ert-deftest eieio-test-persist-simple-1 () + (let ((persist-simple-1 + (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps1.pt")))) + (should persist-simple-1) + + ;; When the slot w/out an initarg has not been changed + (persist-test-save-and-compare persist-simple-1) + + ;; When the slot w/out an initarg HAS been changed + (oset persist-simple-1 slot3 3) + (persist-test-save-and-compare persist-simple-1) + (delete-file (oref persist-simple-1 file)))) + +;;; Slot Writers +;; +;; Replica of the test in eieio-tests.el - + +(defclass persist-:printer (eieio-persistent) + ((slot1 :initarg :slot1 + :initform 'moose + :printer PO-slot1-printer) + (slot2 :initarg :slot2 + :initform "foo")) + "A Persistent object with two initializable slots.") + +(defun PO-slot1-printer (slotvalue) + "Print the slot value SLOTVALUE to stdout. +Assume SLOTVALUE is a symbol of some sort." + (princ "'") + (princ (symbol-name slotvalue)) + (princ " ;; RAN PRINTER") + nil) + +(ert-deftest eieio-test-persist-printer () + (let ((persist-:printer-1 + (persist-:printer "persist" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps2.pt")))) + (should persist-:printer-1) + (persist-test-save-and-compare persist-:printer-1) + + (let* ((find-file-hook nil) + (tbuff (find-file-noselect "test-ps2.pt")) + ) + (condition-case nil + (unwind-protect + (with-current-buffer tbuff + (goto-char (point-min)) + (re-search-forward "RAN PRINTER")) + (kill-buffer tbuff)) + (error "persist-:printer-1's Slot1 printer function didn't work."))) + (delete-file (oref persist-:printer-1 file)))) + +;;; Slot with Object +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent () + ((slot1 :initarg :slot1 + :initform 1) + (slot2 :initform 2)) + "Class for testing persistent saving of an object that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot () + (let ((persist-wos + (persistent-with-objs-slot + "persist wos 1" + :pnp (persist-not-persistent "pnp 1" :slot1 3) + :file (concat default-directory "test-ps3.pt")))) + + (persist-test-save-and-compare persist-wos) + (delete-file (oref persist-wos file)))) + +;;; Slot with Object child of :type +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent-subclass (persist-not-persistent) + ((slot3 :initarg :slot1 + :initform 1) + (slot4 :initform 2)) + "Class for testing persistent saving of an object subclass that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot-subs (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent-child) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot-child () + (let ((persist-woss + (persistent-with-objs-slot-subs + "persist woss 1" + :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :file (concat default-directory "test-ps4.pt")))) + + (persist-test-save-and-compare persist-woss) + (delete-file (oref persist-woss file)))) + +;;; Slot with a list of Objects +;; +;; A slot that contains another object that isn't persistent +(defclass persistent-with-objs-list-slot (eieio-persistent) + ((pnp :initarg :pnp + :type persist-not-persistent-list + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-slot-with-list-of-objects () + (let ((persist-wols + (persistent-with-objs-list-slot + "persist wols 1" + :pnp (list (persist-not-persistent "pnp 1" :slot1 3) + (persist-not-persistent "pnp 2" :slot1 4) + (persist-not-persistent "pnp 3" :slot1 5)) + :file (concat default-directory "test-ps5.pt")))) + + (persist-test-save-and-compare persist-wols) + (delete-file (oref persist-wols file)))) + +;;; eieio-test-persist.el ends here === added file 'test/automated/eieio-tests.el' --- test/automated/eieio-tests.el 1970-01-01 00:00:00 +0000 +++ test/automated/eieio-tests.el 2013-08-21 19:42:52 +0000 @@ -0,0 +1,893 @@ +;;; eieio-tests.el -- eieio tests routines + +;; Copyright (C) 1999-2003, 2005-2010, 2012-2013 Free Software +;; Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Test the various features of EIEIO. + +(require 'ert) +(require 'eieio) +(require 'eieio-base) +(require 'eieio-opt) + +(eval-when-compile (require 'cl)) + +;;; Code: +;; Set up some test classes +(defclass class-a () + ((water :initarg :water + :initform h20 + :type symbol + :documentation "Detail about water.") + (classslot :initform penguin + :type symbol + :documentation "A class allocated slot." + :allocation :class) + (test-tag :initform nil + :documentation "Used to make sure methods are called.") + (self :initform nil + :type (or null class-a) + :documentation "Test self referencing types.") + ) + "Class A") + +(defclass class-b () + ((land :initform "Sc" + :type string + :documentation "Detail about land.")) + "Class B") + +(defclass class-ab (class-a class-b) + ((amphibian :initform "frog" + :documentation "Detail about amphibian on land and water.")) + "Class A and B combined.") + +(defclass class-c () + ((slot-1 :initarg :moose + :initform moose + :type symbol + :allocation :instance + :documentation "Fisrt slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + ) + +(defclass class-subc (class-c) + ((slot-1 ;; :initform moose - don't override this + ) + (slot-2 :initform "linux" ;; Do override this one + :protection :private + )) + "A class for testing slot arguments.") + +;;; Defining a class with a slot tag error +;; +;; Temporarily disable this test because of macro expansion changes in +;; current Emacs trunk. It can be re-enabled when we have moved +;; `eieio-defclass' into the `defclass' macro and the +;; `eval-and-compile' there is removed. + +;; (let ((eieio-error-unsupported-class-tags t)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.") +;; (error "No error was thrown for badslottag")) +;; (invalid-slot-type nil))) + +;; (let ((eieio-error-unsupported-class-tags nil)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.")) +;; (invalid-slot-type +;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") +;; ))) + +(ert-deftest eieio-test-01-mix-alloc-initarg () + ;; Only run this test if the message framework thingy works. + (when (and (message "foo") (string= "foo" (current-message))) + + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (defclass class-alloc-initarg () + ((throwwarning :initarg :throwwarning + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.") + + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message))))) + +(defclass abstract-class () + ((some-slot :initarg :some-slot + :initform nil + :documentation "A slot.")) + :documentation "An abstract class." + :abstract t) + +(ert-deftest eieio-test-02-abstract-class () + ;; Abstract classes cannot be instantiated, so this should throw an + ;; error + (should-error (abstract-class "Test"))) + +(defgeneric generic1 () "First generic function") + +(ert-deftest eieio-test-03-generics () + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a "test"))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666)))) + +(defclass static-method-class () + ((some-slot :initform nil + :allocation :class + :documentation "A slot.")) + :documentation "A class used for testing static methods.") + +(defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value)) + +(ert-deftest eieio-test-04-static-method () + ;; Call static method on a class and see if it worked + (static-method-class-method static-method-class 'class) + (should (eq (oref static-method-class some-slot) 'class)) + (static-method-class-method (static-method-class "test") 'object) + (should (eq (oref static-method-class some-slot) 'object))) + +(ert-deftest eieio-test-05-static-method-2 () + (defclass static-method-class-2 (static-method-class) + () + "A second class after the previous for static methods.") + + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + + (static-method-class-method static-method-class-2 'class) + (should (eq (oref static-method-class-2 some-slot) 'moose-class)) + (static-method-class-method (static-method-class-2 "test") 'object) + (should (eq (oref static-method-class-2 some-slot) 'moose-object))) + + +;;; Perform method testing +;; + +;;; Multiple Inheritance, and method signal testing +;; +(defvar eitest-ab nil) +(defvar eitest-a nil) +(defvar eitest-b nil) +(ert-deftest eieio-test-06-allocate-objects () + ;; allocate an object to use + (should (setq eitest-ab (class-ab "abby"))) + (should (setq eitest-a (class-a "aye"))) + (should (setq eitest-b (class-b "fooby")))) + +(ert-deftest eieio-test-07-make-instance () + (should (make-instance 'class-ab)) + (should (make-instance 'class-a :water 'cho)) + (should (make-instance 'class-b "a name"))) + +(defmethod class-cn ((a class-a)) + "Try calling `call-next-method' when there isn't one. +Argument A is object of type symbol `class-a'." + (call-next-method)) + +(defmethod no-next-method ((a class-a) &rest args) + "Override signal throwing for variable `class-a'. +Argument A is the object of class variable `class-a'." + 'moose) + +(ert-deftest eieio-test-08-call-next-method () + ;; Play with call-next-method + (should (eq (class-cn eitest-ab) 'moose))) + +(defmethod no-applicable-method ((b class-b) method &rest args) + "No need. +Argument B is for booger. +METHOD is the method that was attempting to be called." + 'moose) + +(ert-deftest eieio-test-09-no-applicable-method () + ;; Non-existing methods. + (should (eq (class-cn eitest-b) 'moose))) + +(defmethod class-fun ((a class-a)) + "Fun with class A." + 'moose) + +(defmethod class-fun ((b class-b)) + "Fun with class B." + (error "Class B fun should not be called") + ) + +(defmethod class-fun-foo ((b class-b)) + "Foo Fun with class B." + 'moose) + +(defmethod class-fun2 ((a class-a)) + "More fun with class A." + 'moose) + +(defmethod class-fun2 ((b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called") + ) + +(defmethod class-fun2 ((ab class-ab)) + "More fun with class AB." + (call-next-method)) + +;; How about if B is the only slot? +(defmethod class-fun3 ((b class-b)) + "Even More fun with class B." + 'moose) + +(defmethod class-fun3 ((ab class-ab)) + "Even More fun with class AB." + (call-next-method)) + +(ert-deftest eieio-test-10-multiple-inheritance () + ;; play with methods and mi + (should (eq (class-fun eitest-ab) 'moose)) + (should (eq (class-fun-foo eitest-ab) 'moose)) + ;; Play with next-method and mi + (should (eq (class-fun2 eitest-ab) 'moose)) + (should (eq (class-fun3 eitest-ab) 'moose))) + +(ert-deftest eieio-test-11-self () + ;; Try the self referencing test + (should (oset eitest-a self eitest-a)) + (should (oset eitest-ab self eitest-ab))) + + +(defvar class-fun-value-seq '()) +(defmethod class-fun-value :BEFORE ((a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + +(defmethod class-fun-value :PRIMARY ((a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + +(defmethod class-fun-value :AFTER ((a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after) + +(ert-deftest eieio-test-12-generic-function-call () + ;; Test value of a generic function call + ;; + (let* ((class-fun-value-seq nil) + (value (class-fun-value eitest-a))) + ;; Test if generic function call returns the primary method's value + (should (eq value 'primary)) + ;; Make sure :before and :after methods were run + (should (equal class-fun-value-seq '(after primary before))))) + +;;; Test initialization methods +;; + +(ert-deftest eieio-test-13-init-methods () + (defmethod initialize-instance ((a class-a) &rest slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a "class act"))) + (should-not (/= (oref ca test-tag) 2)))) + + +;;; Perform slot testing +;; +(ert-deftest eieio-test-14-slots () + ;; Check slot existence + (should (oref eitest-ab water)) + (should (oref eitest-ab land)) + (should (oref eitest-ab amphibian))) + +(ert-deftest eieio-test-15-slot-missing () + + (defmethod slot-missing ((ab class-ab) &rest foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose) + + (should (eq (oref eitest-ab ooga-booga) 'moose)) + (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) + +(ert-deftest eieio-test-16-slot-makeunbound () + (slot-makeunbound eitest-a 'water) + ;; Should now be unbound + (should-not (slot-boundp eitest-a 'water)) + ;; But should still exist + (should (slot-exists-p eitest-a 'water)) + (should-not (slot-exists-p eitest-a 'moose)) + ;; oref of unbound slot must fail + (should-error (oref eitest-a water) :type 'unbound-slot)) + +(defvar eitest-vsca nil) +(defvar eitest-vscb nil) +(defclass virtual-slot-class () + ((base-value :initarg :base-value)) + "Class has real slot :base-value and simulated slot :derived-value.") +(defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (call-next-method)))) + +(ert-deftest eieio-test-17-virtual-slot () + (setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1)) + ;; Check slot values + (should (= (oref eitest-vsca :base-value) 1)) + (should (= (oref eitest-vsca :derived-value) 2)) + + (oset eitest-vsca :derived-value 3) + (should (= (oref eitest-vsca :base-value) 2)) + (should (= (oref eitest-vsca :derived-value) 3)) + + (oset eitest-vsca :base-value 3) + (should (= (oref eitest-vsca :base-value) 3)) + (should (= (oref eitest-vsca :derived-value) 4)) + + ;; should also be possible to initialize instance using virtual slot + + (setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5)) + (should (= (oref eitest-vscb :base-value) 4)) + (should (= (oref eitest-vscb :derived-value) 5))) + +(ert-deftest eieio-test-18-slot-unbound () + + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a "foo") water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (call-next-method))) + +(ert-deftest eieio-test-19-slot-type-checking () + ;; Slot type checking + ;; We should not be able to set a string here + (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type) + (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type) + (should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type)) + +(ert-deftest eieio-test-20-class-allocated-slots () + ;; Test out class allocated slots + (defvar eitest-aa nil) + (setq eitest-aa (class-a "another")) + + ;; Make sure class slots do not track between objects + (let ((newval 'moose)) + (oset eitest-aa classslot newval) + (should (eq (oref eitest-a classslot) newval)) + (should (eq (oref eitest-aa classslot) newval))) + + ;; Slot should be bound + (should (slot-boundp eitest-a 'classslot)) + (should (slot-boundp class-a 'classslot)) + + (slot-makeunbound eitest-a 'classslot) + + (should-not (slot-boundp eitest-a 'classslot)) + (should-not (slot-boundp class-a 'classslot))) + + +(defvar eieio-test-permuting-value nil) +(defvar eitest-pvinit nil) +(eval-and-compile + (setq eieio-test-permuting-value 1)) + +(defclass inittest nil + ((staticval :initform 1) + (symval :initform eieio-test-permuting-value) + (evalval :initform (symbol-value 'eieio-test-permuting-value)) + (evalnow :initform (symbol-value 'eieio-test-permuting-value) + :allocation :class) + ) + "Test initforms that eval.") + +(ert-deftest eieio-test-21-eval-at-construction-time () + ;; initforms that need to be evalled at construction time. + (setq eieio-test-permuting-value 2) + (setq eitest-pvinit (inittest "permuteme")) + + (should (eq (oref eitest-pvinit staticval) 1)) + (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value)) + (should (eq (oref eitest-pvinit evalval) 2)) + (should (eq (oref eitest-pvinit evalnow) 1))) + +(defvar eitest-tests nil) + +(ert-deftest eieio-test-22-init-forms-dont-match-runnable () + ;; Init forms with types that don't match the runnable. + (defclass eitest-subordinate nil + ((text :initform "" :type string)) + "Test class that will be a calculated value.") + + (defclass eitest-superior nil + ((sub :initform (eitest-subordinate "test") + :type eitest-subordinate)) + "A class with an initform that creates a class.") + + (should (setq eitest-tests (eitest-superior "test"))) + + (should-error + (eval + '(defclass broken-init nil + ((broken :initform 1 + :type string)) + "This class should break.")) + :type 'invalid-slot-type)) + +(ert-deftest eieio-test-23-inheritance-check () + (should (child-of-class-p class-ab class-a)) + (should (child-of-class-p class-ab class-b)) + (should (object-of-class-p eitest-a class-a)) + (should (object-of-class-p eitest-ab class-a)) + (should (object-of-class-p eitest-ab class-b)) + (should (object-of-class-p eitest-ab class-ab)) + (should (eq (eieio-class-parents class-a) nil)) + (should (equal (eieio-class-parents class-ab) '(class-a class-b))) + (should (same-class-p eitest-a class-a)) + (should (class-a-p eitest-a)) + (should (not (class-a-p eitest-ab))) + (should (class-a-child-p eitest-a)) + (should (class-a-child-p eitest-ab)) + (should (not (class-a-p "foo"))) + (should (not (class-a-child-p "foo")))) + +(ert-deftest eieio-test-24-object-predicates () + (let ((listooa (list (class-ab "ab") (class-a "a"))) + (listoob (list (class-ab "ab") (class-b "b")))) + (should (class-a-list-p listooa)) + (should (class-b-list-p listoob)) + (should-not (class-b-list-p listooa)) + (should-not (class-a-list-p listoob)))) + +(defvar eitest-t1 nil) +(ert-deftest eieio-test-25-slot-tests () + (setq eitest-t1 (class-c "C1")) + ;; Slot initialization + (should (eq (oref eitest-t1 slot-1) 'moose)) + (should (eq (oref eitest-t1 :moose) 'moose)) + ;; Don't pass reference of private slot + (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) + ;; Check private slot accessor + (should (string= (get-slot-2 eitest-t1) "penguin")) + ;; Pass string instead of symbol + (should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type) + (should (eq (get-slot-3 eitest-t1) 'emu)) + (should (eq (get-slot-3 class-c) 'emu)) + ;; Check setf + (setf (get-slot-3 eitest-t1) 'setf-emu) + (should (eq (get-slot-3 eitest-t1) 'setf-emu)) + ;; Roll back + (setf (get-slot-3 eitest-t1) 'emu)) + +(defvar eitest-t2 nil) +(ert-deftest eieio-test-26-default-inheritance () + ;; See previous test, nor for subclass + (setq eitest-t2 (class-subc "subc")) + (should (eq (oref eitest-t2 slot-1) 'moose)) + (should (eq (oref eitest-t2 :moose) 'moose)) + (should (string= (get-slot-2 eitest-t2) "linux")) + (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) + (should (string= (get-slot-2 eitest-t2) "linux")) + (should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type)) + +;;(ert-deftest eieio-test-27-inherited-new-value () + ;;; HACK ALERT: The new value of a class slot is inherited by the + ;; subclass! This is probably a bug. We should either share the slot + ;; so sets on the baseclass change the subclass, or we should inherit + ;; the original value. +;; (should (eq (get-slot-3 eitest-t2) 'emu)) +;; (should (eq (get-slot-3 class-subc) 'emu)) +;; (setf (get-slot-3 eitest-t2) 'setf-emu) +;; (should (eq (get-slot-3 eitest-t2) 'setf-emu))) + +;; Slot protection +(defclass prot-0 () + () + "Protection testing baseclass.") + +(defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. +The object S2 passed in will be of class prot-1, which does have +the slot. This could be allowed, and currently is in EIEIO. +Needed by the eieio persistant base class." + (oref s2 slot-2)) + +(defclass prot-1 (prot-0) + ((slot-1 :initarg :slot-1 + :initform nil + :protection :public) + (slot-2 :initarg :slot-2 + :initform nil + :protection :protected) + (slot-3 :initarg :slot-3 + :initform nil + :protection :private)) + "A class for testing the :protection option.") + +(defclass prot-2 (prot-1) + nil + "A class for testing the :protection option.") + +(defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. +Do not override for `prot-2'." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defvar eitest-p1 nil) +(defvar eitest-p2 nil) +(ert-deftest eieio-test-28-slot-protection () + (setq eitest-p1 (prot-1 "")) + (setq eitest-p2 (prot-2 "")) + ;; Access public slots + (oref eitest-p1 slot-1) + (oref eitest-p2 slot-1) + ;; Accessing protected slot out of context must fail + (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name) + ;; Access protected slot in method + (prot1-slot-2 eitest-p1) + ;; Protected slot in subclass method + (prot1-slot-2 eitest-p2) + ;; Protected slot from parent class method + (prot0-slot-2 eitest-p1) + ;; Accessing private slot out of context must fail + (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name) + ;; Access private slot in ethod + (prot1-slot-3 eitest-p1) + ;; Access private slot in subclass method must fail + (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name) + ;; Access private slot by same class + (prot1-slot-3-only eitest-p1) + ;; Access private slot by subclass in sameclass method + (prot1-slot-3-only eitest-p2)) + +;;; eieio-instance-inheritor +;; Test to make sure this works. +(defclass II (eieio-instance-inheritor) + ((slot1 :initform 1) + (slot2) + (slot3)) + "Instance Inheritor test class.") + +(defvar eitest-II1 nil) +(defvar eitest-II2 nil) +(defvar eitest-II3 nil) +(ert-deftest eieio-test-29-instance-inheritor () + (setq eitest-II1 (II "II Test.")) + (oset eitest-II1 slot2 'cat) + (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) + (oset eitest-II2 slot1 'moose) + (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test.")) + (oset eitest-II3 slot3 'penguin) + + ;; Test level 1 inheritance + (should (eq (oref eitest-II3 slot1) 'moose)) + ;; Test level 2 inheritance + (should (eq (oref eitest-II3 slot2) 'cat)) + ;; Test level 0 inheritance + (should (eq (oref eitest-II3 slot3) 'penguin))) + +(defclass slotattr-base () + ((initform :initform init) + (type :type list) + (initarg :initarg :initarg) + (protection :protection :private) + (custom :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :documentation + "Replace the doc-string for this property.") + (printer :printer printer1) + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-ok (slotattr-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + (printer :printer printer2) + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-30-slot-attribute-override () + ;; Subclass should not override :protection slot attribute + (should-error + (eval + '(defclass slotattr-fail (slotattr-base) + ((protection :protection :public) + ) + "This class should throw an error."))) + + ;; Subclass should not override :type slot attribute + (should-error + (eval + '(defclass slotattr-fail (slotattr-base) + ((type :type string) + ) + "This class should throw an error."))) + + ;; Initform should override instance allocation + (let ((obj (slotattr-ok "moose"))) + (should (eq (oref obj initform) 'no-init)))) + +(defclass slotattr-class-base () + ((initform :allocation :class + :initform init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-class-ok (slotattr-class-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-31-slot-attribute-override-class-allocation () + ;; Same as test-30, but with class allocation + (should-error + (eval + '(defclass slotattr-fail (slotattr-class-base) + ((protection :protection :public) + ) + "This class should throw an error."))) + (should-error + (eval + '(defclass slotattr-fail (slotattr-class-base) + ((type :type string) + ) + "This class should throw an error."))) + (should (eq (oref-default slotattr-class-ok initform) 'no-init))) + +(ert-deftest eieio-test-32-slot-attribute-override-2 () + (let* ((cv (class-v 'slotattr-ok)) + (docs (eieio--class-public-doc cv)) + (names (eieio--class-public-a cv)) + (cust (eieio--class-public-custom cv)) + (label (eieio--class-public-custom-label cv)) + (group (eieio--class-public-custom-group cv)) + (types (eieio--class-public-type cv)) + (args (eieio--class-initarg-tuples cv)) + (i 0)) + ;; :initarg should override for subclass + (should (assoc :initblarg args)) + + (while (< i (length names)) + (cond + ((eq (nth i names) 'custom) + ;; Custom slot attributes must override + (should (eq (nth i cust) 'string)) + ;; Custom label slot attribute must override + (should (string= (nth i label) "One String")) + (let ((grp (nth i group))) + ;; Custom group slot attribute must combine + (should (and (memq 'moose grp) (memq 'cow grp))))) + (t nil)) + + (setq i (1+ i))))) + +(defvar eitest-CLONETEST1 nil) +(defvar eitest-CLONETEST2 nil) + +(ert-deftest eieio-test-32-test-clone-boring-objects () + ;; A simple make instance with EIEIO extension + (should (setq eitest-CLONETEST1 (make-instance 'class-a "a"))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))) + + ;; CLOS form of make-instance + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) + +(defclass IT (eieio-instance-tracker) + ((tracking-symbol :initform IT-list) + (slot1 :initform 'die)) + "Instance Tracker test object.") + +(ert-deftest eieio-test-33-instance-tracker () + (let (IT-list IT1) + (should (setq IT1 (IT "trackme"))) + ;; The instance tracker must find this + (should (eieio-instance-tracker-find 'die 'slot1 'IT-list)) + ;; Test deletion + (delete-instance IT1) + (should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list)))) + +(defclass SINGLE (eieio-singleton) + ((a-slot :initarg :a-slot :initform t)) + "A Singleton test object.") + +(ert-deftest eieio-test-34-singletons () + (let ((obj1 (SINGLE "Moose")) + (obj2 (SINGLE "Cow"))) + (should (eieio-object-p obj1)) + (should (eieio-object-p obj2)) + (should (eq obj1 obj2)) + (should (oref obj1 a-slot)))) + +(defclass NAMED (eieio-named) + ((some-slot :initform nil) + ) + "A class inheriting from eieio-named.") + +(ert-deftest eieio-test-35-named-object () + (let (N) + (should (setq N (NAMED "Foo"))) + (should (string= "Foo" (oref N object-name))) + (should-error (oref N missing-slot) :type 'invalid-slot-name) + (oset N object-name "NewName") + (should (string= "NewName" (oref N object-name))))) + +(defclass opt-test1 () + () + "Abstract base class" + :abstract t) + +(defclass opt-test2 (opt-test1) + () + "Instantiable child") + +(ert-deftest eieio-test-36-build-class-alist () + (should (= (length (eieio-build-class-alist opt-test1 nil)) 2)) + (should (= (length (eieio-build-class-alist opt-test1 t)) 1))) + +(ert-deftest eieio-test-37-persistent-classes () + (load-file "eieio-test-persist.el")) + +(provide 'eieio-tests) + +;;; eieio-tests.el ends here ------------------------------------------------------------ revno: 113967 committer: Stefan Monnier branch nick: trunk timestamp: Wed 2013-08-21 14:26:15 -0400 message: * lisp/emacs-lisp/pp.el (pp-eval-expression, pp-macroexpand-expression): Use read--expression so that completion works again. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-08-21 01:16:27 +0000 +++ lisp/ChangeLog 2013-08-21 18:26:15 +0000 @@ -1,10 +1,15 @@ +2013-08-21 Stefan Monnier + + * emacs-lisp/pp.el (pp-eval-expression, pp-macroexpand-expression): + Use read--expression so that completion works again. + 2013-08-21 Sam Steingold Add rudimentary inferior shell interaction * progmodes/sh-script.el (sh-shell-process): New buffer-local variable. (sh-set-shell): Reset it. - (sh-show-shell, sh-cd-here, sh-send-line-or-region-and-step): New - commands (bound to C-c C-z, C-c C-d, and C-c C-n). + (sh-show-shell, sh-cd-here, sh-send-line-or-region-and-step): + New commands (bound to C-c C-z, C-c C-d, and C-c C-n). 2013-08-20 Stefan Monnier === modified file 'lisp/emacs-lisp/pp.el' --- lisp/emacs-lisp/pp.el 2013-01-01 09:11:05 +0000 +++ lisp/emacs-lisp/pp.el 2013-08-21 18:26:15 +0000 @@ -127,8 +127,7 @@ "Evaluate EXPRESSION and pretty-print its value. Also add the value to the front of the list in the variable `values'." (interactive - (list (read-from-minibuffer "Eval: " nil read-expression-map t - 'read-expression-history))) + (list (read--expression "Eval: "))) (message "Evaluating...") (setq values (cons (eval expression) values)) (pp-display-expression (car values) "*Pp Eval Output*")) @@ -137,8 +136,7 @@ (defun pp-macroexpand-expression (expression) "Macroexpand EXPRESSION and pretty-print its value." (interactive - (list (read-from-minibuffer "Macroexpand: " nil read-expression-map t - 'read-expression-history))) + (list (read--expression "Macroexpand: "))) (pp-display-expression (macroexpand expression) "*Pp Macroexpand Output*")) (defun pp-last-sexp () ------------------------------------------------------------ revno: 113966 committer: Glenn Morris branch nick: trunk timestamp: Wed 2013-08-21 06:17:37 -0400 message: Auto-commit of generated files. diff: === modified file 'autogen/configure' --- autogen/configure 2013-08-19 10:17:37 +0000 +++ autogen/configure 2013-08-21 10:17:37 +0000 @@ -16573,7 +16573,7 @@ $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, \"%s\", ptyname); }" >>confdefs.h if test "x$ac_cv_func_posix_openpt" = xyes; then - $as_echo "#define PTY_OPEN fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY)" >>confdefs.h + $as_echo "#define PTY_OPEN do { fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY); if (fd < 0 && errno == EINVAL) fd = posix_openpt (O_RDWR | O_NOCTTY); } while (0)" >>confdefs.h $as_echo "#define PTY_NAME_SPRINTF /**/" >>confdefs.h ------------------------------------------------------------ revno: 113965 committer: Dmitry Antipov branch nick: trunk timestamp: Wed 2013-08-21 11:02:45 +0400 message: Fix compilation with GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE and GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES. * alloc.c (toplevel): Remove unnecessary nested #if...#endif. (mark_maybe_object) [!GC_MARK_STACK]: Define to emacs_abort to shut up compiler in mark_object. (dump_zombies): Convert to global and add EXTERNALLY_VISIBLE. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-08-21 05:39:51 +0000 +++ src/ChangeLog 2013-08-21 07:02:45 +0000 @@ -1,3 +1,12 @@ +2013-08-21 Dmitry Antipov + + Fix compilation with GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE + and GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES. + * alloc.c (toplevel): Remove unnecessary nested #if...#endif. + (mark_maybe_object) [!GC_MARK_STACK]: Define to emacs_abort + to shut up compiler in mark_object. + (dump_zombies): Convert to global and add EXTERNALLY_VISIBLE. + 2013-08-21 Paul Eggert * process.c (allocate_pty) [PTY_OPEN]: Set fd's FD_CLOEXEC flag. === modified file 'src/alloc.c' --- src/alloc.c 2013-08-14 16:36:16 +0000 +++ src/alloc.c 2013-08-21 07:02:45 +0000 @@ -318,7 +318,6 @@ static struct mem_node mem_z; #define MEM_NIL &mem_z -#if GC_MARK_STACK || defined GC_MALLOC_CHECK static struct mem_node *mem_insert (void *, void *, enum mem_type); static void mem_insert_fixup (struct mem_node *); static void mem_rotate_left (struct mem_node *); @@ -326,7 +325,6 @@ static void mem_delete (struct mem_node *); static void mem_delete_fixup (struct mem_node *); static struct mem_node *mem_find (void *); -#endif #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */ @@ -4238,6 +4236,10 @@ #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES +/* Currently not used, but may be called from gdb. */ + +void dump_zombies (void) EXTERNALLY_VISIBLE; + /* Array of objects that are kept alive because the C stack contains a pattern that looks like a reference to them . */ @@ -4620,7 +4622,7 @@ #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES -static void +void dump_zombies (void) { int i; @@ -4757,6 +4759,10 @@ #endif } +#else /* GC_MARK_STACK == 0 */ + +#define mark_maybe_object(obj) emacs_abort () + #endif /* GC_MARK_STACK != 0 */ ------------------------------------------------------------ revno: 113964 fixes bug: http://debbugs.gnu.org/15129 committer: Paul Eggert branch nick: trunk timestamp: Tue 2013-08-20 23:11:50 -0700 message: Port close-on-exec pty creation to FreeBSD 9.1-RELEASE. * configure.ac (PTY_OPEN): If posix_openpt with O_CLOEXEC fails and reports EINVAL, try it again without O_CLOEXEC. This should port PTY_OPEN to FreeBSD 9, which stupidly rejects O_CLOEXEC. What were they thinking? diff: === modified file 'ChangeLog' --- ChangeLog 2013-08-20 08:30:24 +0000 +++ ChangeLog 2013-08-21 06:11:50 +0000 @@ -1,3 +1,11 @@ +2013-08-21 Paul Eggert + + Port close-on-exec pty creation to FreeBSD 9.1-RELEASE (Bug#15129). + * configure.ac (PTY_OPEN): If posix_openpt with O_CLOEXEC fails + and reports EINVAL, try it again without O_CLOEXEC. This should + port PTY_OPEN to FreeBSD 9, which stupidly rejects O_CLOEXEC. + What were they thinking? + 2013-08-20 Paul Eggert * Makefile.in (distclean, bootstrap-clean, maintainer-clean): === modified file 'configure.ac' --- configure.ac 2013-08-15 16:37:15 +0000 +++ configure.ac 2013-08-21 06:11:50 +0000 @@ -3994,7 +3994,7 @@ AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }]) dnl if HAVE_POSIX_OPENPT if test "x$ac_cv_func_posix_openpt" = xyes; then - AC_DEFINE(PTY_OPEN, [fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY)]) + AC_DEFINE(PTY_OPEN, [do { fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY); if (fd < 0 && errno == EINVAL) fd = posix_openpt (O_RDWR | O_NOCTTY); } while (0)]) AC_DEFINE(PTY_NAME_SPRINTF, []) dnl if HAVE_GETPT elif test "x$ac_cv_func_getpt" = xyes; then