X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=fef67cd52e9b5e255b41e3faca99e04c05767dc6;hp=d71035754a738a0b5d0a2813c1cb82d151525b96;hb=5d97eabba7d837af355df0e772bd9e2f585b7a22;hpb=042a739c7b18b8c5ef666912b6c775fb082f3e4b diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index d71035754..fef67cd52 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,7 +1,6 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -39,6 +38,8 @@ (eval-when-compile (require 'cl)) +(require 'time-date) + (defcustom gnus-completing-read-function 'gnus-emacs-completing-read "Function use to do completing read." :version "24.1" @@ -332,10 +333,11 @@ Symbols are also allowed; their print names are used instead." (and (= (car fdate) (car date)) (> (nth 1 fdate) (nth 1 date)))))) +;; Every version of Emacs Gnus supports has built-in float-time. +;; The featurep test silences an irritating compiler warning. (eval-and-compile (if (or (featurep 'emacs) - (and (fboundp 'float-time) - (subrp (symbol-function 'float-time)))) + (fboundp 'float-time)) (defalias 'gnus-float-time 'float-time) (defun gnus-float-time (&optional time) "Convert time value TIME to a floating point number. @@ -386,57 +388,14 @@ TIME defaults to the current time." (define-key keymap key (pop plist)) (pop plist))))) -;; Two silly functions to ensure that all `y-or-n-p' questions clear -;; the echo area. -;; -;; Do we really need these functions? Workarounds for bugs in the corresponding -;; Emacs functions? Maybe these bugs are no longer present in any supported -;; (X)Emacs version? Alias them to the original functions and see if anyone -;; reports a problem. If not, replace with original functions. --rsteib, -;; 2007-12-14 -;; -;; All supported Emacsen clear the echo area after `yes-or-no-p', so we can -;; remove `yes-or-no-p'. RMS says that not clearing after `y-or-n-p' is -;; intentional (see below), so we could remove `gnus-y-or-n-p' too. -;; Objections? --rsteib, 2008-02-16 -;; -;; ,----[ http://thread.gmane.org/gmane.emacs.gnus.general/65099/focus=66070 ] -;; | From: Richard Stallman -;; | Subject: Re: Do we need gnus-yes-or-no-p and gnus-y-or-n-p? -;; | To: Katsumi Yamaoka [...] -;; | Cc: emacs-devel@[...], xemacs-beta@[...], ding@[...] -;; | Date: Mon, 07 Jan 2008 12:16:05 -0500 -;; | Message-ID: -;; | -;; | The behavior of `y-or-n-p' that it doesn't clear the question -;; | and the answer is not serious of course, but I feel it is not -;; | cool. -;; | -;; | It is intentional. -;; | -;; | Currently, it is commented out in the trunk by Reiner Steib. He -;; | also wrote the benefit of leaving the question and the answer in -;; | the echo area as follows: -;; | -;; | (http://article.gmane.org/gmane.emacs.gnus.general/66061) -;; | > In contrast to yes-or-no-p it is much easier to type y, n, -;; | > SPC, DEL, etc accidentally, so it might be useful for the user -;; | > to see what he has typed. -;; | -;; | Yes, that is the reason. -;; `---- - -;; (defun gnus-y-or-n-p (prompt) -;; (prog1 -;; (y-or-n-p prompt) -;; (message ""))) -;; (defun gnus-yes-or-no-p (prompt) -;; (prog1 -;; (yes-or-no-p prompt) -;; (message ""))) - -(defalias 'gnus-y-or-n-p 'y-or-n-p) -(defalias 'gnus-yes-or-no-p 'yes-or-no-p) +(defun gnus-y-or-n-p (prompt) + (prog1 + (y-or-n-p prompt) + (message ""))) +(defun gnus-yes-or-no-p (prompt) + (prog1 + (yes-or-no-p prompt) + (message ""))) ;; By Frank Schmitt . Allows to have ;; age-depending date representations. (e.g. just the time if it's @@ -475,51 +434,6 @@ Cache the result as a text property stored in DATE." (put-text-property 0 1 'gnus-time time d) time))))) -(defvar gnus-user-date-format-alist - '(((gnus-seconds-today) . "%k:%M") - (604800 . "%a %k:%M") ;;that's one week - ((gnus-seconds-month) . "%a %d") - ((gnus-seconds-year) . "%b %d") - (t . "%b %d '%y")) ;;this one is used when no - ;;other does match - "Specifies date format depending on age of article. -This is an alist of items (AGE . FORMAT). AGE can be a number (of -seconds) or a Lisp expression evaluating to a number. When the age of -the article is less than this number, then use `format-time-string' -with the corresponding FORMAT for displaying the date of the article. -If AGE is not a number or a Lisp expression evaluating to a -non-number, then the corresponding FORMAT is used as a default value. - -Note that the list is processed from the beginning, so it should be -sorted by ascending AGE. Also note that items following the first -non-number AGE will be ignored. - -You can use the functions `gnus-seconds-today', `gnus-seconds-month' -and `gnus-seconds-year' in the AGE spec. They return the number of -seconds passed since the start of today, of this month, of this year, -respectively.") - -(defun gnus-user-date (messy-date) - "Format the messy-date according to gnus-user-date-format-alist. -Returns \" ? \" if there's bad input or if another error occurs. -Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." - (condition-case () - (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date))) - (now (gnus-float-time)) - ;;If we don't find something suitable we'll use this one - (my-format "%b %d '%y")) - (let* ((difference (- now messy-date)) - (templist gnus-user-date-format-alist) - (top (eval (caar templist)))) - (while (if (numberp top) (< top difference) (not top)) - (progn - (setq templist (cdr templist)) - (setq top (eval (caar templist))))) - (if (stringp (cdr (car templist))) - (setq my-format (cdr (car templist))))) - (format-time-string (eval my-format) (seconds-to-time messy-date))) - (error " ? "))) - (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." (condition-case () @@ -557,12 +471,13 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (setq i (* 2 i))) i)) -(defcustom gnus-verbose 7 +(defcustom gnus-verbose 6 "*Integer that says how verbose Gnus should be. The higher the number, the more messages Gnus will flash to say what it's doing. At zero, Gnus will be totally mute; at five, Gnus will display most important messages; and at ten, Gnus will keep on jabbering all the time." + :version "24.1" :group 'gnus-start :type 'integer) @@ -583,8 +498,7 @@ but also to the ones displayed in the echo area." (eval-when-compile (defmacro gnus-message-with-timestamp-1 (format-string args) - (let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time) - "." (format "%03d" (/ (nth 2 time) 1000)) "> "))) + (let ((timestamp '(format-time-string "%Y%m%dT%H%M%S.%3N> " time))) (if (featurep 'xemacs) `(let (str time) (if (or (and (null ,format-string) (null ,args)) @@ -597,10 +511,10 @@ but also to the ones displayed in the echo area." (cond ((eq gnus-add-timestamp-to-message 'log) (setq time (current-time)) (display-message 'no-log str) - (log-message 'message (concat ,@timestamp str))) + (log-message 'message (concat ,timestamp str))) (gnus-add-timestamp-to-message (setq time (current-time)) - (display-message 'message (concat ,@timestamp str))) + (display-message 'message (concat ,timestamp str))) (t (display-message 'message str)))) str) @@ -614,7 +528,7 @@ but also to the ones displayed in the echo area." (setq time (current-time)) (with-current-buffer (get-buffer-create "*Messages*") (goto-char (point-max)) - (insert ,@timestamp str "\n") + (insert ,timestamp str "\n") (forward-line (- message-log-max)) (delete-region (point-min) (point)) (goto-char (point-max)))) @@ -628,7 +542,7 @@ but also to the ones displayed in the echo area." (and ,format-string str) (message nil)) (setq time (current-time)) - (message "%s" (concat ,@timestamp str)) + (message "%s" (concat ,timestamp str)) str)) (t (apply 'message ,format-string ,args)))))))) @@ -715,11 +629,9 @@ If N, return the Nth ancestor instead." (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) (match-string 1 references)))))) -(defun gnus-buffer-live-p (buffer) +(defsubst gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." - (and buffer - (get-buffer buffer) - (buffer-name (get-buffer buffer)))) + (and buffer (buffer-live-p (get-buffer buffer)))) (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." @@ -902,6 +814,7 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." + (require 'nnmail) (let ((file-name-coding-system nnmail-pathname-coding-system)) ;; Make sure the directory exists. (gnus-make-directory (file-name-directory file)) @@ -913,6 +826,15 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (when (file-exists-p file) (delete-file file))) +(defun gnus-delete-duplicates (list) + "Remove duplicate entries from LIST." + (let ((result nil)) + (while list + (unless (member (car list) result) + (push (car list) result)) + (pop list)) + (nreverse result))) + (defun gnus-delete-directory (directory) "Delete files in DIRECTORY. Subdirectories remain. If there's no subdirectory, delete DIRECTORY as well." @@ -1137,6 +1059,7 @@ In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless FILENAME exists and is Babyl format." (require 'rmail) (require 'mm-util) + (require 'nnmail) ;; Some of this codes is borrowed from rmailout.el. (setq filename (expand-file-name filename)) ;; FIXME should we really be messing with this defcustom? @@ -1228,6 +1151,7 @@ FILENAME exists and is Babyl format." (defun gnus-output-to-mail (filename &optional ask) "Append the current article to a mail file named FILENAME." + (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) (tmpbuf (get-buffer-create " *Gnus-output*"))) @@ -1326,6 +1250,13 @@ This function saves the current buffer." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) +(defun gnus-process-live-p (process) + "Returns non-nil if PROCESS is alive. +A process is considered alive if its status is `run', `open', +`listen', `connect' or `stop'." + (memq (process-status process) + '(run open listen connect stop))) + (defun gnus-remove-if (predicate sequence &optional hash-table-p) "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. SEQUENCE should be a list, a vector, or a string. Returns always a list. @@ -1996,6 +1927,19 @@ Sizes are in pixels." image))) image))) +(defun gnus-recursive-directory-files (dir) + "Return all regular files below DIR." + (let (files) + (dolist (file (directory-files dir t)) + (when (and (not (member (file-name-nondirectory file) '("." ".."))) + (file-readable-p file)) + (cond + ((file-regular-p file) + (push file files)) + ((file-directory-p file) + (setq files (append (gnus-recursive-directory-files file) files)))))) + files)) + (defun gnus-list-memq-of-list (elements list) "Return non-nil if any of the members of ELEMENTS are in LIST." (let ((found nil)) @@ -2034,23 +1978,31 @@ Same as `string-match' except this function does not change the match data." (save-match-data (string-match regexp string start)))) -(if (fboundp 'macroexpand-all) - (defalias 'gnus-macroexpand-all 'macroexpand-all) - (defun gnus-macroexpand-all (form) - "Return result of expanding macros at all levels in FORM. -If no macros are expanded, FORM is returned unchanged." - (if (consp form) - (let ((idx 1) - (len (length form)) - elem expanded) - (while (< idx len) - (when (consp (setq elem (nth idx form))) - (setcar (nthcdr idx form) (gnus-macroexpand-all elem))) - (setq idx (1+ idx))) - (if (eq (setq expanded (macroexpand form)) form) - form - (gnus-macroexpand-all expanded))) - form))) +(eval-and-compile + (if (fboundp 'macroexpand-all) + (defalias 'gnus-macroexpand-all 'macroexpand-all) + (defun gnus-macroexpand-all (form &optional environment) + "Return result of expanding macros at all levels in FORM. +If no macros are expanded, FORM is returned unchanged. +The second optional arg ENVIRONMENT specifies an environment of macro +definitions to shadow the loaded ones for use in file byte-compilation." + (if (consp form) + (let ((idx 1) + (len (length (setq form (copy-sequence form)))) + expanded) + (while (< idx len) + (setcar (nthcdr idx form) (gnus-macroexpand-all (nth idx form) + environment)) + (setq idx (1+ idx))) + (if (eq (setq expanded (macroexpand form environment)) form) + form + (gnus-macroexpand-all expanded environment))) + form)))) + +;; Simple check: can be a macro but this way, although slow, it's really clear. +;; We don't use `bound-and-true-p' because it's not in XEmacs. +(defun gnus-bound-and-true-p (sym) + (and (boundp sym) (symbol-value sym))) (provide 'gnus-util)