;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2016 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;;; Code:
-;; For Emacs <22.2 and XEmacs.
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
;; Every version of Emacs Gnus supports has built-in float-time.
;; The featurep test silences an irritating compiler warning.
-(eval-and-compile
+(defalias 'gnus-float-time
(if (or (featurep 'emacs)
(fboundp 'float-time))
- (defalias 'gnus-float-time 'float-time)
- (defun gnus-float-time (&optional time)
- "Convert time value TIME to a floating point number.
-TIME defaults to the current time."
- (time-to-seconds (or time (current-time))))))
+ 'float-time 'time-to-seconds))
;;; Keymap macros.
(defun gnus-seconds-today ()
"Return the number of seconds passed today."
- (let ((now (decode-time (current-time))))
+ (let ((now (decode-time)))
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600))))
(defun gnus-seconds-month ()
"Return the number of seconds passed this month."
- (let ((now (decode-time (current-time))))
+ (let ((now (decode-time)))
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (car (nthcdr 3 now)) 1) 3600 24))))
(defun gnus-seconds-year ()
"Return the number of seconds passed this year."
- (let ((now (decode-time (current-time)))
- (days (format-time-string "%j" (current-time))))
+ (let* ((current (current-time))
+ (now (decode-time current))
+ (days (format-time-string "%j" current)))
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (string-to-number days) 1) 3600 24))))
(setq beg (point)))
(gnus-put-text-property beg (point) prop val)))))
-(declare-function gnus-overlay-put "gnus" (overlay prop value))
-(declare-function gnus-make-overlay "gnus"
- (beg end &optional buffer front-advance rear-advance))
-
(defsubst gnus-put-overlay-excluding-newlines (beg end prop val)
"The same as `put-text-property', but don't put this prop on any newlines in the region."
(save-match-data
(save-restriction
(goto-char beg)
(while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
- (gnus-overlay-put
- (gnus-make-overlay beg (match-beginning 0))
- prop val)
+ (overlay-put (make-overlay beg (match-beginning 0)) prop val)
(setq beg (point)))
- (gnus-overlay-put (gnus-make-overlay beg (point)) prop val)))))
+ (overlay-put (make-overlay beg (point)) prop val)))))
(defun gnus-put-text-property-excluding-characters-with-faces (beg end prop val)
"The same as `put-text-property', except where `gnus-face' is set.
'previous-extent-change 'previous-char-property-change))
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
-;; The primary idea here is to try to protect internal datastructures
+;; The primary idea here is to try to protect internal data structures
;; from becoming corrupted when the user hits C-g, or if a hook or
;; similar blows up. Often in Gnus multiple tables/lists need to be
;; updated at the same time, or information can be lost.
(if (fboundp 'union)
(defalias 'gnus-union 'union)
- (defun gnus-union (l1 l2)
- "Set union of lists L1 and L2."
+ (defun gnus-union (l1 l2 &rest keys)
+ "Set union of lists L1 and L2.
+If KEYS contains the `:test' and `equal' pair, use `equal' to compare
+items in lists, otherwise use `eq'."
(cond ((null l1) l2)
((null l2) l1)
((equal l1 l2) l1)
(t
(or (>= (length l1) (length l2))
(setq l1 (prog1 l2 (setq l2 l1))))
- (while l2
- (or (member (car l2) l1)
- (push (car l2) l1))
- (pop l2))
+ (if (eq 'equal (plist-get keys :test))
+ (while l2
+ (or (member (car l2) l1)
+ (push (car l2) l1))
+ (pop l2))
+ (while l2
+ (or (memq (car l2) l1)
+ (push (car l2) l1))
+ (pop l2)))
l1))))
(declare-function gnus-add-text-properties "gnus"
(defvar gnus-directory-sep-char-regexp "/"
"The regexp of directory separator character.
If you find some problem with the directory separator character, try
-\"[/\\\\\]\" for some systems.")
+\"[/\\\\]\" for some systems.")
(defun gnus-url-unhex (x)
(if (> x ?9)
(declare-function iswitchb-read-buffer "iswitchb"
- (prompt &optional default require-match start matches-set))
+ (prompt &optional default require-match
+ _predicate start matches-set))
(defvar iswitchb-temp-buflist)
+(defvar iswitchb-mode)
(defun gnus-iswitchb-completing-read (prompt collection &optional require-match
initial-input history def)
image)))
image)))
+(eval-when-compile (require 'gmm-utils))
(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))))))
+ "Return all regular files below DIR.
+The first found will be returned if a file has hard or symbolic links."
+ (let (files attr attrs)
+ (gmm-labels
+ ((fn (directory)
+ (dolist (file (directory-files directory t))
+ (setq attr (file-attributes (file-truename file)))
+ (when (and (not (member attr attrs))
+ (not (member (file-name-nondirectory file)
+ '("." "..")))
+ (file-readable-p file))
+ (push attr attrs)
+ (cond ((file-regular-p file)
+ (push file files))
+ ((file-directory-p file)
+ (fn file)))))))
+ (fn dir))
files))
(defun gnus-list-memq-of-list (elements list)
(string-equal (downcase str1) (downcase prefix))
(string-equal str1 prefix))))))
+(defalias 'gnus-format-message
+ (if (fboundp 'format-message) 'format-message
+ ;; for Emacs < 25, and XEmacs, don't worry about quote translation.
+ 'format))
+
;; 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)
(defun gnus-timer--function (timer)
(elt timer 5)))
+(defun gnus-test-list (list predicate)
+ "To each element of LIST apply PREDICATE.
+Return nil if LIST is no list or is empty or some test returns nil;
+otherwise, return t."
+ (when (and list (listp list))
+ (let ((result (mapcar predicate list)))
+ (not (memq nil result)))))
+
+(defun gnus-subsetp (list1 list2)
+ "Return t if LIST1 is a subset of LIST2.
+Similar to `subsetp' but use member for element test so that this works for
+lists of strings."
+ (when (and (listp list1) (listp list2))
+ (if list1
+ (and (member (car list1) list2)
+ (gnus-subsetp (cdr list1) list2))
+ t)))
+
+(defun gnus-setdiff (list1 list2)
+ "Return member-based set difference of LIST1 and LIST2."
+ (when (and list1 (listp list1) (listp list2))
+ (if (member (car list1) list2)
+ (gnus-setdiff (cdr list1) list2)
+ (cons (car list1) (gnus-setdiff (cdr list1) list2)))))
+
(provide 'gnus-util)
;;; gnus-util.el ends here