procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

gmm-utils.el (gmm-flet, gmm-labels): New macros.

Browse source 
gnus-sync.el (gnus-sync-lesync-call)
message.el (message-read-from-minibuffer): Use gmm-flet.
gnus-score.el (gnus-score-decode-text-parts): Use gmm-labels.
gnus-util.el (gnus-macroexpand-all): Remove.
This commit is contained in:
Katsumi Yamaoka 2012-12-04 08:22:12 +00:00
parent ce3e7725b4
commit 46a2cc4470
6 changed files with 100 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
lisp/gnus/ChangeLog
View file

@ -1,3 +1,14 @@
2012-12-04 Katsumi Yamaoka <yamaoka@jpl.org>
* gmm-utils.el (gmm-flet, gmm-labels): New macros.
* gnus-sync.el (gnus-sync-lesync-call)
* message.el (message-read-from-minibuffer): Use gmm-flet.
* gnus-score.el (gnus-score-decode-text-parts): Use gmm-labels.
* gnus-util.el (gnus-macroexpand-all): Remove.
2012-12-03 Andreas Schwab <schwab@linux-m68k.org>
* gnus-sum.el (gnus-summary-mode-map): Bind gnus-summary-widget-forward

60
lisp/gnus/gmm-utils.el
View file

@ -417,6 +417,66 @@ 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.
(defmacro gmm-flet (bindings &rest body)
"Make temporary overriding function definitions.
\(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)))))))
(put 'gmm-flet 'lisp-indent-function 1)
;; An alist of original function names and those unique names.
(defvar gmm-labels-environment)
(defun gmm-labels-expand (form)
"Expand funcalls in FORM according to `gmm-labels-environment'.
This function is a subroutine that `gmm-labels' uses to convert any
`(FN ...)' and #'FN elements in FORM into `(funcall UN ...)' and `UN'
respectively if `(FN . UN)' is listed in `gmm-labels-environment'."
(cond ((or (not (consp form)) (memq (car form) '(\` backquote quote)))
form)
((assq (car form) gmm-labels-environment)
`(funcall ,(cdr (assq (car form) gmm-labels-environment))
,@(mapcar #'gmm-labels-expand (cdr form))))
((eq (car form) 'function)
(if (and (assq (cadr form) gmm-labels-environment)
(not (cddr form)))
(cdr (assq (cadr form) gmm-labels-environment))
(cons 'function (mapcar #'gmm-labels-expand (cdr form)))))
(t
(mapcar #'gmm-labels-expand 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'.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(let (gmm-labels-environment def defs)
(dolist (binding bindings)
(push (cons (car binding)
(make-symbol (format "--gmm-%s--" (car binding))))
gmm-labels-environment))
`(lexical-let ,(mapcar #'cdr gmm-labels-environment)
(setq ,@(dolist (env gmm-labels-environment (nreverse defs))
(setq def (cdr (assq (car env) bindings)))
(push (cdr env) defs)
(push `(lambda ,(car def)
,@(mapcar #'gmm-labels-expand (cdr def)))
defs)))
,@(mapcar #'gmm-labels-expand body))))
(put 'gmm-labels 'lisp-indent-function 1)
(provide 'gmm-utils)
;;; gmm-utils.el ends here

48
lisp/gnus/gnus-score.el
View file

@ -33,6 +33,7 @@
(require 'gnus-win)
(require 'message)
(require 'score-mode)
(require 'gmm-utils)
(defcustom gnus-global-score-files nil
"List of global score files and directories.
@ -1718,33 +1719,36 @@ score in `gnus-newsgroup-scored' by SCORE."
nil)
(defun gnus-score-decode-text-parts ()
(labels ((mm-text-parts (handle)
(cond ((stringp (car handle))
(let ((parts (mapcan #'mm-text-parts (cdr handle))))
(if (equal "multipart/alternative" (car handle))
;; pick the first supported alternative
(list (car parts))
parts)))
(gmm-labels
((mm-text-parts
(handle)
(cond ((stringp (car handle))
(let ((parts (mapcan #'mm-text-parts (cdr handle))))
(if (equal "multipart/alternative" (car handle))
;; pick the first supported alternative
(list (car parts))
parts)))
((bufferp (car handle))
(when (string-match "^text/" (mm-handle-media-type handle))
(list handle)))
((bufferp (car handle))
(when (string-match "^text/" (mm-handle-media-type handle))
(list handle)))
(t (mapcan #'mm-text-parts handle))))
(my-mm-display-part (handle)
(when handle
(save-restriction
(narrow-to-region (point) (point))
(mm-display-inline handle)
(goto-char (point-max))))))
(t (mapcan #'mm-text-parts handle))))
(my-mm-display-part
(handle)
(when handle
(save-restriction
(narrow-to-region (point) (point))
(mm-display-inline handle)
(goto-char (point-max))))))
(let (;(mm-text-html-renderer 'w3m-standalone)
(handles (mm-dissect-buffer t)))
(handles (mm-dissect-buffer t)))
(save-excursion
(article-goto-body)
(delete-region (point) (point-max))
(mapc #'my-mm-display-part (mm-text-parts handles))
handles))))
(article-goto-body)
(delete-region (point) (point-max))
(mapc #'my-mm-display-part (mm-text-parts handles))
handles))))
(defun gnus-score-body (scores header now expire &optional trace)
(if gnus-agent-fetching

3
lisp/gnus/gnus-sync.el
View file

@ -88,6 +88,7 @@
(require 'gnus)
(require 'gnus-start)
(require 'gnus-util)
(require 'gmm-utils)
(defvar gnus-topic-alist) ;; gnus-group.el
(eval-when-compile
@ -176,7 +177,7 @@ and `gnus-topic-alist'. Also see `gnus-variable-list'."
(defun gnus-sync-lesync-call (url method headers &optional kvdata)
"Make an access request to URL using KVDATA and METHOD.
KVDATA must be an alist."
(flet ((json-alist-p (list) (gnus-sync-json-alist-p list))) ; temp patch
(gmm-flet ((json-alist-p (list) (gnus-sync-json-alist-p list))) ; temp patch
(let ((url-request-method method)
(url-request-extra-headers headers)
(url-request-data (if kvdata (json-encode kvdata) nil)))

21
lisp/gnus/gnus-util.el
View file

@ -1938,27 +1938,6 @@ to case differences."
(string-equal (downcase str1) (downcase prefix))
(string-equal str1 prefix))))))
(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)

2
lisp/gnus/message.el
View file

@ -8141,7 +8141,7 @@ regexp VARSTR."
(if (fboundp 'mail-abbrevs-setup)
(let ((minibuffer-setup-hook 'mail-abbrevs-setup)
(minibuffer-local-map message-minibuffer-local-map))
(flet ((mail-abbrev-in-expansion-header-p nil t))
(gmm-flet ((mail-abbrev-in-expansion-header-p nil t))
(read-from-minibuffer prompt initial-contents)))
(let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
(minibuffer-local-map message-minibuffer-local-map))