mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-07 15:00:34 -08:00
Code Issues Projects Releases Wiki Activity

Rewrite gmm-labels usage to use cl-labels

Browse source 
* lisp/gnus/gmm-utils.el (gmm-tool-bar-style): Remove compat code.
(gmm-labels): Remove.
This commit is contained in:
Lars Ingebrigtsen 2016-02-13 16:40:17 +11:00
parent d919f56c24
commit d88118db37
4 changed files with 163 additions and 154 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -196,10 +196,9 @@ This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility."
(defcustom gmm-tool-bar-style (defcustom gmm-tool-bar-style
(if (and (boundp 'tool-bar-mode) (if (and (boundp 'tool-bar-mode)
tool-bar-mode tool-bar-mode
(and (fboundp 'display-visual-class) (memq (display-visual-class)
(not (memq (display-visual-class) (list 'static-gray 'gray-scale
(list 'static-gray 'gray-scale 'static-color 'pseudo-color)))
'static-color 'pseudo-color)))))
'gnome 'gnome
'retro) 'retro)
"Preferred tool bar style." "Preferred tool bar style."
@ -390,20 +389,6 @@ If mode is nil, use `major-mode' of the current buffer."
(string-match "^\\(.+\\)-mode$" mode) (string-match "^\\(.+\\)-mode$" mode)
(match-string 1 mode)))))) (match-string 1 mode))))))
;; `labels' is obsolete since Emacs 24.3.
(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) (defun gmm-format-time-string (format-string &optional time tz)
"Use FORMAT-STRING to format the time TIME, or now if omitted. "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 The optional TZ specifies the time zone in a number of seconds; any

289
lisp/gnus/gnus-icalendar.el
View file

@ -152,17 +152,19 @@
(defun gnus-icalendar-event--find-attendee (ical name-or-email) (defun gnus-icalendar-event--find-attendee (ical name-or-email)
(let* ((event (car (icalendar--all-events ical))) (let* ((event (car (icalendar--all-events ical)))
(event-props (caddr event))) (event-props (caddr event)))
(gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN)) (cl-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
(attendee-email (att) (attendee-email
(replace-regexp-in-string "^.*MAILTO:" "" (caddr att))) (att)
(attendee-prop-matches-p (prop) (replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
(and (eq (car prop) 'ATTENDEE) (attendee-prop-matches-p
(or (member (attendee-name prop) name-or-email) (prop)
(let ((att-email (attendee-email prop))) (and (eq (car prop) 'ATTENDEE)
(gnus-icalendar-find-if (lambda (email) (or (member (attendee-name prop) name-or-email)
(string-match email att-email)) (let ((att-email (attendee-email prop)))
name-or-email)))))) (gnus-icalendar-find-if
(lambda (email)
(string-match email att-email))
name-or-email))))))
(gnus-icalendar-find-if #'attendee-prop-matches-p event-props)))) (gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
(defun gnus-icalendar-event--get-attendee-names (ical) (defun gnus-icalendar-event--get-attendee-names (ical)
@ -171,17 +173,19 @@
(lambda (p) (eq (car p) 'ATTENDEE)) (lambda (p) (eq (car p) 'ATTENDEE))
(caddr event)))) (caddr event))))
(gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) (cl-labels
(attendee-name (prop) ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
(or (plist-get (cadr prop) 'CN) (attendee-name
(replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) (prop)
(attendees-by-type (type) (or (plist-get (cadr prop) 'CN)
(gnus-remove-if-not (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop))))
(lambda (p) (string= (attendee-role p) type)) (attendees-by-type (type)
attendee-props)) (gnus-remove-if-not
(attendee-names-by-type (type) (lambda (p) (string= (attendee-role p) type))
(mapcar #'attendee-name (attendees-by-type type)))) attendee-props))
(attendee-names-by-type
(type)
(mapcar #'attendee-name (attendees-by-type type))))
(list (list
(attendee-names-by-type "REQ-PARTICIPANT") (attendee-names-by-type "REQ-PARTICIPANT")
(attendee-names-by-type "OPT-PARTICIPANT"))))) (attendee-names-by-type "OPT-PARTICIPANT")))))
@ -220,23 +224,25 @@
((string= method "REPLY") 'gnus-icalendar-event-reply) ((string= method "REPLY") 'gnus-icalendar-event-reply)
(t 'gnus-icalendar-event)))) (t 'gnus-icalendar-event))))
(gmm-labels ((map-property (prop) (cl-labels
(let ((value (icalendar--get-event-property event prop))) ((map-property
(when value (prop)
;; ugly, but cannot get (let ((value (icalendar--get-event-property event prop)))
;;replace-regexp-in-string work with "\\" as (when value
;;REP, plus we should also handle "\\;" ;; ugly, but cannot get
(replace-regexp-in-string ;;replace-regexp-in-string work with "\\" as
"\\\\," "," ;;REP, plus we should also handle "\\;"
(replace-regexp-in-string (replace-regexp-in-string
"\\\\n" "\n" (substring-no-properties value)))))) "\\\\," ","
(accumulate-args (mapping) (replace-regexp-in-string
(destructuring-bind (slot . ical-property) mapping "\\\\n" "\n" (substring-no-properties value))))))
(setq args (append (list (accumulate-args
(intern (concat ":" (symbol-name slot))) (mapping)
(map-property ical-property)) (destructuring-bind (slot . ical-property) mapping
args))))) (setq args (append (list
(intern (concat ":" (symbol-name slot)))
(map-property ical-property))
args)))))
(mapc #'accumulate-args prop-map) (mapc #'accumulate-args prop-map)
(apply 'make-instance event-class args)))) (apply 'make-instance event-class args))))
@ -264,41 +270,46 @@ status will be retrieved from the first matching attendee record."
(let ((summary-status (capitalize (symbol-name status))) (let ((summary-status (capitalize (symbol-name status)))
(attendee-status (upcase (symbol-name status))) (attendee-status (upcase (symbol-name status)))
reply-event-lines) reply-event-lines)
(gmm-labels ((update-summary (line) (cl-labels
(if (string-match "^[^:]+:" line) ((update-summary
(replace-match (format "\\&%s: " summary-status) t nil line) (line)
line)) (if (string-match "^[^:]+:" line)
(update-dtstamp () (replace-match (format "\\&%s: " summary-status) t nil line)
(format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t)) line))
(attendee-matches-identity (line) (update-dtstamp ()
(gnus-icalendar-find-if (lambda (name) (string-match-p name line)) (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t))
identities)) (attendee-matches-identity
(update-attendee-status (line) (line)
(when (and (attendee-matches-identity line) (gnus-icalendar-find-if (lambda (name) (string-match-p name line))
(string-match "\\(PARTSTAT=\\)[^;]+" line)) identities))
(replace-match (format "\\1%s" attendee-status) t nil line))) (update-attendee-status
(process-event-line (line) (line)
(when (string-match "^\\([^;:]+\\)" line) (when (and (attendee-matches-identity line)
(let* ((key (match-string 0 line)) (string-match "\\(PARTSTAT=\\)[^;]+" line))
;; NOTE: not all of the below fields are mandatory, (replace-match (format "\\1%s" attendee-status) t nil line)))
;; but they are often present in other clients' (process-event-line
;; replies. Can be helpful for debugging, too. (line)
(new-line (when (string-match "^\\([^;:]+\\)" line)
(cond (let* ((key (match-string 0 line))
((string= key "ATTENDEE") (update-attendee-status line)) ;; NOTE: not all of the below fields are mandatory,
((string= key "SUMMARY") (update-summary line)) ;; but they are often present in other clients'
((string= key "DTSTAMP") (update-dtstamp)) ;; replies. Can be helpful for debugging, too.
((member key '("ORGANIZER" "DTSTART" "DTEND" (new-line
"LOCATION" "DURATION" "SEQUENCE" (cond
"RECURRENCE-ID" "UID")) line) ((string= key "ATTENDEE") (update-attendee-status line))
(t nil)))) ((string= key "SUMMARY") (update-summary line))
(when new-line ((string= key "DTSTAMP") (update-dtstamp))
(push new-line reply-event-lines)))))) ((member key '("ORGANIZER" "DTSTART" "DTEND"
"LOCATION" "DURATION" "SEQUENCE"
"RECURRENCE-ID" "UID")) line)
(t nil))))
(when new-line
(push new-line reply-event-lines))))))
(mapc #'process-event-line (split-string ical-request "\n")) (mapc #'process-event-line (split-string ical-request "\n"))
(unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
reply-event-lines) reply-event-lines)
(error "Could not find an event attendee matching given identity")) (error "Could not find an event attendee matching given identity"))
(mapconcat #'identity `("BEGIN:VEVENT" (mapconcat #'identity `("BEGIN:VEVENT"
@ -311,16 +322,17 @@ status will be retrieved from the first matching attendee record."
The reply will have STATUS (`accepted', `tentative' or `declined'). The reply will have STATUS (`accepted', `tentative' or `declined').
The reply will be composed for attendees matching any entry The reply will be composed for attendees matching any entry
on the IDENTITIES list." on the IDENTITIES list."
(gmm-labels ((extract-block (blockname) (cl-labels
(save-excursion ((extract-block
(let ((block-start-re (format "^BEGIN:%s" blockname)) (blockname)
(block-end-re (format "^END:%s" blockname)) (save-excursion
start) (let ((block-start-re (format "^BEGIN:%s" blockname))
(when (re-search-forward block-start-re nil t) (block-end-re (format "^END:%s" blockname))
(setq start (line-beginning-position)) start)
(re-search-forward block-end-re) (when (re-search-forward block-start-re nil t)
(buffer-substring-no-properties start (line-end-position))))))) (setq start (line-beginning-position))
(re-search-forward block-end-re)
(buffer-substring-no-properties start (line-end-position)))))))
(let (zone event) (let (zone event)
(with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf)) (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
(goto-char (point-min)) (goto-char (point-min))
@ -497,16 +509,17 @@ the optional ORG-FILE argument is specified, only that one file
is searched." is searched."
(let ((uid (gnus-icalendar-event:uid event)) (let ((uid (gnus-icalendar-event:uid event))
(files (or org-file (org-agenda-files t 'ifmode)))) (files (or org-file (org-agenda-files t 'ifmode))))
(gmm-labels (cl-labels
((find-event-in (file) ((find-event-in
(org-check-agenda-file file) (file)
(with-current-buffer (find-file-noselect file) (org-check-agenda-file file)
(let ((event-pos (org-find-entry-with-id uid))) (with-current-buffer (find-file-noselect file)
(when (and event-pos (let ((event-pos (org-find-entry-with-id uid)))
(string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos))) (when (and event-pos
"t")) (string= (cdr (assoc "ICAL_EVENT"
(throw 'found file)))))) (org-entry-properties event-pos)))
"t"))
(throw 'found file))))))
(gnus-icalendar-find-if #'find-event-in files)))) (gnus-icalendar-find-if #'find-event-in files))))
@ -566,22 +579,29 @@ is searched."
(fill-region (point-min) (point-max)))) (fill-region (point-min) (point-max))))
;; update entry properties ;; update entry properties
(gmm-labels (cl-labels
((update-org-entry (position property value) ((update-org-entry
(if (or (null value) (position property value)
(string= value "")) (if (or (null value)
(org-entry-delete position property) (string= value ""))
(org-entry-put position property value)))) (org-entry-delete position property)
(org-entry-put position property value))))
(update-org-entry event-pos "ORGANIZER" organizer) (update-org-entry event-pos "ORGANIZER" organizer)
(update-org-entry event-pos "LOCATION" location) (update-org-entry event-pos "LOCATION" location)
(update-org-entry event-pos "PARTICIPATION_TYPE" (symbol-name participation-type)) (update-org-entry event-pos "PARTICIPATION_TYPE"
(update-org-entry event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants)) (symbol-name participation-type))
(update-org-entry event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants)) (update-org-entry event-pos "REQ_PARTICIPANTS"
(gnus-icalendar--format-participant-list
req-participants))
(update-org-entry event-pos "OPT_PARTICIPANTS"
(gnus-icalendar--format-participant-list
opt-participants))
(update-org-entry event-pos "RRULE" recur) (update-org-entry event-pos "RRULE" recur)
(update-org-entry event-pos "REPLY" (update-org-entry
(if reply-status (capitalize (symbol-name reply-status)) event-pos "REPLY"
"Not replied yet"))) (if reply-status (capitalize (symbol-name reply-status))
"Not replied yet")))
(save-buffer))))))))) (save-buffer)))))))))
@ -714,30 +734,31 @@ These will be used to retrieve the RSVP information from ical events."
;; TODO: make the template customizable ;; TODO: make the template customizable
(cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status) (cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
"Format an overview of EVENT details." "Format an overview of EVENT details."
(gmm-labels ((format-header (x) (cl-labels
(format "%-12s%s" ((format-header (x)
(propertize (concat (car x) ":") 'face 'bold) (format "%-12s%s"
(cadr x)))) (propertize (concat (car x) ":") 'face 'bold)
(cadr x))))
(with-slots (organizer summary description location recur uid (with-slots (organizer summary description location recur uid
method rsvp participation-type) event method rsvp participation-type) event
(let ((headers `(("Summary" ,summary) (let ((headers `(("Summary" ,summary)
("Location" ,(or location "")) ("Location" ,(or location ""))
("Time" ,(gnus-icalendar-event:org-timestamp event)) ("Time" ,(gnus-icalendar-event:org-timestamp event))
("Organizer" ,organizer) ("Organizer" ,organizer)
("Attendance" ,(if (eq participation-type 'non-participant) ("Attendance" ,(if (eq participation-type 'non-participant)
"You are not listed as an attendee" "You are not listed as an attendee"
(capitalize (symbol-name participation-type)))) (capitalize (symbol-name participation-type))))
("Method" ,method)))) ("Method" ,method))))
(when (and (not (gnus-icalendar-event-reply-p event)) rsvp) (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
(setq headers (append headers (setq headers (append headers
`(("Status" ,(or reply-status "Not replied yet")))))) `(("Status" ,(or reply-status "Not replied yet"))))))
(concat (concat
(mapconcat #'format-header headers "\n") (mapconcat #'format-header headers "\n")
"\n\n" "\n\n"
description))))) description)))))
(defmacro gnus-icalendar-with-decoded-handle (handle &rest body) (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
"Execute BODY in buffer containing the decoded contents of HANDLE." "Execute BODY in buffer containing the decoded contents of HANDLE."
@ -793,11 +814,13 @@ These will be used to retrieve the RSVP information from ical events."
(current-buffer) status (gnus-icalendar-identities))))) (current-buffer) status (gnus-icalendar-identities)))))
(when reply (when reply
(gmm-labels ((fold-icalendar-buffer () (cl-labels
(goto-char (point-min)) ((fold-icalendar-buffer
(while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t) ()
(replace-match "\\1\n \\2") (goto-char (point-min))
(goto-char (line-beginning-position))))) (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
(replace-match "\\1\n \\2")
(goto-char (line-beginning-position)))))
(let ((subject (concat (capitalize (symbol-name status)) (let ((subject (concat (capitalize (symbol-name status))
": " (gnus-icalendar-event:summary event)))) ": " (gnus-icalendar-event:summary event))))
@ -867,13 +890,15 @@ These will be used to retrieve the RSVP information from ical events."
(setq gnus-icalendar-reply-status nil) (setq gnus-icalendar-reply-status nil)
(when event (when event
(gmm-labels ((insert-button-group (buttons) (cl-labels
(when buttons ((insert-button-group
(mapc (lambda (x) (buttons)
(apply 'gnus-icalendar-insert-button x) (when buttons
(insert " ")) (mapc (lambda (x)
buttons) (apply 'gnus-icalendar-insert-button x)
(insert "\n\n")))) (insert " "))
buttons)
(insert "\n\n"))))
(insert-button-group (insert-button-group
(gnus-icalendar-event:inline-reply-buttons event handle)) (gnus-icalendar-event:inline-reply-buttons event handle))

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

@ -1727,7 +1727,7 @@ score in `gnus-newsgroup-scored' by SCORE."
nil) nil)
(defun gnus-score-decode-text-parts () (defun gnus-score-decode-text-parts ()
(gmm-labels (cl-labels
((mm-text-parts ((mm-text-parts
(handle) (handle)
(cond ((stringp (car handle)) (cond ((stringp (car handle))
@ -1751,7 +1751,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(mm-display-inline handle) (mm-display-inline handle)
(goto-char (point-max)))))) (goto-char (point-max))))))
(let (;(mm-text-html-renderer 'w3m-standalone) (let ( ;(mm-text-html-renderer 'w3m-standalone)
(handles (mm-dissect-buffer t))) (handles (mm-dissect-buffer t)))
(save-excursion (save-excursion
(article-goto-body) (article-goto-body)

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

@ -1748,12 +1748,11 @@ Sizes are in pixels."
image))) image)))
image))) image)))
(eval-when-compile (require 'gmm-utils))
(defun gnus-recursive-directory-files (dir) (defun gnus-recursive-directory-files (dir)
"Return all regular files below DIR. "Return all regular files below DIR.
The first found will be returned if a file has hard or symbolic links." The first found will be returned if a file has hard or symbolic links."
(let (files attr attrs) (let (files attr attrs)
(gmm-labels (cl-labels
((fn (directory) ((fn (directory)
(dolist (file (directory-files directory t)) (dolist (file (directory-files directory t))
(setq attr (file-attributes (file-truename file))) (setq attr (file-attributes (file-truename file)))