From d88118db37dd543536677d7c4212a2c67621fb88 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 13 Feb 2016 16:40:17 +1100 Subject: [PATCH] Rewrite gmm-labels usage to use cl-labels * lisp/gnus/gmm-utils.el (gmm-tool-bar-style): Remove compat code. (gmm-labels): Remove. --- lisp/gnus/gmm-utils.el | 21 +-- lisp/gnus/gnus-icalendar.el | 293 +++++++++++++++++++----------------- lisp/gnus/gnus-score.el | 4 +- lisp/gnus/gnus-util.el | 3 +- 4 files changed, 165 insertions(+), 156 deletions(-) diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index a18b4c77539..30bddef4123 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -196,10 +196,9 @@ This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." (defcustom gmm-tool-bar-style (if (and (boundp 'tool-bar-mode) tool-bar-mode - (and (fboundp 'display-visual-class) - (not (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color))))) + (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color))) 'gnome 'retro) "Preferred tool bar style." @@ -390,20 +389,6 @@ If mode is nil, use `major-mode' of the current buffer." (string-match "^\\(.+\\)-mode$" 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) "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 diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 17faac451a6..c684007d7f3 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -152,17 +152,19 @@ (defun gnus-icalendar-event--find-attendee (ical name-or-email) (let* ((event (car (icalendar--all-events ical))) (event-props (caddr event))) - (gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN)) - (attendee-email (att) - (replace-regexp-in-string "^.*MAILTO:" "" (caddr att))) - (attendee-prop-matches-p (prop) - (and (eq (car prop) 'ATTENDEE) - (or (member (attendee-name prop) name-or-email) - (let ((att-email (attendee-email prop))) - (gnus-icalendar-find-if (lambda (email) - (string-match email att-email)) - name-or-email)))))) - + (cl-labels ((attendee-name (att) (plist-get (cadr att) 'CN)) + (attendee-email + (att) + (replace-regexp-in-string "^.*MAILTO:" "" (caddr att))) + (attendee-prop-matches-p + (prop) + (and (eq (car prop) 'ATTENDEE) + (or (member (attendee-name prop) name-or-email) + (let ((att-email (attendee-email prop))) + (gnus-icalendar-find-if + (lambda (email) + (string-match email att-email)) + name-or-email)))))) (gnus-icalendar-find-if #'attendee-prop-matches-p event-props)))) (defun gnus-icalendar-event--get-attendee-names (ical) @@ -171,17 +173,19 @@ (lambda (p) (eq (car p) 'ATTENDEE)) (caddr event)))) - (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) - (attendee-name (prop) - (or (plist-get (cadr prop) 'CN) - (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) - (attendees-by-type (type) - (gnus-remove-if-not - (lambda (p) (string= (attendee-role p) type)) - attendee-props)) - (attendee-names-by-type (type) - (mapcar #'attendee-name (attendees-by-type type)))) - + (cl-labels + ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) + (attendee-name + (prop) + (or (plist-get (cadr prop) 'CN) + (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) + (attendees-by-type (type) + (gnus-remove-if-not + (lambda (p) (string= (attendee-role p) type)) + attendee-props)) + (attendee-names-by-type + (type) + (mapcar #'attendee-name (attendees-by-type type)))) (list (attendee-names-by-type "REQ-PARTICIPANT") (attendee-names-by-type "OPT-PARTICIPANT"))))) @@ -220,23 +224,25 @@ ((string= method "REPLY") 'gnus-icalendar-event-reply) (t 'gnus-icalendar-event)))) - (gmm-labels ((map-property (prop) - (let ((value (icalendar--get-event-property event prop))) - (when value - ;; ugly, but cannot get - ;;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) - (destructuring-bind (slot . ical-property) mapping - (setq args (append (list - (intern (concat ":" (symbol-name slot))) - (map-property ical-property)) - args))))) - + (cl-labels + ((map-property + (prop) + (let ((value (icalendar--get-event-property event prop))) + (when value + ;; ugly, but cannot get + ;;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) + (destructuring-bind (slot . ical-property) mapping + (setq args (append (list + (intern (concat ":" (symbol-name slot))) + (map-property ical-property)) + args))))) (mapc #'accumulate-args prop-map) (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))) (attendee-status (upcase (symbol-name status))) reply-event-lines) - (gmm-labels ((update-summary (line) - (if (string-match "^[^:]+:" line) - (replace-match (format "\\&%s: " summary-status) t nil line) - line)) - (update-dtstamp () - (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t)) - (attendee-matches-identity (line) - (gnus-icalendar-find-if (lambda (name) (string-match-p name line)) - identities)) - (update-attendee-status (line) - (when (and (attendee-matches-identity line) - (string-match "\\(PARTSTAT=\\)[^;]+" line)) - (replace-match (format "\\1%s" attendee-status) t nil line))) - (process-event-line (line) - (when (string-match "^\\([^;:]+\\)" line) - (let* ((key (match-string 0 line)) - ;; NOTE: not all of the below fields are mandatory, - ;; but they are often present in other clients' - ;; replies. Can be helpful for debugging, too. - (new-line - (cond - ((string= key "ATTENDEE") (update-attendee-status line)) - ((string= key "SUMMARY") (update-summary line)) - ((string= key "DTSTAMP") (update-dtstamp)) - ((member key '("ORGANIZER" "DTSTART" "DTEND" - "LOCATION" "DURATION" "SEQUENCE" - "RECURRENCE-ID" "UID")) line) - (t nil)))) - (when new-line - (push new-line reply-event-lines)))))) + (cl-labels + ((update-summary + (line) + (if (string-match "^[^:]+:" line) + (replace-match (format "\\&%s: " summary-status) t nil line) + line)) + (update-dtstamp () + (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t)) + (attendee-matches-identity + (line) + (gnus-icalendar-find-if (lambda (name) (string-match-p name line)) + identities)) + (update-attendee-status + (line) + (when (and (attendee-matches-identity line) + (string-match "\\(PARTSTAT=\\)[^;]+" line)) + (replace-match (format "\\1%s" attendee-status) t nil line))) + (process-event-line + (line) + (when (string-match "^\\([^;:]+\\)" line) + (let* ((key (match-string 0 line)) + ;; NOTE: not all of the below fields are mandatory, + ;; but they are often present in other clients' + ;; replies. Can be helpful for debugging, too. + (new-line + (cond + ((string= key "ATTENDEE") (update-attendee-status line)) + ((string= key "SUMMARY") (update-summary line)) + ((string= key "DTSTAMP") (update-dtstamp)) + ((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")) (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")) (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 be composed for attendees matching any entry on the IDENTITIES list." - (gmm-labels ((extract-block (blockname) - (save-excursion - (let ((block-start-re (format "^BEGIN:%s" blockname)) - (block-end-re (format "^END:%s" blockname)) - start) - (when (re-search-forward block-start-re nil t) - (setq start (line-beginning-position)) - (re-search-forward block-end-re) - (buffer-substring-no-properties start (line-end-position))))))) - + (cl-labels + ((extract-block + (blockname) + (save-excursion + (let ((block-start-re (format "^BEGIN:%s" blockname)) + (block-end-re (format "^END:%s" blockname)) + start) + (when (re-search-forward block-start-re nil t) + (setq start (line-beginning-position)) + (re-search-forward block-end-re) + (buffer-substring-no-properties start (line-end-position))))))) (let (zone event) (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf)) (goto-char (point-min)) @@ -497,16 +509,17 @@ the optional ORG-FILE argument is specified, only that one file is searched." (let ((uid (gnus-icalendar-event:uid event)) (files (or org-file (org-agenda-files t 'ifmode)))) - (gmm-labels - ((find-event-in (file) - (org-check-agenda-file file) - (with-current-buffer (find-file-noselect file) - (let ((event-pos (org-find-entry-with-id uid))) - (when (and event-pos - (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos))) - "t")) - (throw 'found file)))))) - + (cl-labels + ((find-event-in + (file) + (org-check-agenda-file file) + (with-current-buffer (find-file-noselect file) + (let ((event-pos (org-find-entry-with-id uid))) + (when (and event-pos + (string= (cdr (assoc "ICAL_EVENT" + (org-entry-properties event-pos))) + "t")) + (throw 'found file)))))) (gnus-icalendar-find-if #'find-event-in files)))) @@ -566,22 +579,29 @@ is searched." (fill-region (point-min) (point-max)))) ;; update entry properties - (gmm-labels - ((update-org-entry (position property value) - (if (or (null value) - (string= value "")) - (org-entry-delete position property) - (org-entry-put position property value)))) + (cl-labels + ((update-org-entry + (position property value) + (if (or (null value) + (string= value "")) + (org-entry-delete position property) + (org-entry-put position property value)))) (update-org-entry event-pos "ORGANIZER" organizer) (update-org-entry event-pos "LOCATION" location) - (update-org-entry event-pos "PARTICIPATION_TYPE" (symbol-name participation-type)) - (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 "PARTICIPATION_TYPE" + (symbol-name participation-type)) + (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 "REPLY" - (if reply-status (capitalize (symbol-name reply-status)) - "Not replied yet"))) + (update-org-entry + event-pos "REPLY" + (if reply-status (capitalize (symbol-name reply-status)) + "Not replied yet"))) (save-buffer))))))))) @@ -714,30 +734,31 @@ These will be used to retrieve the RSVP information from ical events." ;; TODO: make the template customizable (cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status) "Format an overview of EVENT details." - (gmm-labels ((format-header (x) - (format "%-12s%s" - (propertize (concat (car x) ":") 'face 'bold) - (cadr x)))) + (cl-labels + ((format-header (x) + (format "%-12s%s" + (propertize (concat (car x) ":") 'face 'bold) + (cadr x)))) (with-slots (organizer summary description location recur uid method rsvp participation-type) event (let ((headers `(("Summary" ,summary) - ("Location" ,(or location "")) - ("Time" ,(gnus-icalendar-event:org-timestamp event)) - ("Organizer" ,organizer) - ("Attendance" ,(if (eq participation-type 'non-participant) - "You are not listed as an attendee" - (capitalize (symbol-name participation-type)))) - ("Method" ,method)))) - - (when (and (not (gnus-icalendar-event-reply-p event)) rsvp) - (setq headers (append headers - `(("Status" ,(or reply-status "Not replied yet")))))) - - (concat - (mapconcat #'format-header headers "\n") - "\n\n" - description))))) + ("Location" ,(or location "")) + ("Time" ,(gnus-icalendar-event:org-timestamp event)) + ("Organizer" ,organizer) + ("Attendance" ,(if (eq participation-type 'non-participant) + "You are not listed as an attendee" + (capitalize (symbol-name participation-type)))) + ("Method" ,method)))) + + (when (and (not (gnus-icalendar-event-reply-p event)) rsvp) + (setq headers (append headers + `(("Status" ,(or reply-status "Not replied yet")))))) + + (concat + (mapconcat #'format-header headers "\n") + "\n\n" + description))))) (defmacro gnus-icalendar-with-decoded-handle (handle &rest body) "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))))) (when reply - (gmm-labels ((fold-icalendar-buffer () - (goto-char (point-min)) - (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t) - (replace-match "\\1\n \\2") - (goto-char (line-beginning-position))))) + (cl-labels + ((fold-icalendar-buffer + () + (goto-char (point-min)) + (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t) + (replace-match "\\1\n \\2") + (goto-char (line-beginning-position))))) (let ((subject (concat (capitalize (symbol-name status)) ": " (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) (when event - (gmm-labels ((insert-button-group (buttons) - (when buttons - (mapc (lambda (x) - (apply 'gnus-icalendar-insert-button x) - (insert " ")) - buttons) - (insert "\n\n")))) + (cl-labels + ((insert-button-group + (buttons) + (when buttons + (mapc (lambda (x) + (apply 'gnus-icalendar-insert-button x) + (insert " ")) + buttons) + (insert "\n\n")))) (insert-button-group (gnus-icalendar-event:inline-reply-buttons event handle)) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 1a12a0fc373..22ff7b9eba3 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -1727,7 +1727,7 @@ score in `gnus-newsgroup-scored' by SCORE." nil) (defun gnus-score-decode-text-parts () - (gmm-labels + (cl-labels ((mm-text-parts (handle) (cond ((stringp (car handle)) @@ -1751,7 +1751,7 @@ score in `gnus-newsgroup-scored' by SCORE." (mm-display-inline handle) (goto-char (point-max)))))) - (let (;(mm-text-html-renderer 'w3m-standalone) + (let ( ;(mm-text-html-renderer 'w3m-standalone) (handles (mm-dissect-buffer t))) (save-excursion (article-goto-body) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 284f094f7a5..6ca0de3cf54 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1748,12 +1748,11 @@ Sizes are in pixels." image))) image))) -(eval-when-compile (require 'gmm-utils)) (defun gnus-recursive-directory-files (dir) "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 + (cl-labels ((fn (directory) (dolist (file (directory-files directory t)) (setq attr (file-attributes (file-truename file))) -- 2.39.2