diff options
| author | Lars Magne Ingebrigtsen | 2015-01-28 14:21:33 +1100 |
|---|---|---|
| committer | Lars Magne Ingebrigtsen | 2015-01-28 14:21:33 +1100 |
| commit | 7f4f16b3ae6fdb59d83cfc01017668f2a564309f (patch) | |
| tree | 60e4a7f23f949afaed3bc2fddd0a528aef297861 /lisp | |
| parent | 1a369fc7f1ccec6954344ec1ee0211a4d24c312d (diff) | |
| parent | be2d23e58721b7acc68c0ea654a38e5109df2aa2 (diff) | |
| download | emacs-7f4f16b3ae6fdb59d83cfc01017668f2a564309f.tar.gz emacs-7f4f16b3ae6fdb59d83cfc01017668f2a564309f.zip | |
Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ChangeLog | 84 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 323 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 13 | ||||
| -rw-r--r-- | lisp/emacs-lisp/derived.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-compat.el | 13 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-datadebug.el | 16 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-opt.el | 18 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/ChangeLog | 20 | ||||
| -rw-r--r-- | lisp/gnus/gnus-bcklg.el | 4 | ||||
| -rw-r--r-- | lisp/gnus/nnimap.el | 20 | ||||
| -rw-r--r-- | lisp/gnus/nnir.el | 123 | ||||
| -rw-r--r-- | lisp/gnus/nnmairix.el | 2 | ||||
| -rw-r--r-- | lisp/isearch.el | 2 | ||||
| -rw-r--r-- | lisp/net/eudc-bob.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudc-export.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudc-hotlist.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudc-vars.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudc.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudcb-bbdb.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudcb-ldap.el | 3 | ||||
| -rw-r--r-- | lisp/net/eudcb-mab.el | 2 | ||||
| -rw-r--r-- | lisp/net/eudcb-ph.el | 3 | ||||
| -rw-r--r-- | lisp/progmodes/python.el | 6 | ||||
| -rw-r--r-- | lisp/tar-mode.el | 115 |
26 files changed, 547 insertions, 245 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d17dff23a2f..b95424543f8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,87 @@ | |||
| 1 | 2015-01-27 Katsumi Yamaoka <yamaoka@jpl.org> | ||
| 2 | |||
| 3 | * emacs-lisp/cl.el (cl--function-convert): | ||
| 4 | Merge cache that cl--labels-convert adds (bug#19699). | ||
| 5 | |||
| 6 | 2015-01-27 Ivan Shmakov <ivan@siamics.net> | ||
| 7 | |||
| 8 | * tar-mode.el: Allow for adding new archive members. (Bug#19274) | ||
| 9 | (tar-new-regular-file-header, tar--pad-to, tar--put-at) | ||
| 10 | (tar-header-serialize): New functions. | ||
| 11 | (tar-current-position): Split from tar-current-descriptor. | ||
| 12 | (tar-current-descriptor): Use it. | ||
| 13 | (tar-new-entry): New command. | ||
| 14 | (tar-mode-map): Bind it. | ||
| 15 | |||
| 16 | 2015-01-27 Sam Steingold <sds@gnu.org> | ||
| 17 | |||
| 18 | * progmodes/python.el (python-check-custom-command): Buffer local | ||
| 19 | because it usually includes the buffer name. | ||
| 20 | (python-check-command): Set to epylint when pyflakes is not available. | ||
| 21 | |||
| 22 | 2015-01-27 Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 23 | |||
| 24 | * net/eudcb-bbdb.el, net/eudcb-ldap.el, net/eudcb-mab.el, | ||
| 25 | net/eudc-bob.el, net/eudcb-ph.el, net/eudc.el, net/eudc-export.el, | ||
| 26 | net/eudc-hotlist.el, net/eudc-vars.el: New maintainer. | ||
| 27 | |||
| 28 | 2015-01-27 Artur Malabarba <bruce.connor.am@gmail.com> | ||
| 29 | |||
| 30 | * isearch.el (isearch-process-search-char): Add docstring. | ||
| 31 | |||
| 32 | 2015-01-27 Oleh Krehel <ohwoeowho@gmail.com> | ||
| 33 | |||
| 34 | * emacs-lisp/derived.el (define-derived-mode): Declare indent 3. | ||
| 35 | |||
| 36 | 2015-01-27 Katsumi Yamaoka <yamaoka@jpl.org> | ||
| 37 | |||
| 38 | * emacs-lisp/cl.el (cl--function-convert): Run cl--labels-convert | ||
| 39 | for the case cl-flet or cl-labels form is wrapped with lexical-let | ||
| 40 | (bug#19613). | ||
| 41 | |||
| 42 | 2015-01-26 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 43 | |||
| 44 | * emacs-lisp/cl-generic.el (cl--generic-method): New struct. | ||
| 45 | (cl--generic): The method-table is now a (list-of cl--generic-method). | ||
| 46 | (cl--generic-member-method): New function. | ||
| 47 | (cl-generic-define-method): Use it. | ||
| 48 | (cl--generic-build-combined-method, cl--generic-cache-miss): | ||
| 49 | Adapt to new method-table. | ||
| 50 | (cl--generic-no-next-method-function): Add `method' argument. | ||
| 51 | (cl-generic-call-method): Adapt to new method representation. | ||
| 52 | (cl--generic-cnm-sample, cl--generic-nnm-sample): Adjust. | ||
| 53 | (cl-find-method, cl-method-qualifiers): New functions. | ||
| 54 | (cl--generic-method-info): Adapt to new method representation. | ||
| 55 | Return a string for the qualifiers. | ||
| 56 | (cl--generic-describe): | ||
| 57 | * emacs-lisp/eieio-opt.el (eieio-help-class): Adjust accordingly. | ||
| 58 | (eieio-all-generic-functions, eieio-method-documentation): | ||
| 59 | Adjust to new method representation. | ||
| 60 | |||
| 61 | * emacs-lisp/eieio-compat.el (eieio--defmethod): Use cl-find-method. | ||
| 62 | |||
| 63 | 2015-01-26 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 64 | |||
| 65 | * emacs-lisp/cl-generic.el: Add a method-combination hook. | ||
| 66 | (cl-generic-method-combination-function): New var. | ||
| 67 | (cl--generic-lambda): Remove `with-cnm' arg. | ||
| 68 | (cl-defmethod): Change accordingly. | ||
| 69 | (cl-generic-define-method): Don't check qualifiers validity. | ||
| 70 | Preserve all qualifiers in `method-table'. | ||
| 71 | (cl-generic-call-method): New function. | ||
| 72 | (cl--generic-nest): Remove (morph into cl-generic-call-method). | ||
| 73 | (cl--generic-build-combined-method): Adjust to new format of method-table | ||
| 74 | and use cl-generic-method-combination-function. | ||
| 75 | (cl--generic-standard-method-combination): New function, extracted from | ||
| 76 | cl--generic-build-combined-method. | ||
| 77 | (cl--generic-cnm-sample): Adjust to new format of method-table. | ||
| 78 | |||
| 79 | * emacs-lisp/eieio-compat.el (eieio--defmethod): Use () qualifiers | ||
| 80 | instead of :primary. | ||
| 81 | |||
| 82 | * emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke): | ||
| 83 | Remove obsolete function. | ||
| 84 | |||
| 1 | 2015-01-26 Lars Ingebrigtsen <larsi@gnus.org> | 85 | 2015-01-26 Lars Ingebrigtsen <larsi@gnus.org> |
| 2 | 86 | ||
| 3 | * net/shr.el (shr-make-table-1): Fix colspan typo. | 87 | * net/shr.el (shr-make-table-1): Fix colspan typo. |
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 02a43514019..1bb70963a57 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el | |||
| @@ -30,11 +30,9 @@ | |||
| 30 | ;; CLOS's define-method-combination is IMO overly complicated, and it suffers | 30 | ;; CLOS's define-method-combination is IMO overly complicated, and it suffers |
| 31 | ;; from a significant problem: the method-combination code returns a sexp | 31 | ;; from a significant problem: the method-combination code returns a sexp |
| 32 | ;; that needs to be `eval'uated or compiled. IOW it requires run-time | 32 | ;; that needs to be `eval'uated or compiled. IOW it requires run-time |
| 33 | ;; code generation. | 33 | ;; code generation. Given how rarely method-combinations are used, |
| 34 | ;; - Method and generic function objects: CLOS defines methods as objects | 34 | ;; I just provided a cl-generic-method-combination-function, which |
| 35 | ;; (same for generic functions), whereas we don't offer such an abstraction. | 35 | ;; people can use if they are really desperate for such functionality. |
| 36 | ;; - `no-next-method' should receive the "calling method" object, but since we | ||
| 37 | ;; don't have such a thing, we pass nil instead. | ||
| 38 | ;; - In defgeneric we don't support the options: | 36 | ;; - In defgeneric we don't support the options: |
| 39 | ;; declare, :method-combination, :generic-function-class, :method-class, | 37 | ;; declare, :method-combination, :generic-function-class, :method-class, |
| 40 | ;; :method. | 38 | ;; :method. |
| @@ -48,6 +46,8 @@ | |||
| 48 | ;; eieio-core adds dispatch on: | 46 | ;; eieio-core adds dispatch on: |
| 49 | ;; - class of eieio objects | 47 | ;; - class of eieio objects |
| 50 | ;; - actual class argument, using the syntax (subclass <class>). | 48 | ;; - actual class argument, using the syntax (subclass <class>). |
| 49 | ;; - cl-generic-method-combination-function (i.s.o define-method-combination). | ||
| 50 | ;; - cl-generic-call-method (which replaces make-method and call-method). | ||
| 51 | 51 | ||
| 52 | ;; Efficiency considerations: overall, I've made an effort to make this fairly | 52 | ;; Efficiency considerations: overall, I've made an effort to make this fairly |
| 53 | ;; efficient for the expected case (e.g. no constant redefinition of methods). | 53 | ;; efficient for the expected case (e.g. no constant redefinition of methods). |
| @@ -101,6 +101,18 @@ that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then | |||
| 101 | "Function to get the list of types that a given \"tag\" matches. | 101 | "Function to get the list of types that a given \"tag\" matches. |
| 102 | They should be sorted from most specific to least specific.") | 102 | They should be sorted from most specific to least specific.") |
| 103 | 103 | ||
| 104 | (cl-defstruct (cl--generic-method | ||
| 105 | (:constructor nil) | ||
| 106 | (:constructor cl--generic-method-make | ||
| 107 | (specializers qualifiers uses-cnm function)) | ||
| 108 | (:predicate nil)) | ||
| 109 | (specializers nil :read-only t :type list) | ||
| 110 | (qualifiers nil :read-only t :type (list-of atom)) | ||
| 111 | ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument | ||
| 112 | ;; holding the next-method. | ||
| 113 | (uses-cnm nil :read-only t :type boolean) | ||
| 114 | (function nil :read-only t :type function)) | ||
| 115 | |||
| 104 | (cl-defstruct (cl--generic | 116 | (cl-defstruct (cl--generic |
| 105 | (:constructor nil) | 117 | (:constructor nil) |
| 106 | (:constructor cl--generic-make | 118 | (:constructor cl--generic-make |
| @@ -114,12 +126,7 @@ They should be sorted from most specific to least specific.") | |||
| 114 | ;; decide in which order to sort them. | 126 | ;; decide in which order to sort them. |
| 115 | ;; The most important dispatch is last in the list (and the least is first). | 127 | ;; The most important dispatch is last in the list (and the least is first). |
| 116 | (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) | 128 | (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) |
| 117 | ;; `method-table' is a list of | 129 | (method-table nil :type (list-of cl--generic-method))) |
| 118 | ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where | ||
| 119 | ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method' | ||
| 120 | ;; (and hence expects an extra argument holding the next-method). | ||
| 121 | (method-table nil :type (list-of (cons (cons (list-of type) keyword) | ||
| 122 | (cons boolean function))))) | ||
| 123 | 130 | ||
| 124 | (defmacro cl--generic (name) | 131 | (defmacro cl--generic (name) |
| 125 | `(get ,name 'cl--generic)) | 132 | `(get ,name 'cl--generic)) |
| @@ -232,7 +239,7 @@ This macro can only be used within the lexical scope of a cl-generic method." | |||
| 232 | (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) | 239 | (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) |
| 233 | res)) | 240 | res)) |
| 234 | 241 | ||
| 235 | (defun cl--generic-lambda (args body with-cnm) | 242 | (defun cl--generic-lambda (args body) |
| 236 | "Make the lambda expression for a method with ARGS and BODY." | 243 | "Make the lambda expression for a method with ARGS and BODY." |
| 237 | (let ((plain-args ()) | 244 | (let ((plain-args ()) |
| 238 | (specializers nil) | 245 | (specializers nil) |
| @@ -255,36 +262,34 @@ This macro can only be used within the lexical scope of a cl-generic method." | |||
| 255 | . ,(lambda () specializers)) | 262 | . ,(lambda () specializers)) |
| 256 | macroexpand-all-environment))) | 263 | macroexpand-all-environment))) |
| 257 | (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. | 264 | (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. |
| 258 | (if (not with-cnm) | 265 | ;; First macroexpand away the cl-function stuff (e.g. &key and |
| 259 | (cons nil (macroexpand-all fun macroenv)) | 266 | ;; destructuring args, `declare' and whatnot). |
| 260 | ;; First macroexpand away the cl-function stuff (e.g. &key and | 267 | (pcase (macroexpand fun macroenv) |
| 261 | ;; destructuring args, `declare' and whatnot). | 268 | (`#'(lambda ,args . ,body) |
| 262 | (pcase (macroexpand fun macroenv) | 269 | (let* ((doc-string (and doc-string (stringp (car body)) (cdr body) |
| 263 | (`#'(lambda ,args . ,body) | 270 | (pop body))) |
| 264 | (let* ((doc-string (and doc-string (stringp (car body)) (cdr body) | 271 | (cnm (make-symbol "cl--cnm")) |
| 265 | (pop body))) | 272 | (nmp (make-symbol "cl--nmp")) |
| 266 | (cnm (make-symbol "cl--cnm")) | 273 | (nbody (macroexpand-all |
| 267 | (nmp (make-symbol "cl--nmp")) | 274 | `(cl-flet ((cl-call-next-method ,cnm) |
| 268 | (nbody (macroexpand-all | 275 | (cl-next-method-p ,nmp)) |
| 269 | `(cl-flet ((cl-call-next-method ,cnm) | 276 | ,@body) |
| 270 | (cl-next-method-p ,nmp)) | 277 | macroenv)) |
| 271 | ,@body) | 278 | ;; FIXME: Rather than `grep' after the fact, the |
| 272 | macroenv)) | 279 | ;; macroexpansion should directly set some flag when cnm |
| 273 | ;; FIXME: Rather than `grep' after the fact, the | 280 | ;; is used. |
| 274 | ;; macroexpansion should directly set some flag when cnm | 281 | ;; FIXME: Also, optimize the case where call-next-method is |
| 275 | ;; is used. | 282 | ;; only called with explicit arguments. |
| 276 | ;; FIXME: Also, optimize the case where call-next-method is | 283 | (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) |
| 277 | ;; only called with explicit arguments. | 284 | (cons (not (not uses-cnm)) |
| 278 | (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) | 285 | `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) |
| 279 | (cons (not (not uses-cnm)) | 286 | ,@(if doc-string (list doc-string)) |
| 280 | `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) | 287 | ,(if (not (memq nmp uses-cnm)) |
| 281 | ,@(if doc-string (list doc-string)) | 288 | nbody |
| 282 | ,(if (not (memq nmp uses-cnm)) | 289 | `(let ((,nmp (lambda () |
| 283 | nbody | 290 | (cl--generic-isnot-nnm-p ,cnm)))) |
| 284 | `(let ((,nmp (lambda () | 291 | ,nbody)))))) |
| 285 | (cl--generic-isnot-nnm-p ,cnm)))) | 292 | (f (error "Unexpected macroexpansion result: %S" f))))))) |
| 286 | ,nbody)))))) | ||
| 287 | (f (error "Unexpected macroexpansion result: %S" f)))))))) | ||
| 288 | 293 | ||
| 289 | 294 | ||
| 290 | ;;;###autoload | 295 | ;;;###autoload |
| @@ -324,8 +329,7 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 324 | (while (not (listp args)) | 329 | (while (not (listp args)) |
| 325 | (push args qualifiers) | 330 | (push args qualifiers) |
| 326 | (setq args (pop body))) | 331 | (setq args (pop body))) |
| 327 | (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after)))) | 332 | (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) |
| 328 | (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm))) | ||
| 329 | `(progn | 333 | `(progn |
| 330 | ,(when setfizer | 334 | ,(when setfizer |
| 331 | (setq name (car setfizer)) | 335 | (setq name (car setfizer)) |
| @@ -345,19 +349,25 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 345 | (cl-generic-define-method ',name ',qualifiers ',args | 349 | (cl-generic-define-method ',name ',qualifiers ',args |
| 346 | ,uses-cnm ,fun))))) | 350 | ,uses-cnm ,fun))))) |
| 347 | 351 | ||
| 352 | (defun cl--generic-member-method (specializers qualifiers methods) | ||
| 353 | (while | ||
| 354 | (and methods | ||
| 355 | (let ((m (car methods))) | ||
| 356 | (not (and (equal (cl--generic-method-specializers m) specializers) | ||
| 357 | (equal (cl--generic-method-qualifiers m) qualifiers))))) | ||
| 358 | (setq methods (cdr methods)) | ||
| 359 | methods)) | ||
| 360 | |||
| 348 | ;;;###autoload | 361 | ;;;###autoload |
| 349 | (defun cl-generic-define-method (name qualifiers args uses-cnm function) | 362 | (defun cl-generic-define-method (name qualifiers args uses-cnm function) |
| 350 | (when (> (length qualifiers) 1) | ||
| 351 | (error "We only support a single qualifier per method: %S" qualifiers)) | ||
| 352 | (unless (memq (car qualifiers) '(nil :primary :around :after :before)) | ||
| 353 | (error "Unsupported qualifier in: %S" qualifiers)) | ||
| 354 | (let* ((generic (cl-generic-ensure-function name)) | 363 | (let* ((generic (cl-generic-ensure-function name)) |
| 355 | (mandatory (cl--generic-mandatory-args args)) | 364 | (mandatory (cl--generic-mandatory-args args)) |
| 356 | (specializers | 365 | (specializers |
| 357 | (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) | 366 | (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) |
| 358 | (key (cons specializers (or (car qualifiers) ':primary))) | 367 | (method (cl--generic-method-make |
| 368 | specializers qualifiers uses-cnm function)) | ||
| 359 | (mt (cl--generic-method-table generic)) | 369 | (mt (cl--generic-method-table generic)) |
| 360 | (me (assoc key mt)) | 370 | (me (cl--generic-member-method specializers qualifiers mt)) |
| 361 | (dispatches (cl--generic-dispatches generic)) | 371 | (dispatches (cl--generic-dispatches generic)) |
| 362 | (i 0)) | 372 | (i 0)) |
| 363 | (dolist (specializer specializers) | 373 | (dolist (specializer specializers) |
| @@ -372,9 +382,8 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 372 | (nreverse (sort (cons tagcode (cdr x)) | 382 | (nreverse (sort (cons tagcode (cdr x)) |
| 373 | #'car-less-than-car)))) | 383 | #'car-less-than-car)))) |
| 374 | (setq i (1+ i)))) | 384 | (setq i (1+ i)))) |
| 375 | (if me (setcdr me (cons uses-cnm function)) | 385 | (if me (setcar me method) |
| 376 | (setf (cl--generic-method-table generic) | 386 | (setf (cl--generic-method-table generic) (cons method mt))) |
| 377 | (cons `(,key ,uses-cnm . ,function) mt))) | ||
| 378 | (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) | 387 | (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) |
| 379 | current-load-list :test #'equal) | 388 | current-load-list :test #'equal) |
| 380 | (let ((gfun (cl--generic-make-function generic)) | 389 | (let ((gfun (cl--generic-make-function generic)) |
| @@ -438,22 +447,19 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 438 | (cdr dispatch) (car dispatch)))) | 447 | (cdr dispatch) (car dispatch)))) |
| 439 | (funcall dispatcher generic dispatches))))) | 448 | (funcall dispatcher generic dispatches))))) |
| 440 | 449 | ||
| 441 | (defun cl--generic-nest (fun methods) | 450 | (defvar cl-generic-method-combination-function |
| 442 | (pcase-dolist (`(,uses-cnm . ,method) methods) | 451 | #'cl--generic-standard-method-combination |
| 443 | (setq fun | 452 | "Function to build the effective method. |
| 444 | (if (not uses-cnm) method | 453 | Called with 2 arguments: NAME and METHOD-ALIST. |
| 445 | (let ((next fun)) | 454 | It should return an effective method, i.e. a function that expects the same |
| 446 | (lambda (&rest args) | 455 | arguments as the methods, and calls those methods in some appropriate order. |
| 447 | (apply method | 456 | NAME is the name (a symbol) of the corresponding generic function. |
| 448 | ;; FIXME: This sucks: passing just `next' would | 457 | METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where |
| 449 | ;; be a lot more efficient than the lambda+apply | 458 | QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected |
| 450 | ;; quasi-η, but we need this to implement the | 459 | methods for that qualifier list. |
| 451 | ;; "if call-next-method is called with no | 460 | The METHODS lists are sorted from most generic first to most specific last. |
| 452 | ;; arguments, then use the previous arguments". | 461 | The function can use `cl-generic-call-method' to create functions that call those |
| 453 | (lambda (&rest cnm-args) | 462 | methods.") |
| 454 | (apply next (or cnm-args args))) | ||
| 455 | args)))))) | ||
| 456 | fun) | ||
| 457 | 463 | ||
| 458 | (defvar cl--generic-combined-method-memoization | 464 | (defvar cl--generic-combined-method-memoization |
| 459 | (make-hash-table :test #'equal :weakness 'value) | 465 | (make-hash-table :test #'equal :weakness 'value) |
| @@ -462,54 +468,82 @@ This is particularly useful when many different tags select the same set | |||
| 462 | of methods, since this table then allows us to share a single combined-method | 468 | of methods, since this table then allows us to share a single combined-method |
| 463 | for all those different tags in the method-cache.") | 469 | for all those different tags in the method-cache.") |
| 464 | 470 | ||
| 465 | (defun cl--generic-no-next-method-function (generic) | ||
| 466 | (lambda (&rest args) | ||
| 467 | ;; FIXME: CLOS passes as second arg the "calling method". | ||
| 468 | ;; We don't currently have "method objects" like CLOS | ||
| 469 | ;; does so we can't really do it the CLOS way. | ||
| 470 | ;; The closest would be to pass the lambda corresponding | ||
| 471 | ;; to the method, or maybe the ((SPECIALIZERS | ||
| 472 | ;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method | ||
| 473 | ;; table, but the caller wouldn't be able to do much with | ||
| 474 | ;; it anyway. So we pass nil for now. | ||
| 475 | (apply #'cl-no-next-method generic nil args))) | ||
| 476 | |||
| 477 | (defun cl--generic-build-combined-method (generic-name methods) | 471 | (defun cl--generic-build-combined-method (generic-name methods) |
| 478 | (let ((mets-by-qual ())) | 472 | (cl--generic-with-memoization |
| 479 | (dolist (qm methods) | 473 | (gethash (cons generic-name methods) |
| 480 | (push (cdr qm) (alist-get (cdar qm) mets-by-qual))) | 474 | cl--generic-combined-method-memoization) |
| 481 | (cl--generic-with-memoization | 475 | (let ((mets-by-qual ())) |
| 482 | (gethash (cons generic-name mets-by-qual) | 476 | (dolist (method methods) |
| 483 | cl--generic-combined-method-memoization) | 477 | (let* ((qualifiers (cl--generic-method-qualifiers method)) |
| 484 | (cond | 478 | (x (assoc qualifiers mets-by-qual))) |
| 485 | ((null mets-by-qual) | 479 | ;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'. |
| 486 | (lambda (&rest args) | 480 | ;;(push (cdr qm) (alist-get qualifiers mets-by-qual))) |
| 487 | (apply #'cl-no-applicable-method generic-name args))) | 481 | (if x |
| 488 | ((null (alist-get :primary mets-by-qual)) | 482 | (push method (cdr x)) |
| 489 | (lambda (&rest args) | 483 | (push (list qualifiers method) mets-by-qual)))) |
| 490 | (apply #'cl-no-primary-method generic-name args))) | 484 | (funcall cl-generic-method-combination-function |
| 491 | (t | 485 | generic-name mets-by-qual)))) |
| 492 | (let* ((fun (cl--generic-no-next-method-function generic-name)) | 486 | |
| 493 | ;; We use `cdr' to drop the `uses-cnm' annotations. | 487 | (defun cl--generic-no-next-method-function (generic method) |
| 494 | (before | 488 | (lambda (&rest args) |
| 495 | (mapcar #'cdr (reverse (alist-get :before mets-by-qual)))) | 489 | (apply #'cl-no-next-method generic method args))) |
| 496 | (after (mapcar #'cdr (alist-get :after mets-by-qual)))) | 490 | |
| 497 | (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual))) | 491 | (defun cl-generic-call-method (generic-name method &optional fun) |
| 498 | (when (or after before) | 492 | "Return a function that calls METHOD. |
| 499 | (let ((next fun)) | 493 | FUN is the function that should be called when METHOD calls |
| 500 | (setq fun (lambda (&rest args) | 494 | `call-next-method'." |
| 501 | (dolist (bf before) | 495 | (if (not (cl--generic-method-uses-cnm method)) |
| 502 | (apply bf args)) | 496 | (cl--generic-method-function method) |
| 503 | (prog1 | 497 | (let ((met-fun (cl--generic-method-function method)) |
| 504 | (apply next args) | 498 | (next (or fun (cl--generic-no-next-method-function |
| 505 | (dolist (af after) | 499 | generic-name method)))) |
| 506 | (apply af args))))))) | 500 | (lambda (&rest args) |
| 507 | (cl--generic-nest fun (alist-get :around mets-by-qual)))))))) | 501 | (apply met-fun |
| 508 | 502 | ;; FIXME: This sucks: passing just `next' would | |
| 509 | (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function 'dummy)) | 503 | ;; be a lot more efficient than the lambda+apply |
| 504 | ;; quasi-η, but we need this to implement the | ||
| 505 | ;; "if call-next-method is called with no | ||
| 506 | ;; arguments, then use the previous arguments". | ||
| 507 | (lambda (&rest cnm-args) | ||
| 508 | (apply next (or cnm-args args))) | ||
| 509 | args))))) | ||
| 510 | |||
| 511 | (defun cl--generic-standard-method-combination (generic-name mets-by-qual) | ||
| 512 | (dolist (x mets-by-qual) | ||
| 513 | (unless (member (car x) '(() (:after) (:before) (:around))) | ||
| 514 | (error "Unsupported qualifiers in function %S: %S" generic-name (car x)))) | ||
| 515 | (cond | ||
| 516 | ((null mets-by-qual) | ||
| 517 | (lambda (&rest args) | ||
| 518 | (apply #'cl-no-applicable-method generic-name args))) | ||
| 519 | ((null (alist-get nil mets-by-qual)) | ||
| 520 | (lambda (&rest args) | ||
| 521 | (apply #'cl-no-primary-method generic-name args))) | ||
| 522 | (t | ||
| 523 | (let* ((fun nil) | ||
| 524 | (ab-call (lambda (m) (cl-generic-call-method generic-name m))) | ||
| 525 | (before | ||
| 526 | (mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual))))) | ||
| 527 | (after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual))))) | ||
| 528 | (dolist (method (cdr (assoc nil mets-by-qual))) | ||
| 529 | (setq fun (cl-generic-call-method generic-name method fun))) | ||
| 530 | (when (or after before) | ||
| 531 | (let ((next fun)) | ||
| 532 | (setq fun (lambda (&rest args) | ||
| 533 | (dolist (bf before) | ||
| 534 | (apply bf args)) | ||
| 535 | (prog1 | ||
| 536 | (apply next args) | ||
| 537 | (dolist (af after) | ||
| 538 | (apply af args))))))) | ||
| 539 | (dolist (method (cdr (assoc '(:around) mets-by-qual))) | ||
| 540 | (setq fun (cl-generic-call-method generic-name method fun))) | ||
| 541 | fun)))) | ||
| 542 | |||
| 543 | (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) | ||
| 510 | (defconst cl--generic-cnm-sample | 544 | (defconst cl--generic-cnm-sample |
| 511 | (funcall (cl--generic-build-combined-method | 545 | (funcall (cl--generic-build-combined-method |
| 512 | nil `(((specializer . :primary) t . ,#'identity))))) | 546 | nil (list (cl--generic-method-make () () t #'identity))))) |
| 513 | 547 | ||
| 514 | (defun cl--generic-isnot-nnm-p (cnm) | 548 | (defun cl--generic-isnot-nnm-p (cnm) |
| 515 | "Return non-nil if CNM is the function that calls `cl-no-next-method'." | 549 | "Return non-nil if CNM is the function that calls `cl-no-next-method'." |
| @@ -540,11 +574,13 @@ for all those different tags in the method-cache.") | |||
| 540 | (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) | 574 | (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) |
| 541 | (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) | 575 | (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) |
| 542 | (methods '())) | 576 | (methods '())) |
| 543 | (dolist (method-desc (cl--generic-method-table generic)) | 577 | (dolist (method (cl--generic-method-table generic)) |
| 544 | (let* ((specializer (or (nth dispatch-arg (caar method-desc)) t)) | 578 | (let* ((specializer (or (nth dispatch-arg |
| 579 | (cl--generic-method-specializers method)) | ||
| 580 | t)) | ||
| 545 | (m (member specializer types))) | 581 | (m (member specializer types))) |
| 546 | (when m | 582 | (when m |
| 547 | (push (cons (length m) method-desc) methods)))) | 583 | (push (cons (length m) method) methods)))) |
| 548 | ;; Sort the methods, most specific first. | 584 | ;; Sort the methods, most specific first. |
| 549 | ;; It would be tempting to sort them once and for all in the method-table | 585 | ;; It would be tempting to sort them once and for all in the method-table |
| 550 | ;; rather than here, but the order might depend on the actual argument | 586 | ;; rather than here, but the order might depend on the actual argument |
| @@ -587,6 +623,14 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 587 | (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1")) | 623 | (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1")) |
| 588 | (error "cl-next-method-p only allowed inside primary and around methods")) | 624 | (error "cl-next-method-p only allowed inside primary and around methods")) |
| 589 | 625 | ||
| 626 | ;;;###autoload | ||
| 627 | (defun cl-find-method (generic qualifiers specializers) | ||
| 628 | (car (cl--generic-member-method | ||
| 629 | specializers qualifiers | ||
| 630 | (cl--generic-method-table (cl--generic generic))))) | ||
| 631 | |||
| 632 | (defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers) | ||
| 633 | |||
| 590 | ;;; Add support for describe-function | 634 | ;;; Add support for describe-function |
| 591 | 635 | ||
| 592 | (defun cl--generic-search-method (met-name) | 636 | (defun cl--generic-search-method (met-name) |
| @@ -611,22 +655,30 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 611 | `(cl-defmethod . ,#'cl--generic-search-method))) | 655 | `(cl-defmethod . ,#'cl--generic-search-method))) |
| 612 | 656 | ||
| 613 | (defun cl--generic-method-info (method) | 657 | (defun cl--generic-method-info (method) |
| 614 | (pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method)) | 658 | (let* ((specializers (cl--generic-method-specializers method)) |
| 615 | (let* ((args (help-function-arglist function 'names)) | 659 | (qualifiers (cl--generic-method-qualifiers method)) |
| 616 | (docstring (documentation function)) | 660 | (uses-cnm (cl--generic-method-uses-cnm method)) |
| 617 | (doconly (if docstring | 661 | (function (cl--generic-method-function method)) |
| 618 | (let ((split (help-split-fundoc docstring nil))) | 662 | (args (help-function-arglist function 'names)) |
| 619 | (if split (cdr split) docstring)))) | 663 | (docstring (documentation function)) |
| 620 | (combined-args ())) | 664 | (qual-string |
| 621 | (if uses-cnm (setq args (cdr args))) | 665 | (if (null qualifiers) "" |
| 622 | (dolist (specializer specializers) | 666 | (cl-assert (consp qualifiers)) |
| 623 | (let ((arg (if (eq '&rest (car args)) | 667 | (let ((s (prin1-to-string qualifiers))) |
| 624 | (intern (format "arg%d" (length combined-args))) | 668 | (concat (substring s 1 -1) " ")))) |
| 625 | (pop args)))) | 669 | (doconly (if docstring |
| 626 | (push (if (eq specializer t) arg (list arg specializer)) | 670 | (let ((split (help-split-fundoc docstring nil))) |
| 627 | combined-args))) | 671 | (if split (cdr split) docstring)))) |
| 628 | (setq combined-args (append (nreverse combined-args) args)) | 672 | (combined-args ())) |
| 629 | (list qualifier combined-args doconly)))) | 673 | (if uses-cnm (setq args (cdr args))) |
| 674 | (dolist (specializer specializers) | ||
| 675 | (let ((arg (if (eq '&rest (car args)) | ||
| 676 | (intern (format "arg%d" (length combined-args))) | ||
| 677 | (pop args)))) | ||
| 678 | (push (if (eq specializer t) arg (list arg specializer)) | ||
| 679 | combined-args))) | ||
| 680 | (setq combined-args (append (nreverse combined-args) args)) | ||
| 681 | (list qual-string combined-args doconly))) | ||
| 630 | 682 | ||
| 631 | (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) | 683 | (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) |
| 632 | (defun cl--generic-describe (function) | 684 | (defun cl--generic-describe (function) |
| @@ -640,8 +692,9 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 640 | (dolist (method (cl--generic-method-table generic)) | 692 | (dolist (method (cl--generic-method-table generic)) |
| 641 | (let* ((info (cl--generic-method-info method))) | 693 | (let* ((info (cl--generic-method-info method))) |
| 642 | ;; FIXME: Add hyperlinks for the types as well. | 694 | ;; FIXME: Add hyperlinks for the types as well. |
| 643 | (insert (format "%S %S" (nth 0 info) (nth 1 info))) | 695 | (insert (format "%s%S" (nth 0 info) (nth 1 info))) |
| 644 | (let* ((met-name (cons function (caar method))) | 696 | (let* ((met-name (cons function |
| 697 | (cl--generic-method-specializers method))) | ||
| 645 | (file (find-lisp-object-file-name met-name 'cl-defmethod))) | 698 | (file (find-lisp-object-file-name met-name 'cl-defmethod))) |
| 646 | (when file | 699 | (when file |
| 647 | (insert " in `") | 700 | (insert " in `") |
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index da3eab73fc4..1b204631fb8 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el | |||
| @@ -342,6 +342,8 @@ The two cases that are handled are: | |||
| 342 | - renaming of F when it's a function defined via `cl-labels' or `labels'." | 342 | - renaming of F when it's a function defined via `cl-labels' or `labels'." |
| 343 | (require 'cl-macs) | 343 | (require 'cl-macs) |
| 344 | (declare-function cl--expr-contains-any "cl-macs" (x y)) | 344 | (declare-function cl--expr-contains-any "cl-macs" (x y)) |
| 345 | (declare-function cl--labels-convert "cl-macs" (f)) | ||
| 346 | (defvar cl--labels-convert-cache) | ||
| 345 | (cond | 347 | (cond |
| 346 | ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked | 348 | ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked |
| 347 | ;; *after* handling `function', but we want to stop macroexpansion from | 349 | ;; *after* handling `function', but we want to stop macroexpansion from |
| @@ -374,13 +376,10 @@ The two cases that are handled are: | |||
| 374 | (setq cl--function-convert-cache (cons newf res)) | 376 | (setq cl--function-convert-cache (cons newf res)) |
| 375 | res)))) | 377 | res)))) |
| 376 | (t | 378 | (t |
| 377 | (let ((found (assq f macroexpand-all-environment))) | 379 | (setq cl--labels-convert-cache cl--function-convert-cache) |
| 378 | (if (and found (ignore-errors | 380 | (prog1 |
| 379 | (eq (cadr (cl-caddr found)) 'cl-labels-args))) | 381 | (cl--labels-convert f) |
| 380 | (cadr (cl-caddr (cl-cadddr found))) | 382 | (setq cl--function-convert-cache cl--labels-convert-cache))))) |
| 381 | (let ((res `(function ,f))) | ||
| 382 | (setq cl--function-convert-cache (cons f res)) | ||
| 383 | res)))))) | ||
| 384 | 383 | ||
| 385 | (defmacro lexical-let (bindings &rest body) | 384 | (defmacro lexical-let (bindings &rest body) |
| 386 | "Like `let', but lexically scoped. | 385 | "Like `let', but lexically scoped. |
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index a250ea60d21..52da4c99eaf 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el | |||
| @@ -162,7 +162,8 @@ The new mode runs the hook constructed by the function | |||
| 162 | See Info node `(elisp)Derived Modes' for more details." | 162 | See Info node `(elisp)Derived Modes' for more details." |
| 163 | (declare (debug (&define name symbolp sexp [&optional stringp] | 163 | (declare (debug (&define name symbolp sexp [&optional stringp] |
| 164 | [&rest keywordp sexp] def-body)) | 164 | [&rest keywordp sexp] def-body)) |
| 165 | (doc-string 4)) | 165 | (doc-string 4) |
| 166 | (indent 3)) | ||
| 166 | 167 | ||
| 167 | (when (and docstring (not (stringp docstring))) | 168 | (when (and docstring (not (stringp docstring))) |
| 168 | ;; Some trickiness, since what appears to be the docstring may really be | 169 | ;; Some trickiness, since what appears to be the docstring may really be |
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index c2dabf7f446..fcca99d79d5 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el | |||
| @@ -181,7 +181,8 @@ Summary: | |||
| 181 | (lambda (generic arg &rest args) (apply code arg generic args))) | 181 | (lambda (generic arg &rest args) (apply code arg generic args))) |
| 182 | (_ code)))) | 182 | (_ code)))) |
| 183 | (cl-generic-define-method | 183 | (cl-generic-define-method |
| 184 | method (if kind (list kind)) specializers uses-cnm | 184 | method (unless (memq kind '(nil :primary)) (list kind)) |
| 185 | specializers uses-cnm | ||
| 185 | (if uses-cnm | 186 | (if uses-cnm |
| 186 | (let* ((docstring (documentation code 'raw)) | 187 | (let* ((docstring (documentation code 'raw)) |
| 187 | (args (help-function-arglist code 'preserve-names)) | 188 | (args (help-function-arglist code 'preserve-names)) |
| @@ -201,11 +202,11 @@ Summary: | |||
| 201 | ;; applicable but only of the before/after kind. So if we add a :before | 202 | ;; applicable but only of the before/after kind. So if we add a :before |
| 202 | ;; or :after, make sure there's a matching dummy primary. | 203 | ;; or :after, make sure there's a matching dummy primary. |
| 203 | (when (and (memq kind '(:before :after)) | 204 | (when (and (memq kind '(:before :after)) |
| 204 | (not (assoc (cons (mapcar (lambda (arg) | 205 | ;; FIXME: Use `cl-find-method'? |
| 205 | (if (consp arg) (nth 1 arg) t)) | 206 | (not (cl-find-method method () |
| 206 | specializers) | 207 | (mapcar (lambda (arg) |
| 207 | :primary) | 208 | (if (consp arg) (nth 1 arg) t)) |
| 208 | (cl--generic-method-table (cl--generic method))))) | 209 | specializers)))) |
| 209 | (cl-generic-define-method method () specializers t | 210 | (cl-generic-define-method method () specializers t |
| 210 | (lambda (cnm &rest args) | 211 | (lambda (cnm &rest args) |
| 211 | (if (cl--generic-isnot-nnm-p cnm) | 212 | (if (cl--generic-isnot-nnm-p cnm) |
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 261138bfbf8..7492f0522ab 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el | |||
| @@ -1258,7 +1258,7 @@ method invocation orders of the involved classes." | |||
| 1258 | (eieio--class-precedence-list tag)))) | 1258 | (eieio--class-precedence-list tag)))) |
| 1259 | 1259 | ||
| 1260 | 1260 | ||
| 1261 | ;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "57805f02023795a01567781e70aaf9f9") | 1261 | ;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "b568ffb3c90ed5d0ae673f0051d608ee") |
| 1262 | ;;; Generated autoloads from eieio-compat.el | 1262 | ;;; Generated autoloads from eieio-compat.el |
| 1263 | 1263 | ||
| 1264 | (autoload 'eieio--defalias "eieio-compat" "\ | 1264 | (autoload 'eieio--defalias "eieio-compat" "\ |
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 6534bd0fecf..119f7cce038 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el | |||
| @@ -129,22 +129,6 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 129 | (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) | 129 | (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) |
| 130 | (data-debug-insert-object-slots obj "]")) | 130 | (data-debug-insert-object-slots obj "]")) |
| 131 | 131 | ||
| 132 | ;;; DEBUG FUNCTIONS | ||
| 133 | ;; | ||
| 134 | (defun eieio-debug-methodinvoke (method class) | ||
| 135 | "Show the method invocation order for METHOD with CLASS object." | ||
| 136 | (interactive "aMethod: \nXClass Expression: ") | ||
| 137 | (let* ((eieio-pre-method-execution-functions | ||
| 138 | (lambda (l) (throw 'moose l) )) | ||
| 139 | (data | ||
| 140 | (catch 'moose (eieio--generic-call | ||
| 141 | method (list class)))) | ||
| 142 | (_buf (data-debug-new-buffer "*Method Invocation*")) | ||
| 143 | (data2 (mapcar (lambda (sym) | ||
| 144 | (symbol-function (car sym))) | ||
| 145 | data))) | ||
| 146 | (data-debug-insert-thing data2 ">" ""))) | ||
| 147 | |||
| 148 | (provide 'eieio-datadebug) | 132 | (provide 'eieio-datadebug) |
| 149 | 133 | ||
| 150 | ;;; eieio-datadebug.el ends here | 134 | ;;; eieio-datadebug.el ends here |
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index a131b02ee16..8d40edf5624 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el | |||
| @@ -129,9 +129,9 @@ If CLASS is actually an object, then also display current values of that object. | |||
| 129 | (insert "`") | 129 | (insert "`") |
| 130 | (help-insert-xref-button (symbol-name generic) 'help-function generic) | 130 | (help-insert-xref-button (symbol-name generic) 'help-function generic) |
| 131 | (insert "'") | 131 | (insert "'") |
| 132 | (pcase-dolist (`(,qualifier ,args ,doc) | 132 | (pcase-dolist (`(,qualifiers ,args ,doc) |
| 133 | (eieio-method-documentation generic class)) | 133 | (eieio-method-documentation generic class)) |
| 134 | (insert (format " %S %S\n" qualifier args) | 134 | (insert (format " %s%S\n" qualifiers args) |
| 135 | (or doc ""))) | 135 | (or doc ""))) |
| 136 | (insert "\n\n"))))) | 136 | (insert "\n\n"))))) |
| 137 | 137 | ||
| @@ -325,10 +325,9 @@ methods for CLASS." | |||
| 325 | (and generic | 325 | (and generic |
| 326 | (catch 'found | 326 | (catch 'found |
| 327 | (if (null class) (throw 'found t)) | 327 | (if (null class) (throw 'found t)) |
| 328 | (pcase-dolist (`((,specializers . ,_qualifier) . ,_) | 328 | (dolist (method (cl--generic-method-table generic)) |
| 329 | (cl--generic-method-table generic)) | ||
| 330 | (if (eieio--specializers-apply-to-class-p | 329 | (if (eieio--specializers-apply-to-class-p |
| 331 | specializers class) | 330 | (cl--generic-method-specializers method) class) |
| 332 | (throw 'found t)))) | 331 | (throw 'found t)))) |
| 333 | (push symbol l))))) | 332 | (push symbol l))))) |
| 334 | l)) | 333 | l)) |
| @@ -336,15 +335,14 @@ methods for CLASS." | |||
| 336 | (defun eieio-method-documentation (generic class) | 335 | (defun eieio-method-documentation (generic class) |
| 337 | "Return info for all methods of GENERIC applicable to CLASS. | 336 | "Return info for all methods of GENERIC applicable to CLASS. |
| 338 | The value returned is a list of elements of the form | 337 | The value returned is a list of elements of the form |
| 339 | \(QUALIFIER ARGS DOC)." | 338 | \(QUALIFIERS ARGS DOC)." |
| 340 | (let ((generic (cl--generic generic)) | 339 | (let ((generic (cl--generic generic)) |
| 341 | (docs ())) | 340 | (docs ())) |
| 342 | (when generic | 341 | (when generic |
| 343 | (dolist (method (cl--generic-method-table generic)) | 342 | (dolist (method (cl--generic-method-table generic)) |
| 344 | (pcase-let ((`((,specializers . ,_qualifier) . ,_) method)) | 343 | (when (eieio--specializers-apply-to-class-p |
| 345 | (when (eieio--specializers-apply-to-class-p | 344 | (cl--generic-method-specializers method) class) |
| 346 | specializers class) | 345 | (push (cl--generic-method-info method) docs)))) |
| 347 | (push (cl--generic-method-info method) docs))))) | ||
| 348 | docs)) | 346 | docs)) |
| 349 | 347 | ||
| 350 | ;;; METHOD STATS | 348 | ;;; METHOD STATS |
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 3dba8e0e7bf..91469b4b96c 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -942,7 +942,7 @@ Optional argument GROUP is the sub-group of slots to display. | |||
| 942 | 942 | ||
| 943 | ;;;*** | 943 | ;;;*** |
| 944 | 944 | ||
| 945 | ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d7b8682e15aebad7dbe6384dc5ed655f") | 945 | ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b849f8bf1312d5ef57e53d02173e4b5a") |
| 946 | ;;; Generated autoloads from eieio-opt.el | 946 | ;;; Generated autoloads from eieio-opt.el |
| 947 | 947 | ||
| 948 | (autoload 'eieio-browse "eieio-opt" "\ | 948 | (autoload 'eieio-browse "eieio-opt" "\ |
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 7ef526b4253..7bf4a6e01d6 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog | |||
| @@ -1,3 +1,23 @@ | |||
| 1 | 2015-01-27 Lars Ingebrigtsen <larsi@gnus.org> | ||
| 2 | |||
| 3 | * nnir.el (nnir-imap-expr-to-imap): Check for literal+ capability in | ||
| 4 | IMAP. | ||
| 5 | |||
| 6 | 2015-01-27 Eric Abrahamsen <eric@ericabrahamsen.net> | ||
| 7 | |||
| 8 | * nnir.el (nnir-run-imap): Enable non-ASCII IMAP searches. | ||
| 9 | |||
| 10 | * nnmairix.el ("nnmairix"): Declare nnmairix as virtual. | ||
| 11 | |||
| 12 | * gnus-bcklg.el (gnus-backlog-enter-article): No virtual groups should | ||
| 13 | be added to the backlog. | ||
| 14 | |||
| 15 | 2015-01-26 Trevor Murphy <trevor.m.murphy@gmail.com> | ||
| 16 | |||
| 17 | * nnimap.el (nnimap-header-parameters): Refactor and request | ||
| 18 | X-GM-LABELS if it's been announced. | ||
| 19 | (nnimap-transform-headers): Gather and output GM-LABELS. | ||
| 20 | |||
| 1 | 2015-01-26 Peder O. Klingenberg <peder@klingenberg.no> | 21 | 2015-01-26 Peder O. Klingenberg <peder@klingenberg.no> |
| 2 | 22 | ||
| 3 | * mm-decode.el (mm-display-part): Make non-string methods work. | 23 | * mm-decode.el (mm-display-part): Make non-string methods work. |
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index b26f367a79b..e0c457a8829 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el | |||
| @@ -61,7 +61,7 @@ | |||
| 61 | 61 | ||
| 62 | (defun gnus-backlog-enter-article (group number buffer) | 62 | (defun gnus-backlog-enter-article (group number buffer) |
| 63 | (when (and (numberp number) | 63 | (when (and (numberp number) |
| 64 | (not (string-match "^nnvirtual" group))) | 64 | (not (gnus-virtual-group-p group))) |
| 65 | (gnus-backlog-setup) | 65 | (gnus-backlog-setup) |
| 66 | (let ((ident (intern (concat group ":" (int-to-string number)) | 66 | (let ((ident (intern (concat group ":" (int-to-string number)) |
| 67 | gnus-backlog-hashtb)) | 67 | gnus-backlog-hashtb)) |
| @@ -126,7 +126,7 @@ | |||
| 126 | 126 | ||
| 127 | (defun gnus-backlog-request-article (group number &optional buffer) | 127 | (defun gnus-backlog-request-article (group number &optional buffer) |
| 128 | (when (and (numberp number) | 128 | (when (and (numberp number) |
| 129 | (not (string-match "^nnvirtual" group))) | 129 | (not (gnus-virtual-group-p group))) |
| 130 | (gnus-backlog-setup) | 130 | (gnus-backlog-setup) |
| 131 | (let ((ident (intern (concat group ":" (int-to-string number)) | 131 | (let ((ident (intern (concat group ":" (int-to-string number)) |
| 132 | gnus-backlog-hashtb)) | 132 | gnus-backlog-hashtb)) |
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index ced55619881..8e81abcf9c0 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el | |||
| @@ -166,14 +166,21 @@ textual parts.") | |||
| 166 | (nnimap-find-process-buffer nntp-server-buffer)) | 166 | (nnimap-find-process-buffer nntp-server-buffer)) |
| 167 | 167 | ||
| 168 | (defun nnimap-header-parameters () | 168 | (defun nnimap-header-parameters () |
| 169 | (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" | 169 | (let (params) |
| 170 | (format | 170 | (push "UID" params) |
| 171 | (push "RFC822.SIZE" params) | ||
| 172 | (when (nnimap-capability "X-GM-EXT-1") | ||
| 173 | (push "X-GM-LABELS" params)) | ||
| 174 | (push "BODYSTRUCTURE" params) | ||
| 175 | (push (format | ||
| 171 | (if (nnimap-ver4-p) | 176 | (if (nnimap-ver4-p) |
| 172 | "BODY.PEEK[HEADER.FIELDS %s]" | 177 | "BODY.PEEK[HEADER.FIELDS %s]" |
| 173 | "RFC822.HEADER.LINES %s") | 178 | "RFC822.HEADER.LINES %s") |
| 174 | (append '(Subject From Date Message-Id | 179 | (append '(Subject From Date Message-Id |
| 175 | References In-Reply-To Xref) | 180 | References In-Reply-To Xref) |
| 176 | nnmail-extra-headers)))) | 181 | nnmail-extra-headers)) |
| 182 | params) | ||
| 183 | (format "%s" (nreverse params)))) | ||
| 177 | 184 | ||
| 178 | (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) | 185 | (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) |
| 179 | (when group | 186 | (when group |
| @@ -197,7 +204,7 @@ textual parts.") | |||
| 197 | 204 | ||
| 198 | (defun nnimap-transform-headers () | 205 | (defun nnimap-transform-headers () |
| 199 | (goto-char (point-min)) | 206 | (goto-char (point-min)) |
| 200 | (let (article lines size string) | 207 | (let (article lines size string labels) |
| 201 | (block nil | 208 | (block nil |
| 202 | (while (not (eobp)) | 209 | (while (not (eobp)) |
| 203 | (while (not (looking-at "\\* [0-9]+ FETCH")) | 210 | (while (not (looking-at "\\* [0-9]+ FETCH")) |
| @@ -232,6 +239,9 @@ textual parts.") | |||
| 232 | t) | 239 | t) |
| 233 | (match-string 1))) | 240 | (match-string 1))) |
| 234 | (beginning-of-line) | 241 | (beginning-of-line) |
| 242 | (when (search-forward "X-GM-LABELS" (line-end-position) t) | ||
| 243 | (setq labels (ignore-errors (read (current-buffer))))) | ||
| 244 | (beginning-of-line) | ||
| 235 | (when (search-forward "BODYSTRUCTURE" (line-end-position) t) | 245 | (when (search-forward "BODYSTRUCTURE" (line-end-position) t) |
| 236 | (let ((structure (ignore-errors | 246 | (let ((structure (ignore-errors |
| 237 | (read (current-buffer))))) | 247 | (read (current-buffer))))) |
| @@ -251,6 +261,8 @@ textual parts.") | |||
| 251 | (insert (format "Chars: %s\n" size))) | 261 | (insert (format "Chars: %s\n" size))) |
| 252 | (when lines | 262 | (when lines |
| 253 | (insert (format "Lines: %s\n" lines))) | 263 | (insert (format "Lines: %s\n" lines))) |
| 264 | (when labels | ||
| 265 | (insert (format "X-GM-LABELS: %s\n" labels))) | ||
| 254 | ;; Most servers have a blank line after the headers, but | 266 | ;; Most servers have a blank line after the headers, but |
| 255 | ;; Davmail doesn't. | 267 | ;; Davmail doesn't. |
| 256 | (unless (re-search-forward "^\r$\\|^)\r?$" nil t) | 268 | (unless (re-search-forward "^\r$\\|^)\r?$" nil t) |
diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 08ca7c7e06b..6d111e89e80 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el | |||
| @@ -284,6 +284,8 @@ is `(valuefunc member)'." | |||
| 284 | (eval-when-compile | 284 | (eval-when-compile |
| 285 | (autoload 'nnimap-buffer "nnimap") | 285 | (autoload 'nnimap-buffer "nnimap") |
| 286 | (autoload 'nnimap-command "nnimap") | 286 | (autoload 'nnimap-command "nnimap") |
| 287 | (autoload 'nnimap-capability "nnimap") | ||
| 288 | (autoload 'nnimap-wait-for-line "nnimap") | ||
| 287 | (autoload 'nnimap-change-group "nnimap") | 289 | (autoload 'nnimap-change-group "nnimap") |
| 288 | (autoload 'nnimap-make-thread-query "nnimap") | 290 | (autoload 'nnimap-make-thread-query "nnimap") |
| 289 | (autoload 'gnus-registry-action "gnus-registry") | 291 | (autoload 'gnus-registry-action "gnus-registry") |
| @@ -968,33 +970,52 @@ details on the language and supported extensions." | |||
| 968 | (catch 'found | 970 | (catch 'found |
| 969 | (mapcar | 971 | (mapcar |
| 970 | #'(lambda (group) | 972 | #'(lambda (group) |
| 971 | (let (artlist) | 973 | (let (artlist) |
| 972 | (condition-case () | 974 | (condition-case () |
| 973 | (when (nnimap-change-group | 975 | (when (nnimap-change-group |
| 974 | (gnus-group-short-name group) server) | 976 | (gnus-group-short-name group) server) |
| 975 | (with-current-buffer (nnimap-buffer) | 977 | (with-current-buffer (nnimap-buffer) |
| 976 | (message "Searching %s..." group) | 978 | (message "Searching %s..." group) |
| 977 | (let ((arts 0) | 979 | (let* ((arts 0) |
| 978 | (result (nnimap-command "UID SEARCH %s" | 980 | (literal+ (nnimap-capability "LITERAL+")) |
| 979 | (if (string= criteria "") | 981 | (search (split-string |
| 980 | qstring | 982 | (if (string= criteria "") |
| 981 | (nnir-imap-make-query | 983 | qstring |
| 982 | criteria qstring))))) | 984 | (nnir-imap-make-query |
| 983 | (mapc | 985 | criteria qstring)) |
| 984 | (lambda (artnum) | 986 | "\n")) |
| 985 | (let ((artn (string-to-number artnum))) | 987 | (coding (upcase |
| 986 | (when (> artn 0) | 988 | (replace-regexp-in-string |
| 987 | (push (vector group artn 100) | 989 | "-\\(unix\\|dos\\|mac\\)" "" |
| 988 | artlist) | 990 | (symbol-name |
| 989 | (when (assq 'shortcut query) | 991 | (cdr default-process-coding-system))))) |
| 990 | (throw 'found (list artlist))) | 992 | call result) |
| 991 | (setq arts (1+ arts))))) | 993 | (setq call (nnimap-send-command |
| 992 | (and (car result) | 994 | "UID SEARCH CHARSET %s %s" coding (pop search))) |
| 993 | (cdr (assoc "SEARCH" (cdr result))))) | 995 | (while search ; Non-ascii search terms |
| 994 | (message "Searching %s... %d matches" group arts))) | 996 | (unless literal+ |
| 995 | (message "Searching %s...done" group)) | 997 | (nnimap-wait-for-line "^\\+\\(.*\\)\n")) |
| 996 | (quit nil)) | 998 | (process-send-string (get-buffer-process (current-buffer)) (pop search)) |
| 997 | (nreverse artlist))) | 999 | (process-send-string (get-buffer-process (current-buffer)) |
| 1000 | (if (nnimap-newlinep nnimap-object) | ||
| 1001 | "\n" | ||
| 1002 | "\r\n"))) | ||
| 1003 | (setq result (nnimap-get-response call)) | ||
| 1004 | (mapc | ||
| 1005 | (lambda (artnum) | ||
| 1006 | (let ((artn (string-to-number artnum))) | ||
| 1007 | (when (> artn 0) | ||
| 1008 | (push (vector group artn 100) | ||
| 1009 | artlist) | ||
| 1010 | (when (assq 'shortcut query) | ||
| 1011 | (throw 'found (list artlist))) | ||
| 1012 | (setq arts (1+ arts))))) | ||
| 1013 | (and (car result) | ||
| 1014 | (cdr (assoc "SEARCH" (cdr result))))) | ||
| 1015 | (message "Searching %s... %d matches" group arts))) | ||
| 1016 | (message "Searching %s...done" group)) | ||
| 1017 | (quit nil)) | ||
| 1018 | (nreverse artlist))) | ||
| 998 | groups)))))) | 1019 | groups)))))) |
| 999 | 1020 | ||
| 1000 | (defun nnir-imap-make-query (criteria qstring) | 1021 | (defun nnir-imap-make-query (criteria qstring) |
| @@ -1048,25 +1069,30 @@ In future the following will be added to the language: | |||
| 1048 | (defun nnir-imap-expr-to-imap (criteria expr) | 1069 | (defun nnir-imap-expr-to-imap (criteria expr) |
| 1049 | "Convert EXPR into an IMAP search expression on CRITERIA" | 1070 | "Convert EXPR into an IMAP search expression on CRITERIA" |
| 1050 | ;; What sort of expression is this, eh? | 1071 | ;; What sort of expression is this, eh? |
| 1051 | (cond | 1072 | (let ((literal+ (nnimap-capability "LITERAL+"))) |
| 1052 | ;; Simple string term | 1073 | (cond |
| 1053 | ((stringp expr) | 1074 | ;; Simple string term |
| 1054 | (format "%s %S" criteria expr)) | 1075 | ((stringp expr) |
| 1055 | ;; Trivial term: and | 1076 | (format "%s %S" criteria expr)) |
| 1056 | ((eq expr 'and) nil) | 1077 | ;; Trivial term: and |
| 1057 | ;; Composite term: or expression | 1078 | ((eq expr 'and) nil) |
| 1058 | ((eq (car-safe expr) 'or) | 1079 | ;; Composite term: or expression |
| 1059 | (format "OR %s %s" | 1080 | ((eq (car-safe expr) 'or) |
| 1060 | (nnir-imap-expr-to-imap criteria (second expr)) | 1081 | (format "OR %s %s" |
| 1061 | (nnir-imap-expr-to-imap criteria (third expr)))) | 1082 | (nnir-imap-expr-to-imap criteria (second expr)) |
| 1062 | ;; Composite term: just the fax, mam | 1083 | (nnir-imap-expr-to-imap criteria (third expr)))) |
| 1063 | ((eq (car-safe expr) 'not) | 1084 | ;; Composite term: just the fax, mam |
| 1064 | (format "NOT (%s)" (nnir-imap-query-to-imap criteria (rest expr)))) | 1085 | ((eq (car-safe expr) 'not) |
| 1065 | ;; Composite term: just expand it all. | 1086 | (format "NOT (%s)" (nnir-imap-query-to-imap criteria (rest expr)))) |
| 1066 | ((and (not (null expr)) (listp expr)) | 1087 | ;; Composite term: non-ascii search term |
| 1067 | (format "(%s)" (nnir-imap-query-to-imap criteria expr))) | 1088 | ((numberp (car-safe expr)) |
| 1068 | ;; Complex value, give up for now. | 1089 | (format "%s {%d%s}\n%s" criteria (car expr) |
| 1069 | (t (error "Unhandled input: %S" expr)))) | 1090 | (if literal+ "+" "") (second expr))) |
| 1091 | ;; Composite term: just expand it all. | ||
| 1092 | ((and (not (null expr)) (listp expr)) | ||
| 1093 | (format "(%s)" (nnir-imap-query-to-imap criteria expr))) | ||
| 1094 | ;; Complex value, give up for now. | ||
| 1095 | (t (error "Unhandled input: %S" expr))))) | ||
| 1070 | 1096 | ||
| 1071 | 1097 | ||
| 1072 | (defun nnir-imap-parse-query (string) | 1098 | (defun nnir-imap-parse-query (string) |
| @@ -1108,6 +1134,11 @@ that the search language can then understand and use." | |||
| 1108 | ((eq term 'and) 'and) | 1134 | ((eq term 'and) 'and) |
| 1109 | ;; negated term | 1135 | ;; negated term |
| 1110 | ((eq term 'not) (list 'not (nnir-imap-next-expr))) | 1136 | ((eq term 'not) (list 'not (nnir-imap-next-expr))) |
| 1137 | ;; non-ascii search string | ||
| 1138 | ((and (stringp term) | ||
| 1139 | (not (= (string-bytes term) | ||
| 1140 | (length term)))) | ||
| 1141 | (list (string-bytes term) term)) | ||
| 1111 | ;; generic term | 1142 | ;; generic term |
| 1112 | (t term)))) | 1143 | (t term)))) |
| 1113 | 1144 | ||
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 5a01ce8c25c..96b40e5b845 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el | |||
| @@ -417,7 +417,7 @@ Other back ends might or might not work.") | |||
| 417 | 417 | ||
| 418 | (nnoo-define-basics nnmairix) | 418 | (nnoo-define-basics nnmairix) |
| 419 | 419 | ||
| 420 | (gnus-declare-backend "nnmairix" 'mail 'address) | 420 | (gnus-declare-backend "nnmairix" 'mail 'address 'virtual) |
| 421 | 421 | ||
| 422 | (deffoo nnmairix-open-server (server &optional definitions) | 422 | (deffoo nnmairix-open-server (server &optional definitions) |
| 423 | ;; just set server variables | 423 | ;; just set server variables |
diff --git a/lisp/isearch.el b/lisp/isearch.el index 191ec8270eb..99ca73f9f54 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el | |||
| @@ -2349,6 +2349,8 @@ With argument, add COUNT copies of the character." | |||
| 2349 | (isearch-process-search-char char count)))) | 2349 | (isearch-process-search-char char count)))) |
| 2350 | 2350 | ||
| 2351 | (defun isearch-process-search-char (char &optional count) | 2351 | (defun isearch-process-search-char (char &optional count) |
| 2352 | "Add CHAR to the search string, COUNT times. | ||
| 2353 | Search is updated accordingly." | ||
| 2352 | ;; * and ? are special in regexps when not preceded by \. | 2354 | ;; * and ? are special in regexps when not preceded by \. |
| 2353 | ;; } and | are special in regexps when preceded by \. | 2355 | ;; } and | are special in regexps when preceded by \. |
| 2354 | ;; Nothing special for + because it matches at least once. | 2356 | ;; Nothing special for + because it matches at least once. |
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 622ea72d021..f01f671de9e 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1999-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el index bbdb294da7f..0e54d841d57 100644 --- a/lisp/net/eudc-export.el +++ b/lisp/net/eudc-export.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index b3c9a6db0d5..7416ad090eb 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index 29ddf613376..36a583daa4d 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 4dd80972e3f..cf5d13fce88 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | 9 | ||
| 9 | ;; This file is part of GNU Emacs. | 10 | ;; This file is part of GNU Emacs. |
diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index 0400e5b5bb4..5be2bec0c5d 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 92972c5f99e..1d426a7b7b0 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index 81d8f24ecb2..a11cd95b05d 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el | |||
| @@ -3,7 +3,7 @@ | |||
| 3 | ;; Copyright (C) 2003-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2003-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: John Wiegley <johnw@newartisans.com> | 5 | ;; Author: John Wiegley <johnw@newartisans.com> |
| 6 | ;; Maintainer: emacs-devel@gnu.org | 6 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> |
| 7 | ;; Keywords: comm | 7 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 8 | ;; Package: eudc |
| 9 | 9 | ||
diff --git a/lisp/net/eudcb-ph.el b/lisp/net/eudcb-ph.el index fc6aad671c0..1897e0b08bc 100644 --- a/lisp/net/eudcb-ph.el +++ b/lisp/net/eudcb-ph.el | |||
| @@ -3,7 +3,8 @@ | |||
| 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
| 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> | 6 | ;; Pavel Janík <Pavel@Janik.cz> |
| 7 | ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> | ||
| 7 | ;; Keywords: comm | 8 | ;; Keywords: comm |
| 8 | ;; Package: eudc | 9 | ;; Package: eudc |
| 9 | 10 | ||
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index d298f96bc81..13ff439bef2 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el | |||
| @@ -3816,7 +3816,9 @@ The skeleton will be bound to python-skeleton-NAME." | |||
| 3816 | ;;; Code check | 3816 | ;;; Code check |
| 3817 | 3817 | ||
| 3818 | (defcustom python-check-command | 3818 | (defcustom python-check-command |
| 3819 | "pyflakes" | 3819 | (or (executable-find "pyflakes") |
| 3820 | (executable-find "epylint") | ||
| 3821 | "install pyflakes, pylint or something else") | ||
| 3820 | "Command used to check a Python file." | 3822 | "Command used to check a Python file." |
| 3821 | :type 'string | 3823 | :type 'string |
| 3822 | :group 'python) | 3824 | :group 'python) |
| @@ -3827,7 +3829,7 @@ The skeleton will be bound to python-skeleton-NAME." | |||
| 3827 | :type 'string | 3829 | :type 'string |
| 3828 | :group 'python) | 3830 | :group 'python) |
| 3829 | 3831 | ||
| 3830 | (defvar python-check-custom-command nil | 3832 | (defvar-local python-check-custom-command nil |
| 3831 | "Internal use.") | 3833 | "Internal use.") |
| 3832 | 3834 | ||
| 3833 | (defun python-check (command) | 3835 | (defun python-check (command) |
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 1ee54515bea..6c7f7553f82 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el | |||
| @@ -50,9 +50,6 @@ | |||
| 50 | ;; | 50 | ;; |
| 51 | ;; o chmod should understand "a+x,og-w". | 51 | ;; o chmod should understand "a+x,og-w". |
| 52 | ;; | 52 | ;; |
| 53 | ;; o It's not possible to add a NEW file to a tar archive; not that | ||
| 54 | ;; important, but still... | ||
| 55 | ;; | ||
| 56 | ;; o The code is less efficient that it could be - in a lot of places, I | 53 | ;; o The code is less efficient that it could be - in a lot of places, I |
| 57 | ;; pull a 512-character string out of the buffer and parse it, when I could | 54 | ;; pull a 512-character string out of the buffer and parse it, when I could |
| 58 | ;; be parsing it in place, not garbaging a string. Should redo that. | 55 | ;; be parsing it in place, not garbaging a string. Should redo that. |
| @@ -369,6 +366,80 @@ write-date, checksum, link-type, and link-name." | |||
| 369 | string) | 366 | string) |
| 370 | (tar-parse-octal-integer string)) | 367 | (tar-parse-octal-integer string)) |
| 371 | 368 | ||
| 369 | (defun tar-new-regular-file-header (filename &optional size time) | ||
| 370 | "Return a Tar header for a regular file. | ||
| 371 | The header will lack a proper checksum; use `tar-header-block-checksum' | ||
| 372 | to compute one, or request `tar-header-serialize' to do that. | ||
| 373 | |||
| 374 | Other tar-mode facilities may also require the data-start header | ||
| 375 | field to be set to a valid value. | ||
| 376 | |||
| 377 | If SIZE is not given or nil, it defaults to 0. | ||
| 378 | If TIME is not given or nil, assume now." | ||
| 379 | (make-tar-header | ||
| 380 | nil | ||
| 381 | filename | ||
| 382 | #o644 0 0 (or size 0) | ||
| 383 | (or time (current-time)) | ||
| 384 | nil ; checksum | ||
| 385 | nil nil | ||
| 386 | nil nil nil nil nil)) | ||
| 387 | |||
| 388 | (defun tar--pad-to (pos) | ||
| 389 | (make-string (+ pos (- (point)) (point-min)) 0)) | ||
| 390 | |||
| 391 | (defun tar--put-at (pos val &optional fmt mask) | ||
| 392 | (when val | ||
| 393 | (insert (tar--pad-to pos) | ||
| 394 | (if fmt | ||
| 395 | (format fmt (if mask (logand mask val) val)) | ||
| 396 | val)))) | ||
| 397 | |||
| 398 | (defun tar-header-serialize (header &optional update-checksum) | ||
| 399 | "Return the serialization of a Tar HEADER as a string. | ||
| 400 | This function calls `tar-header-block-check-checksum' to ensure the | ||
| 401 | checksum is correct. | ||
| 402 | |||
| 403 | If UPDATE-CHECKSUM is non-nil, update HEADER with the newly-computed | ||
| 404 | checksum before doing the check." | ||
| 405 | (with-temp-buffer | ||
| 406 | (set-buffer-multibyte nil) | ||
| 407 | (let ((encoded-name | ||
| 408 | (encode-coding-string (tar-header-name header) | ||
| 409 | tar-file-name-coding-system))) | ||
| 410 | (unless (< (length encoded-name) 99) | ||
| 411 | ;; FIXME: Implement it. | ||
| 412 | (error "Long file name support is not implemented")) | ||
| 413 | (insert encoded-name)) | ||
| 414 | (tar--put-at tar-mode-offset (tar-header-mode header) "%6o\0 " #o777777) | ||
| 415 | (tar--put-at tar-uid-offset (tar-header-uid header) "%6o\0 " #o777777) | ||
| 416 | (tar--put-at tar-gid-offset (tar-header-gid header) "%6o\0 " #o777777) | ||
| 417 | (tar--put-at tar-size-offset (tar-header-size header) "%11o ") | ||
| 418 | (insert (tar--pad-to tar-time-offset) | ||
| 419 | (tar-octal-time (tar-header-date header)) | ||
| 420 | " ") | ||
| 421 | ;; Omit tar-header-checksum (tar-chk-offset) for now. | ||
| 422 | (tar--put-at tar-linkp-offset (tar-header-link-type header)) | ||
| 423 | (tar--put-at tar-link-offset (tar-header-link-name header)) | ||
| 424 | (when (tar-header-magic header) | ||
| 425 | (tar--put-at tar-magic-offset (tar-header-magic header)) | ||
| 426 | (tar--put-at tar-uname-offset (tar-header-uname header)) | ||
| 427 | (tar--put-at tar-gname-offset (tar-header-gname header)) | ||
| 428 | (tar--put-at tar-dmaj-offset (tar-header-dmaj header) "%7o\0" #o7777777) | ||
| 429 | (tar--put-at tar-dmin-offset (tar-header-dmin header) "%7o\0" #o7777777)) | ||
| 430 | (tar--put-at 512 "") | ||
| 431 | (let ((ck (tar-header-block-checksum (buffer-string)))) | ||
| 432 | (goto-char (+ (point-min) tar-chk-offset)) | ||
| 433 | (delete-char 8) | ||
| 434 | (insert (format "%6o\0 " ck)) | ||
| 435 | (when update-checksum | ||
| 436 | (setf (tar-header-checksum header) ck)) | ||
| 437 | (tar-header-block-check-checksum (buffer-string) | ||
| 438 | (tar-header-checksum header) | ||
| 439 | (tar-header-name header))) | ||
| 440 | ;; . | ||
| 441 | (buffer-string))) | ||
| 442 | |||
| 372 | 443 | ||
| 373 | (defun tar-header-block-checksum (string) | 444 | (defun tar-header-block-checksum (string) |
| 374 | "Compute and return a tar-acceptable checksum for this block." | 445 | "Compute and return a tar-acceptable checksum for this block." |
| @@ -547,6 +618,7 @@ MODE should be an integer which is a file mode value." | |||
| 547 | (define-key map "p" 'tar-previous-line) | 618 | (define-key map "p" 'tar-previous-line) |
| 548 | (define-key map "\^P" 'tar-previous-line) | 619 | (define-key map "\^P" 'tar-previous-line) |
| 549 | (define-key map [up] 'tar-previous-line) | 620 | (define-key map [up] 'tar-previous-line) |
| 621 | (define-key map "I" 'tar-new-entry) | ||
| 550 | (define-key map "R" 'tar-rename-entry) | 622 | (define-key map "R" 'tar-rename-entry) |
| 551 | (define-key map "u" 'tar-unflag) | 623 | (define-key map "u" 'tar-unflag) |
| 552 | (define-key map "v" 'tar-view) | 624 | (define-key map "v" 'tar-view) |
| @@ -731,10 +803,14 @@ tar-file's buffer." | |||
| 731 | (interactive "p") | 803 | (interactive "p") |
| 732 | (tar-next-line (- arg))) | 804 | (tar-next-line (- arg))) |
| 733 | 805 | ||
| 806 | (defun tar-current-position () | ||
| 807 | "Return the `tar-parse-info' index for the current line." | ||
| 808 | (count-lines (point-min) (line-beginning-position))) | ||
| 809 | |||
| 734 | (defun tar-current-descriptor (&optional noerror) | 810 | (defun tar-current-descriptor (&optional noerror) |
| 735 | "Return the tar-descriptor of the current line, or signals an error." | 811 | "Return the tar-descriptor of the current line, or signals an error." |
| 736 | ;; I wish lines had plists, like in ZMACS... | 812 | ;; I wish lines had plists, like in ZMACS... |
| 737 | (or (nth (count-lines (point-min) (line-beginning-position)) | 813 | (or (nth (tar-current-position) |
| 738 | tar-parse-info) | 814 | tar-parse-info) |
| 739 | (if noerror | 815 | (if noerror |
| 740 | nil | 816 | nil |
| @@ -948,6 +1024,37 @@ the current tar-entry." | |||
| 948 | (write-region start end to-file nil nil nil t))) | 1024 | (write-region start end to-file nil nil nil t))) |
| 949 | (message "Copied tar entry %s to %s" name to-file))) | 1025 | (message "Copied tar entry %s to %s" name to-file))) |
| 950 | 1026 | ||
| 1027 | (defun tar-new-entry (filename &optional index) | ||
| 1028 | "Insert a new empty regular file before point." | ||
| 1029 | (interactive "*sFile name: ") | ||
| 1030 | (let* ((buffer (current-buffer)) | ||
| 1031 | (index (or index (tar-current-position))) | ||
| 1032 | (d-list (and (not (zerop index)) | ||
| 1033 | (nthcdr (+ -1 index) tar-parse-info))) | ||
| 1034 | (pos (if d-list | ||
| 1035 | (tar-header-data-end (car d-list)) | ||
| 1036 | (point-min))) | ||
| 1037 | (new-descriptor | ||
| 1038 | (tar-new-regular-file-header filename))) | ||
| 1039 | ;; Update the data buffer; fill the missing descriptor fields. | ||
| 1040 | (with-current-buffer tar-data-buffer | ||
| 1041 | (goto-char pos) | ||
| 1042 | (insert (tar-header-serialize new-descriptor t)) | ||
| 1043 | (setf (tar-header-data-start new-descriptor) | ||
| 1044 | (copy-marker (point) nil))) | ||
| 1045 | ;; Update tar-parse-info. | ||
| 1046 | (if d-list | ||
| 1047 | (setcdr d-list (cons new-descriptor (cdr d-list))) | ||
| 1048 | (setq tar-parse-info (cons new-descriptor tar-parse-info))) | ||
| 1049 | ;; Update the listing buffer. | ||
| 1050 | (save-excursion | ||
| 1051 | (goto-char (point-min)) | ||
| 1052 | (forward-line index) | ||
| 1053 | (let ((inhibit-read-only t)) | ||
| 1054 | (insert (tar-header-block-summarize new-descriptor) ?\n))) | ||
| 1055 | ;; . | ||
| 1056 | index)) | ||
| 1057 | |||
| 951 | (defun tar-flag-deleted (p &optional unflag) | 1058 | (defun tar-flag-deleted (p &optional unflag) |
| 952 | "In Tar mode, mark this sub-file to be deleted from the tar file. | 1059 | "In Tar mode, mark this sub-file to be deleted from the tar file. |
| 953 | With a prefix argument, mark that many files." | 1060 | With a prefix argument, mark that many files." |