X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgmm-utils.el;h=2f24f8c03bfc268de222c0075babfec873fd1da0;hb=585ce63470b33b1f54c0ff555e2ff1dbd393aace;hp=4fe3736974d828f5c53027292339eaab29edb79b;hpb=c9107492c745b4713d5b4980d504858a7a22f70c;p=gnus diff --git a/lisp/gmm-utils.el b/lisp/gmm-utils.el index 4fe373697..2f24f8c03 100644 --- a/lisp/gmm-utils.el +++ b/lisp/gmm-utils.el @@ -1,39 +1,37 @@ ;;; gmm-utils.el --- Utility functions for Gnus, Message and MML -;; Copyright (C) 2006 Free Software Foundation, Inc. +;; Copyright (C) 2006-2015 Free Software Foundation, Inc. ;; Author: Reiner Steib ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;; This library provides self-contained utility functions. The functions are ;; used in Gnus, Message and MML, but within this library there are no -;; dependencies on Gnus, Message, or MML or Gnus. +;; dependencies on Gnus, Message, or MML. ;;; Code: (defgroup gmm nil - "Utility functions for Gnus, Message and MML" + "Utility functions for Gnus, Message and MML." :prefix "gmm-" - :version "23.0" ;; No Gnus + :version "22.1" ;; Gnus 5.10.9 :group 'lisp) ;; Helper functions from `gnus-utils.el': gmm-verbose, gmm-message, gmm-error @@ -41,20 +39,35 @@ (defcustom gmm-verbose 7 "Integer that says how verbose gmm should be. The higher the number, the more messages will flash to say what -it done. At zero, it will be totally mute; at five, it will +it did. At zero, it will be totally mute; at five, it will display most important messages; and at ten, it will keep on jabbering all the time." :type 'integer :group 'gmm) +;;;###autoload +(defun gmm-regexp-concat (regexp) + "Potentially concat a list of regexps into a single one. +The concatenation is done with logical ORs." + (cond ((null regexp) + nil) + ((stringp regexp) + regexp) + ((listp regexp) + (mapconcat (lambda (elt) (concat "\\(" elt "\\)")) + regexp + "\\|")))) + ;;;###autoload (defun gmm-message (level &rest args) "If LEVEL is lower than `gmm-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." +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 gmm-verbose) (apply 'message args) ;; We have to do this format thingy here even if the result isn't @@ -77,14 +90,18 @@ ARGS are passed to `message'." ;;;###autoload (defun gmm-widget-p (symbol) - "Non-nil iff SYMBOL is a widget." + "Non-nil if SYMBOL is a widget." (get symbol 'widget-type)) +(autoload 'widget-create-child-value "wid-edit") +(autoload 'widget-convert "wid-edit") +(autoload 'widget-default-get "wid-edit") + ;; Copy of the `nnmail-lazy' code from `nnmail.el': (define-widget 'gmm-lazy 'default - "Base widget for recursive datastructures. + "Base widget for recursive data structures. -This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." +This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." :format "%{%t%}: %v" :convert-widget 'widget-value-convert-widget :value-create (lambda (widget) @@ -123,7 +140,7 @@ This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." ;; :mouse-2 command-on-mouse-2-press ;; :mouse-3 command-on-mouse-3-press) ;; typically a menu of related commands ;; -;; Combinations of mouse-[23] plus shift and/or controll might be overkill. +;; Combinations of mouse-[23] plus shift and/or control might be overkill. ;; ;; Then use (plist-get rs-command :none), (plist-get rs-command :shift) @@ -200,9 +217,9 @@ This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." 'static-color 'pseudo-color))))) 'gnome 'retro) - "Prefered tool bar style." - :type '(choice (const :tag "GNOME style" 'gnome) - (const :tag "Retro look" 'retro)) + "Preferred tool bar style." + :type '(choice (const :tag "GNOME style" gnome) + (const :tag "Retro look" retro)) :group 'gmm) (defvar tool-bar-map) @@ -215,7 +232,7 @@ Within each entry of ICON-LIST, the first element is a menu command, the second element is an icon file name and the third element is a test function. You can use \\[describe-key] to find out the name of a menu command. The fourth -and all following elements are passed a the PROPS argument to the +and all following elements are passed as the PROPS argument to the function `tool-bar-local-item'. If ZAP-LIST is a list, remove those item from the default @@ -250,38 +267,23 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." ;; (tool-bar-add-item ICON DEF KEY &rest PROPS) (apply 'tool-bar-add-item icon nil nil :enable nil props))) ((equal fmap t) ;; Not a menu command - (if (fboundp 'tool-bar-local-item) - (apply 'tool-bar-local-item - icon command - (intern icon) ;; reuse icon or fmap here? - tool-bar-map props) - ;; Emacs 21 compatibility: - (apply 'tool-bar-add-item - icon command - (intern icon) - props))) + (apply 'tool-bar-local-item + icon command + (intern icon) ;; reuse icon or fmap here? + tool-bar-map props)) (t ;; A menu command - (if (fboundp 'tool-bar-local-item-from-menu) - (apply 'tool-bar-local-item-from-menu - ;; (apply 'tool-bar-local-item icon def key - ;; tool-bar-map props) - command icon tool-bar-map (symbol-value fmap) - props) - ;; Emacs 21 compatibility: - (apply 'tool-bar-add-item-from-menu - command icon (symbol-value fmap) - props)))) + (apply 'tool-bar-local-item-from-menu + ;; (apply 'tool-bar-local-item icon def key + ;; tool-bar-map props) + command icon tool-bar-map (symbol-value fmap) + props))) t)) (if (symbolp icon-list) (eval icon-list) icon-list)) tool-bar-map)) -;; WARNING: The following is subject to change. Don't rely on it yet. - -;; From MH-E without modifications: - -(defmacro gmm-defun-compat (name function arg-list &rest body) +(defmacro defun-gmm (name function arg-list &rest body) "Create function NAME. If FUNCTION exists, then NAME becomes an alias for FUNCTION. Otherwise, create function NAME with ARG-LIST and BODY." @@ -290,48 +292,77 @@ Otherwise, create function NAME with ARG-LIST and BODY." `(defalias ',name ',function) `(defun ,name ,arg-list ,@body)))) -(gmm-defun-compat gmm-image-search-load-path +(defun-gmm gmm-image-search-load-path image-search-load-path (file &optional path) "Emacs 21 and XEmacs don't have `image-search-load-path'. This function returns nil on those systems." nil) -;; From MH-E with modifications: +;; Cf. `mh-image-load-path-for-library' in `mh-compat.el'. -;; Don't use `gmm-defun-compat' until API changes in -;; `image-load-path-for-library' in Emacs CVS are completed. +(defun-gmm gmm-image-load-path-for-library + image-load-path-for-library (library image &optional path no-error) + "Return a suitable search path for images used by LIBRARY. -(defun gmm-image-load-path-for-library (library image &optional path no-error) - "Return a suitable search path for images relative to LIBRARY. +It searches for IMAGE in `image-load-path' (excluding +\"`data-directory'/images\") and `load-path', followed by a path +suitable for LIBRARY, which includes \"../../etc/images\" and +\"../etc/images\" relative to the library file itself, and then +in \"`data-directory'/images\". -Images for LIBRARY are searched for in \"../../etc/images\" and -\"../etc/images\" relative to the files in \"lisp/LIBRARY\" as -well as in `image-load-path' and `load-path'. +Then this function returns a list of directories which contains +first the directory in which IMAGE was found, followed by the +value of `load-path'. If PATH is given, it is used instead of +`load-path'. -This function returns the value of `load-path' augmented with the -path to IMAGE. If PATH is given, it is used instead of -`load-path'. If PATH is t, return a single image directory -instead of a path. - -If NO-ERROR is non-nil, don't signal an error if no suitable path -can be found. +If NO-ERROR is non-nil and a suitable path can't be found, don't +signal an error. Instead, return a list of directories as before, +except that nil appears in place of the image directory. Here is an example that uses a common idiom to provide compatibility with versions of Emacs that lack the variable `image-load-path': - (let ((load-path - (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) - (image-load-path - (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\" 'image-load-path))) - (mh-tool-bar-folder-buttons-init)) + ;; Shush compiler. + (defvar image-load-path) -This function is used by Emacs versions that don't have -`image-load-path-for-library'." + (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) + (image-load-path (cons (car load-path) + (when (boundp 'image-load-path) + image-load-path)))) + (mh-tool-bar-folder-buttons-init))" (unless library (error "No library specified")) (unless image (error "No image specified")) - (let ((image-directory)) + (let (image-directory image-directory-load-path) + ;; Check for images in image-load-path or load-path. + (let ((img image) + (dir (or + ;; Images in image-load-path. + (gmm-image-search-load-path image) ;; "gmm-" prefix! + ;; Images in load-path. + (locate-library image))) + parent) + ;; Since the image might be in a nested directory (for + ;; example, mail/attach.pbm), adjust `image-directory' + ;; accordingly. + (when dir + (setq dir (file-name-directory dir)) + (while (setq parent (file-name-directory img)) + (setq img (directory-file-name parent) + dir (expand-file-name "../" dir)))) + (setq image-directory-load-path dir)) + + ;; If `image-directory-load-path' isn't Emacs's image directory, + ;; it's probably a user preference, so use it. Then use a + ;; relative setting if possible; otherwise, use + ;; `image-directory-load-path'. (cond + ;; User-modified image-load-path? + ((and image-directory-load-path + (not (equal image-directory-load-path + (file-name-as-directory + (expand-file-name "images" data-directory))))) + (setq image-directory image-directory-load-path)) ;; Try relative setting. ((let (library-name d1ei d2ei) ;; First, find library in the load-path. @@ -341,55 +372,32 @@ This function is used by Emacs versions that don't have ;; And then set image-directory relative to that. (setq ;; Go down 2 levels. - d2ei (expand-file-name - (concat (file-name-directory library-name) "../../etc/images")) + d2ei (file-name-as-directory + (expand-file-name + (concat (file-name-directory library-name) "../../etc/images"))) ;; Go down 1 level. - d1ei (expand-file-name - (concat (file-name-directory library-name) "../etc/images"))) + d1ei (file-name-as-directory + (expand-file-name + (concat (file-name-directory library-name) "../etc/images")))) (setq image-directory ;; Set it to nil if image is not found. (cond ((file-exists-p (expand-file-name image d2ei)) d2ei) ((file-exists-p (expand-file-name image d1ei)) d1ei))))) - ;; Check for images in image-load-path or load-path. - ((let ((img image) - (dir (or - ;; Images in image-load-path. - (gmm-image-search-load-path image) - ;; Images in load-path. - (locate-library image))) - parent) - ;; Since the image might be in a nested directory (for - ;; example, mail/attach.pbm), adjust `image-directory' - ;; accordingly. - (and dir - (setq dir (file-name-directory dir)) - (progn - (while (setq parent (file-name-directory img)) - (setq img (directory-file-name parent) - dir (expand-file-name "../" dir))) - (setq image-directory dir))))) + ;; Use Emacs's image directory. + (image-directory-load-path + (setq image-directory image-directory-load-path)) (no-error - ;; In this case we will return a nil element - (gmm-message 1 "Could not find image %s for library %s" image library)) + (message "Could not find image %s for library %s" image library)) (t (error "Could not find image %s for library %s" image library))) - ;; Return augmented `image-load-path' or `load-path'. - (cond ((eq path t) - image-directory) - ((and path (symbolp path)) - (nconc (list image-directory) - (delete image-directory - (if (boundp path) - (copy-sequence (symbol-value path)) - nil)))) - (t - (nconc (list image-directory) - (delete image-directory (copy-sequence load-path))))))) + ;; Return an augmented `path' or `load-path'. + (nconc (list image-directory) + (delete image-directory (copy-sequence (or path load-path)))))) (defun gmm-customize-mode (&optional mode) "Customize customization group for MODE. -If mode is nil, use `major-mode' of the curent buffer." +If mode is nil, use `major-mode' of the current buffer." (interactive) (customize-group (or mode @@ -397,7 +405,93 @@ If mode is nil, use `major-mode' of the curent buffer." (string-match "^\\(.+\\)-mode$" mode) (match-string 1 mode)))))) +(defun gmm-write-region (start end filename &optional append visit + lockname mustbenew) + "Compatibility function for `write-region'. + +In XEmacs, the seventh argument of `write-region' specifies the +coding-system." + (if (and mustbenew (featurep 'xemacs)) + (if (file-exists-p filename) + (signal 'file-already-exists (list "File exists" filename)) + (write-region start end filename append visit lockname)) + (write-region start end filename append visit lockname mustbenew))) + +;; `interactive-p' is obsolete since Emacs 23.2. +(defmacro gmm-called-interactively-p (kind) + (condition-case nil + (progn + (eval '(called-interactively-p 'any)) + ;; Emacs >=23.2 + `(called-interactively-p ,kind)) + ;; Emacs <23.2 + (wrong-number-of-arguments '(called-interactively-p)) + ;; XEmacs + (void-function '(interactive-p)))) + +;; `flet' and `labels' are obsolete since Emacs 24.3. +(defmacro gmm-flet (bindings &rest body) + "Make temporary overriding function definitions. +This is an analogue of a dynamically scoped `let' that operates on +the function cell of FUNCs rather than their value cell. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (require 'cl) + (if (fboundp 'cl-letf) + `(cl-letf ,(mapcar (lambda (binding) + `((symbol-function ',(car binding)) + (lambda ,@(cdr binding)))) + bindings) + ,@body) + `(flet ,bindings ,@body))) +(put 'gmm-flet 'lisp-indent-function 1) +(put 'gmm-flet 'edebug-form-spec '((&rest (sexp sexp &rest form)) &rest form)) + +(defmacro gmm-labels (bindings &rest body) + "Make temporary function bindings. +The bindings can be recursive and the scoping is lexical, but capturing +them in closures will only work if `lexical-binding' is in use. But in +Emacs 24.2 and older, the lexical scoping is handled via `lexical-let' +rather than relying on `lexical-binding'. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + `(,(progn (require 'cl) (if (fboundp 'cl-labels) 'cl-labels 'labels)) + ,bindings ,@body)) +(put 'gmm-labels 'lisp-indent-function 1) +(put 'gmm-labels 'edebug-form-spec '((&rest (sexp sexp &rest form)) &rest form)) + +(defun gmm-format-time-string (format-string &optional time tz) + "Use FORMAT-STRING to format the time TIME, or now if omitted. +The optional TZ specifies the time zone in a number of seconds; any +other non-nil value will be treated as 0. Note that both the format +specifiers `%Z' and `%z' will be replaced with a numeric form. " +;; FIXME: is there a smart way to replace %Z with a time zone name? + (if (and (numberp tz) (not (zerop tz))) + (let ((st 0) + (case-fold-search t) + ls nd rest) + (setq time (if time + (copy-sequence time) + (current-time))) + (if (>= (setq ls (- (cadr time) (car (current-time-zone)) (- tz))) 0) + (setcar (cdr time) ls) + (setcar (cdr time) (+ ls 65536)) + (setcar time (1- (car time)))) + (setq tz (format "%s%02d%02d" + (if (>= tz 0) "+" "-") + (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))) + (while (string-match "%+z" format-string st) + (if (zerop (% (- (setq nd (match-end 0)) (match-beginning 0)) 2)) + (progn + (push (substring format-string st (- nd 2)) rest) + (push tz rest)) + (push (substring format-string st nd) rest)) + (setq st nd)) + (push (substring format-string st) rest) + (format-time-string (apply 'concat (nreverse rest)) time)) + (format-time-string format-string time tz))) + (provide 'gmm-utils) -;; arch-tag: e0b60920-2ce6-40c1-bfc0-cadbbe26b602 ;;; gmm-utils.el ends here