aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorLars Magne Ingebrigtsen2015-01-28 14:21:33 +1100
committerLars Magne Ingebrigtsen2015-01-28 14:21:33 +1100
commit7f4f16b3ae6fdb59d83cfc01017668f2a564309f (patch)
tree60e4a7f23f949afaed3bc2fddd0a528aef297861 /lisp
parent1a369fc7f1ccec6954344ec1ee0211a4d24c312d (diff)
parentbe2d23e58721b7acc68c0ea654a38e5109df2aa2 (diff)
downloademacs-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/ChangeLog84
-rw-r--r--lisp/emacs-lisp/cl-generic.el323
-rw-r--r--lisp/emacs-lisp/cl.el13
-rw-r--r--lisp/emacs-lisp/derived.el3
-rw-r--r--lisp/emacs-lisp/eieio-compat.el13
-rw-r--r--lisp/emacs-lisp/eieio-core.el2
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el16
-rw-r--r--lisp/emacs-lisp/eieio-opt.el18
-rw-r--r--lisp/emacs-lisp/eieio.el2
-rw-r--r--lisp/gnus/ChangeLog20
-rw-r--r--lisp/gnus/gnus-bcklg.el4
-rw-r--r--lisp/gnus/nnimap.el20
-rw-r--r--lisp/gnus/nnir.el123
-rw-r--r--lisp/gnus/nnmairix.el2
-rw-r--r--lisp/isearch.el2
-rw-r--r--lisp/net/eudc-bob.el3
-rw-r--r--lisp/net/eudc-export.el3
-rw-r--r--lisp/net/eudc-hotlist.el3
-rw-r--r--lisp/net/eudc-vars.el3
-rw-r--r--lisp/net/eudc.el3
-rw-r--r--lisp/net/eudcb-bbdb.el3
-rw-r--r--lisp/net/eudcb-ldap.el3
-rw-r--r--lisp/net/eudcb-mab.el2
-rw-r--r--lisp/net/eudcb-ph.el3
-rw-r--r--lisp/progmodes/python.el6
-rw-r--r--lisp/tar-mode.el115
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 @@
12015-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
62015-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
162015-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
222015-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
282015-01-27 Artur Malabarba <bruce.connor.am@gmail.com>
29
30 * isearch.el (isearch-process-search-char): Add docstring.
31
322015-01-27 Oleh Krehel <ohwoeowho@gmail.com>
33
34 * emacs-lisp/derived.el (define-derived-mode): Declare indent 3.
35
362015-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
422015-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
632015-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
12015-01-26 Lars Ingebrigtsen <larsi@gnus.org> 852015-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.
102They should be sorted from most specific to least specific.") 102They 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 453Called with 2 arguments: NAME and METHOD-ALIST.
445 (let ((next fun)) 454It should return an effective method, i.e. a function that expects the same
446 (lambda (&rest args) 455arguments as the methods, and calls those methods in some appropriate order.
447 (apply method 456NAME is the name (a symbol) of the corresponding generic function.
448 ;; FIXME: This sucks: passing just `next' would 457METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where
449 ;; be a lot more efficient than the lambda+apply 458QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected
450 ;; quasi-η, but we need this to implement the 459methods for that qualifier list.
451 ;; "if call-next-method is called with no 460The METHODS lists are sorted from most generic first to most specific last.
452 ;; arguments, then use the previous arguments". 461The function can use `cl-generic-call-method' to create functions that call those
453 (lambda (&rest cnm-args) 462methods.")
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
462of methods, since this table then allows us to share a single combined-method 468of methods, since this table then allows us to share a single combined-method
463for all those different tags in the method-cache.") 469for 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)) 493FUN 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
162See Info node `(elisp)Derived Modes' for more details." 162See 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.
338The value returned is a list of elements of the form 337The 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 @@
12015-01-27 Lars Ingebrigtsen <larsi@gnus.org>
2
3 * nnir.el (nnir-imap-expr-to-imap): Check for literal+ capability in
4 IMAP.
5
62015-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
152015-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
12015-01-26 Peder O. Klingenberg <peder@klingenberg.no> 212015-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.
2353Search 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.
371The header will lack a proper checksum; use `tar-header-block-checksum'
372to compute one, or request `tar-header-serialize' to do that.
373
374Other tar-mode facilities may also require the data-start header
375field to be set to a valid value.
376
377If SIZE is not given or nil, it defaults to 0.
378If 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.
400This function calls `tar-header-block-check-checksum' to ensure the
401checksum is correct.
402
403If UPDATE-CHECKSUM is non-nil, update HEADER with the newly-computed
404checksum 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.
953With a prefix argument, mark that many files." 1060With a prefix argument, mark that many files."