X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=23c418e7a7cdde03e791d228ffa77e1d3f5423b4;hb=d9e28e3e79936d460820dfa09c278750eddc1649;hp=4242d0e7c17f58b958eef45e387ddfdb592417ab;hpb=f344bd14c4b7e73add97d561de63bb7d85ab6571;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 4242d0e7c..23c418e7a 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -36,7 +36,6 @@ (require 'cl) ;; Fixme: this should be a gnus variable, not nnmail-. (defvar nnmail-pathname-coding-system)) -(require 'nnheader) (require 'time-date) (require 'netrc) @@ -45,7 +44,9 @@ (autoload 'gnus-get-buffer-window "gnus-win") (autoload 'rmail-insert-rmail-file-header "rmail") (autoload 'rmail-count-new-messages "rmail") - (autoload 'rmail-show-message "rmail")) + (autoload 'rmail-show-message "rmail") + (autoload 'nnheader-narrow-to-headers "nnheader") + (autoload 'nnheader-replace-chars-in-string "nnheader")) (eval-and-compile (cond @@ -104,17 +105,12 @@ ;; Added by Geoffrey T. Dairiki . A safe way ;; to limit the length of a string. This function is necessary since ;; `(substr "abc" 0 30)' pukes with "Args out of range". +;; Fixme: Why not `truncate-string-to-width'? (defsubst gnus-limit-string (str width) (if (> (length str) width) (substring str 0 width) str)) -(defsubst gnus-functionp (form) - "Return non-nil if FORM is funcallable." - (or (and (symbolp form) (fboundp form)) - (and (listp form) (eq (car form) 'lambda)) - (byte-code-function-p form))) - (defsubst gnus-goto-char (point) (and point (goto-char point))) @@ -134,6 +130,16 @@ 'point-at-eol 'line-end-position)) +;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and +;; XEmacs. In Emacs we don't need to call `make-local-hook' first. +;; It's harmless, though, so the main purpose of this alias is to shut +;; up the byte compiler. +(defalias 'gnus-make-local-hook + (if (eq (get 'make-local-hook 'byte-compile) + 'byte-compile-obsolete) + 'ignore ; Emacs + 'make-local-hook)) ; XEmacs + (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." (if (equal (car list) elt) @@ -228,7 +234,6 @@ (delete-char 1)) (goto-char (next-single-property-change (point) prop nil (point-max)))))) -(require 'nnheader) (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) @@ -455,12 +460,13 @@ jabbering all the time." :group 'gnus-start :type 'integer) -;; Show message if message has a lower level than `gnus-verbose'. -;; Guideline for numbers: -;; 1 - error messages, 3 - non-serious error messages, 5 - messages -;; for things that take a long time, 7 - not very important messages -;; on stuff, 9 - messages inside loops. (defun gnus-message (level &rest args) + "If LEVEL is lower than `gnus-verbose' print ARGS using `message'. + +Guideline for numbers: +1 - error messages, 3 - non-serious error messages, 5 - messages for things +that take a long time, 7 - not very important messages on stuff, 9 - messages +inside loops." (if (<= level gnus-verbose) (apply 'message args) ;; We have to do this format thingy here even if the result isn't @@ -577,7 +583,7 @@ If N, return the Nth ancestor instead." "Return a composite sort condition based on the functions in FUNC." (cond ;; Just a simple function. - ((gnus-functionp funs) funs) + ((functionp funs) funs) ;; No functions at all. ((null funs) funs) ;; A list of functions. @@ -602,7 +608,7 @@ If N, return the Nth ancestor instead." (setq function (cadr function) first 't2 last 't1)) - ((gnus-functionp function) + ((functionp function) ;; Do nothing. ) (t @@ -1025,28 +1031,29 @@ Return the modified alist." (while (search-backward "\\." nil t) (delete-char 1))))) +;; Fixme: Why not use `with-output-to-temp-buffer'? (defmacro gnus-with-output-to-file (file &rest body) (let ((buffer (make-symbol "output-buffer")) (size (make-symbol "output-buffer-size")) - (leng (make-symbol "output-buffer-length"))) - `(let* ((print-quoted t) - (print-readably t) - (print-escape-multibyte nil) - print-level - print-length - (,size 131072) + (leng (make-symbol "output-buffer-length")) + (append (make-symbol "output-buffer-append"))) + `(let* ((,size 131072) (,buffer (make-string ,size 0)) (,leng 0) - (append nil) - (standard-output (lambda (c) - (aset ,buffer ,leng c) - (if (= ,size (setq ,leng (1+ ,leng))) - (progn (write-region ,buffer nil ,file append 'no-msg) - (setq ,leng 0 - append t)))))) + (,append nil) + (standard-output + (lambda (c) + (aset ,buffer ,leng c) + + (if (= ,size (setq ,leng (1+ ,leng))) + (progn (write-region ,buffer nil ,file ,append 'no-msg) + (setq ,leng 0 + ,append t)))))) ,@body - (if (> ,leng 0) - (write-region (substring ,buffer 0 ,leng) nil ,file append 'no-msg))))) + (when (> ,leng 0) + (let ((coding-system-for-write 'no-conversion)) + (write-region (substring ,buffer 0 ,leng) nil ,file + ,append 'no-msg)))))) (put 'gnus-with-output-to-file 'lisp-indent-function 1) (put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) @@ -1092,6 +1099,9 @@ Return the modified alist." (remove-text-properties start end properties object)) t)) +;; This might use `compare-strings' to reduce consing in the +;; case-insensitive case, but it has to cope with null args. +;; (`string-equal' uses symbol print names.) (defun gnus-string-equal (x y) "Like `string-equal', except it compares case-insensitively." (and (= (length x) (length y)) @@ -1099,9 +1109,9 @@ Return the modified alist." (string-equal (downcase x) (downcase y))))) (defcustom gnus-use-byte-compile t - "If non-nil, byte-compile crucial run-time codes. -Setting it to nil has no effect after first time running -`gnus-byte-compile'." + "If non-nil, byte-compile crucial run-time code. +Setting it to nil has no effect after the first time `gnus-byte-compile' +is run." :type 'boolean :version "21.1" :group 'gnus-various) @@ -1115,8 +1125,11 @@ Setting it to nil has no effect after first time running (require 'byte-optimize) (error)) (require 'bytecomp) - (defalias 'gnus-byte-compile 'byte-compile) - (byte-compile form)) + (defalias 'gnus-byte-compile + (lambda (form) + (let ((byte-compile-warnings '(unresolved callargs redefine))) + (byte-compile form)))) + (gnus-byte-compile form)) form)) (defun gnus-remassoc (key alist) @@ -1160,12 +1173,13 @@ If you find some problem with the directory separator character, try (+ 10 (- x ?A))) (- x ?0))) +;; Fixme: Do it like QP. (defun gnus-url-unhex-string (str &optional allow-newlines) - "Remove %XXX embedded spaces, etc in a url. + "Remove %XX, embedded spaces, etc in a url. If optional second argument ALLOW-NEWLINES is non-nil, then allow the decoding of carriage returns and line feeds in the string, which is normally forbidden in URL encoding." - (setq str (or (mm-subst-char-in-string ?+ ? str) "")) + (setq str (or (mm-subst-char-in-string ?+ ? str) "")) ; why `or'? (let ((tmp "") (case-fold-search t)) (while (string-match "%[0-9a-f][0-9a-f]" str) @@ -1210,12 +1224,22 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (t (list 'local-map map)))) +(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate + require-match initial-contents + history default) + "Like `completing-read', allowing for non-existent 7th arg in older XEmacsen." + `(completing-read ,prompt ,table ,predicate ,require-match + ,initial-contents ,history + ,@(if (and (featurep 'xemacs) (< emacs-minor-version 2)) + () + (list default)))) + (defun gnus-completing-read (prompt table &optional predicate require-match history) (when (and history (not (boundp history))) (set history nil)) - (completing-read + (gnus-completing-read-maybe-default (if (symbol-value history) (concat prompt " (" (car (symbol-value history)) "): ") (concat prompt ": ")) @@ -1350,6 +1374,56 @@ Return nil otherwise." display)) display))))) +;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile. +(defmacro gnus-mapcar (function seq1 &rest seqs2_n) + "Apply FUNCTION to each element of the sequences, and make a list of the results. +If there are several sequences, FUNCTION is called with that many arguments, +and mapping stops as soon as the shortest sequence runs out. With just one +sequence, this is like `mapcar'. With several, it is like the Common Lisp +`mapcar' function extended to arbitrary sequence types." + + (if seqs2_n + (let* ((seqs (cons seq1 seqs2_n)) + (cnt 0) + (heads (mapcar (lambda (seq) + (make-symbol (concat "head" + (int-to-string + (setq cnt (1+ cnt)))))) + seqs)) + (result (make-symbol "result")) + (result-tail (make-symbol "result-tail"))) + `(let* ,(let* ((bindings (cons nil nil)) + (heads heads)) + (nconc bindings (list (list result '(cons nil nil)))) + (nconc bindings (list (list result-tail result))) + (while heads + (nconc bindings (list (list (pop heads) (pop seqs))))) + (cdr bindings)) + (while (and ,@heads) + (setcdr ,result-tail (cons (funcall ,function + ,@(mapcar (lambda (h) (list 'car h)) + heads)) + nil)) + (setq ,result-tail (cdr ,result-tail) + ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) + (cdr ,result))) + `(mapcar ,function ,seq1))) + +(if (fboundp 'merge) + (defalias 'gnus-merge 'merge) + ;; Adapted from cl-seq.el + (defun gnus-merge (type list1 list2 pred) + "Destructively merge lists LIST1 and LIST2 to produce a new list. +Argument TYPE is for compatibility and ignored. +Ordering of the elements is preserved according to PRED, a `less-than' +predicate on the elements." + (let ((res nil)) + (while (and list1 list2) + (if (funcall pred (car list2) (car list1)) + (push (pop list2) res) + (push (pop list1) res))) + (nconc (nreverse res) list1 list2)))) + (provide 'gnus-util) ;;; gnus-util.el ends here