X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgmm-utils.el;h=3a1bb030e298ddc8d8770766fa53707da9a29bd1;hb=eac68931aa33d79c85ca6f118eb15ffe8489c4fc;hp=9be6c66b63a474008b0f0a6f8a7f6523749f484c;hpb=1dd17bf9b604184bffb73cceb9e3892b323efd52;p=gnus diff --git a/lisp/gmm-utils.el b/lisp/gmm-utils.el index 9be6c66b6..3a1bb030e 100644 --- a/lisp/gmm-utils.el +++ b/lisp/gmm-utils.el @@ -1,6 +1,6 @@ ;;; gmm-utils.el --- Utility functions for Gnus, Message and MML -;; Copyright (C) 2006-2012 Free Software Foundation, Inc. +;; Copyright (C) 2006-2014 Free Software Foundation, Inc. ;; Author: Reiner Steib ;; Keywords: news @@ -99,7 +99,7 @@ ARGS are passed to `message'." ;; 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 a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." :format "%{%t%}: %v" @@ -417,33 +417,80 @@ coding-system." (write-region start end filename append visit lockname)) (write-region start end filename append visit lockname mustbenew))) -;; `flet' and `labels' got obsolete since Emacs 24.3. +;; `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...)" - `(let (fn origs) - (dolist (bind ',bindings) - (setq fn (car bind)) - (push (cons fn (and (fboundp fn) (symbol-function fn))) origs) - (fset fn (cons 'lambda (cdr bind)))) - (unwind-protect - (progn ,@body) - (dolist (orig origs) - (if (cdr orig) - (fset (car orig) (cdr orig)) - (fmakunbound (car orig))))))) + (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 lexical scoping is handled via `lexical-let' rather than relying -on `lexical-binding'. +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)