Using saved parent location: http://bzr.savannah.gnu.org/r/emacs/trunk/ Now on revision 102530. ------------------------------------------------------------ revno: 102530 committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 07:35:42 +0000 message: shr.el (shr-insert): Revert last change. shr.el (shr-find-fill-point): Never leave point being at bol; relax the kinsoku limitation when rendering tables. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 02:37:23 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 07:35:42 +0000 @@ -1,3 +1,9 @@ +2010-11-26 Katsumi Yamaoka + + * shr.el (shr-insert): Revert last change. + (shr-find-fill-point): Never leave point being at bol; + relax the kinsoku limitation when rendering tables. + 2010-11-26 Lars Magne Ingebrigtsen * nnmail.el (nnmail-expiry-target-group): Protect against degenerate === modified file 'lisp/gnus/shr.el' --- lisp/gnus/shr.el 2010-11-25 14:51:51 +0000 +++ lisp/gnus/shr.el 2010-11-26 07:35:42 +0000 @@ -254,7 +254,7 @@ (while (and (> (current-column) shr-width) (progn (setq found (shr-find-fill-point)) - (not (or (bolp) (eolp))))) + (not (eolp)))) (when (eq (preceding-char) ? ) (delete-char -1)) (insert "\n") @@ -278,7 +278,8 @@ (or (setq failed (= (current-column) shr-indentation)) (eq (preceding-char) ? ) (eq (following-char) ? ) - (aref fill-find-break-point-function-table (preceding-char)))) + (aref fill-find-break-point-function-table (preceding-char)) + (aref (char-category-set (preceding-char)) ?>))) (backward-char 1)) (if failed ;; There's no breakable point, so we give it up. @@ -287,30 +288,52 @@ (while (aref fill-find-break-point-function-table (preceding-char)) (backward-char 1)) nil) - (or (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line, - (let ((count 4)) - (if (or shr-kinsoku-shorten - (and (aref (char-category-set (preceding-char)) ?<) - (progn - (setq count (1- count)) - (backward-char 1) - t))) - (while (and - (>= (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (aref (char-category-set (preceding-char)) ?<) - (aref (char-category-set (following-char)) ?>))) - (backward-char 1)) - (while (and (>= (setq count (1- count)) 0) - (aref (char-category-set (following-char)) ?>) - (aref fill-find-break-point-function-table - (following-char))) - (forward-char 1))) - (when (eq (following-char) ? ) - (forward-char 1)) - t))))) + (or + (eolp) + (progn + ;; Don't put kinsoku-bol characters at the beginning of a line, + ;; or kinsoku-eol characters at the end of a line. + (cond + (shr-kinsoku-shorten + (while (and + (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) + (not (or (aref (char-category-set (preceding-char)) ?>) + (aref (char-category-set (following-char)) ?<))) + (or (aref (char-category-set (preceding-char)) ?<) + (aref (char-category-set (following-char)) ?>))) + (backward-char 1))) + ((aref (char-category-set (preceding-char)) ?<) + (let ((count 3)) + (while (progn + (backward-char 1) + (and + (> (setq count (1- count)) 0) + (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) + (or (aref (char-category-set (preceding-char)) ?<) + (aref (char-category-set (following-char)) ?>)))))) + (if (and (setq failed (= (current-column) shr-indentation)) + (re-search-forward "\\c|" (line-end-position) 'move)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we look for the second best position. + (let (bp) + (while (and (<= (current-column) shr-width) + (progn + (setq bp (point)) + (not (eolp))) + (aref fill-find-break-point-function-table + (following-char))) + (forward-char 1)) + (goto-char (or bp (line-end-position)))))) + (t + (let ((count 4)) + (while (and (>= (setq count (1- count)) 0) + (aref (char-category-set (following-char)) ?>) + (aref fill-find-break-point-function-table + (following-char))) + (forward-char 1))))) + (when (eq (following-char) ? ) + (forward-char 1)) + (not failed)))))) (defun shr-ensure-newline () (unless (zerop (current-column)) ------------------------------------------------------------ revno: 102529 committer: Glenn Morris branch nick: trunk timestamp: Thu 2010-11-25 19:22:49 -0800 message: * lisp/calendar/diary-lib.el (diary-outlook-format): Remove pointless element. diff: === modified file 'lisp/calendar/diary-lib.el' --- lisp/calendar/diary-lib.el 2010-11-26 03:19:58 +0000 +++ lisp/calendar/diary-lib.el 2010-11-26 03:22:49 +0000 @@ -346,7 +346,7 @@ ;; Where: Meeting room B ("[ \t\n]*When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \ \\([0-9]\\{4\\}\\),? \\(.+\\)\n\ -\\(?:Where: \\(.+\n\\)\n*\\)?" . diary-outlook-format-1)) +\\(?:Where: \\(.+\n\\)\\)?" . diary-outlook-format-1)) "Alist of regexps matching message text and replacement text. The regexp must match the start of the message text containing an ------------------------------------------------------------ revno: 102528 committer: Glenn Morris branch nick: trunk timestamp: Thu 2010-11-25 19:19:58 -0800 message: * lisp/calendar/diary-lib.el (diary-outlook-format-1): Another fix. diff: === modified file 'lisp/calendar/diary-lib.el' --- lisp/calendar/diary-lib.el 2010-11-26 03:14:03 +0000 +++ lisp/calendar/diary-lib.el 2010-11-26 03:19:58 +0000 @@ -323,8 +323,7 @@ ;; If we could convert the monthname to a numeric month, we can ;; use the standard function calendar-date-string. (concat (if month - (calendar-date-string (list (string-to-number month) - (string-to-number day) + (calendar-date-string (list month (string-to-number day) (string-to-number year))) (cond ((eq calendar-date-style 'iso) "\\3 \\1 \\2") ; YMD ((eq calendar-date-style 'european) "\\2 \\1 \\3") ; DMY ------------------------------------------------------------ revno: 102527 committer: Glenn Morris branch nick: trunk timestamp: Thu 2010-11-25 19:14:03 -0800 message: * lisp/calendar/diary-lib.el (diary-outlook-format-1): Fix match-strings. diff: === modified file 'lisp/calendar/diary-lib.el' --- lisp/calendar/diary-lib.el 2010-11-26 03:10:16 +0000 +++ lisp/calendar/diary-lib.el 2010-11-26 03:14:03 +0000 @@ -309,11 +309,10 @@ "Return a replace-match template for an element of `diary-outlook-formats'. Returns a string using match elements 1-5, where: 1 = month name, 2 = day, 3 = year, 4 = time, 5 = location; also uses -%s = message subject. -The argument BODY is not used." - (let* ((monthname (match-string 1)) - (day (match-string 2)) - (year (match-string 3)) +%s = message subject. BODY is the string from which the matches derive." + (let* ((monthname (match-string 1 body)) + (day (match-string 2 body)) + (year (match-string 3 body)) ;; Blech. (month (catch 'found (dotimes (i (length calendar-month-name-array)) ------------------------------------------------------------ revno: 102526 committer: Glenn Morris branch nick: trunk timestamp: Thu 2010-11-25 19:10:16 -0800 message: diary-lib.el diary-outlook* changes. * lisp/calendar/diary-lib.el (diary-outlook-format-1): New function, so that diary-outlook-formats can be sensitive to calendar-date-style. (diary-outlook-formats): Simplify the default setting. (diary-from-outlook-internal): Pass subject and body as arguments. Use dolist rather than dotimes. Don't save the diary buffer. (diary-from-outlook-gnus, diary-from-outlook-rmail): Pass subject and body as explicit arguments to the -internal function. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-11-26 02:28:03 +0000 +++ lisp/ChangeLog 2010-11-26 03:10:16 +0000 @@ -1,3 +1,13 @@ +2010-11-26 Glenn Morris + + * calendar/diary-lib.el (diary-outlook-format-1): New function, so that + diary-outlook-formats can be sensitive to calendar-date-style. + (diary-outlook-formats): Simplify the default setting. + (diary-from-outlook-internal): Pass subject and body as arguments. + Use dolist rather than dotimes. Don't save the diary buffer. + (diary-from-outlook-gnus, diary-from-outlook-rmail): + Pass subject and body as explicit arguments to the -internal function. + 2010-11-26 Lars Magne Ingebrigtsen * mail/rfc2368.el (rfc2368-parse-mailto-url): Unfold URLs before === modified file 'lisp/calendar/diary-lib.el' --- lisp/calendar/diary-lib.el 2010-11-20 22:29:35 +0000 +++ lisp/calendar/diary-lib.el 2010-11-26 03:10:16 +0000 @@ -305,28 +305,50 @@ :type 'boolean :group 'diary) +(defun diary-outlook-format-1 (body) + "Return a replace-match template for an element of `diary-outlook-formats'. +Returns a string using match elements 1-5, where: +1 = month name, 2 = day, 3 = year, 4 = time, 5 = location; also uses +%s = message subject. +The argument BODY is not used." + (let* ((monthname (match-string 1)) + (day (match-string 2)) + (year (match-string 3)) + ;; Blech. + (month (catch 'found + (dotimes (i (length calendar-month-name-array)) + (if (string-equal (aref calendar-month-name-array i) + monthname) + (throw 'found (1+ i)))) + nil))) + ;; If we could convert the monthname to a numeric month, we can + ;; use the standard function calendar-date-string. + (concat (if month + (calendar-date-string (list (string-to-number month) + (string-to-number day) + (string-to-number year))) + (cond ((eq calendar-date-style 'iso) "\\3 \\1 \\2") ; YMD + ((eq calendar-date-style 'european) "\\2 \\1 \\3") ; DMY + (t "\\1 \\2 \\3"))) ; MDY + "\n \\4 %s, \\5"))) +;; TODO Sometimes the time is in a different time-zone to the one you +;; are in. Eg in PST, you might still get an email referring to: +;; "7:00 PM-8:00 PM. Greenwich Standard Time". +;; Note that it doesn't use a standard abbreviation for the timezone, +;; or anything helpful like that. +;; Sigh, this could cause the meeting to even be on a different day +;; to that given in the When: string. +;; These things seem to come in a multipart mail with a calendar part, +;; it's probably better to use that rather than this whole thing. +;; So this is unlikely to get improved. + +;; TODO Is the format of these messages actually documented anywhere? (defcustom diary-outlook-formats - '( - ;; When: 11 October 2001 12:00-14:00 (GMT) Greenwich Mean Time : Dublin, ... - ;; [Current UK format? The timezone is meaningless. Sometimes the - ;; Where is missing.] - ("When: \\([0-9]+ [[:alpha:]]+ [0-9]+\\) \ -\\([^ ]+\\) [^\n]+ -\[^\n]+ -\\(?:Where: \\([^\n]+\\)\n+\\)? -\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*" - . "\\1\n \\2 %s, \\3") - ;; When: Tuesday, April 30, 2002 03:00 PM-03:30 PM (GMT) Greenwich Mean ... - ;; [Old UK format?] - ("^When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \\([0-9]\\{4\\}\\) \ -\\([^ ]+\\) [^\n]+ -\[^\n]+ -\\(?:Where: \\([^\n]+\\)\\)?\n+" - . "\\2 \\1 \\3\n \\4 %s, \\5") - ( - ;; German format, apparently. - "^Zeit: [^ ]+, +\\([0-9]+\\)\. +\\([[:upper:]][[:lower:]][[:lower:]]\\)[^ ]* +\\([0-9]+\\) +\\([^ ]+\\).*$" - . "\\1 \\2 \\3\n \\4 %s")) + '(;; When: Tuesday, November 9, 2010 7:00 PM-8:00 PM. Greenwich Standard Time + ;; Where: Meeting room B + ("[ \t\n]*When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \ +\\([0-9]\\{4\\}\\),? \\(.+\\)\n\ +\\(?:Where: \\(.+\n\\)\n*\\)?" . diary-outlook-format-1)) "Alist of regexps matching message text and replacement text. The regexp must match the start of the message text containing an @@ -836,7 +858,7 @@ (kill-local-variable 'mode-line-format)) (defvar original-date) ; bound in diary-list-entries -(defvar number) +;(defvar number) ; already declared above (defun diary-include-other-diary-files () "Include the diary entries from other diary files with those of `diary-file'. @@ -2414,25 +2436,19 @@ ;; functions `diary-from-outlook-gnus' and `diary-from-outlook-rmail', ;; could be run from hooks to notice appointments automatically (in ;; which case they will prompt about adding to the diary). The -;; message formats recognized are customizable through -;; `diary-outlook-formats'. - -(defvar subject) ; bound in diary-from-outlook-gnus -(defvar body) - -(defun diary-from-outlook-internal (&optional test-only) +;; message formats recognized are customizable through `diary-outlook-formats'. + +(defun diary-from-outlook-internal (subject body &optional test-only) "Snarf a diary entry from a message assumed to be from MS Outlook. -Assumes `body' is bound to a string comprising the body of the message and -`subject' is bound to a string comprising its subject. +SUBJECT and BODY are strings giving the message subject and body. Arg TEST-ONLY non-nil means return non-nil if and only if the message contains an appointment, don't make a diary entry." (catch 'finished (let (format-string) - (dotimes (i (length diary-outlook-formats)) - (when (eq 0 (string-match (car (nth i diary-outlook-formats)) - body)) + (dolist (fmt diary-outlook-formats) + (when (eq 0 (string-match (car fmt) body)) (unless test-only - (setq format-string (cdr (nth i diary-outlook-formats))) + (setq format-string (cdr fmt)) (save-excursion (save-window-excursion (diary-make-entry @@ -2440,8 +2456,7 @@ (funcall format-string body) format-string) t nil (match-string 0 body)) - subject)) - (save-buffer)))) + subject))))) (throw 'finished t)))) nil)) @@ -2469,9 +2484,9 @@ (save-restriction (gnus-narrow-to-body) (buffer-string))))) - (when (diary-from-outlook-internal t) + (when (diary-from-outlook-internal subject body t) (when (or noconfirm (y-or-n-p "Snarf diary entry? ")) - (diary-from-outlook-internal) + (diary-from-outlook-internal subject body) (message "Diary entry added")))))) (custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus) @@ -2484,15 +2499,17 @@ this function is called interactively), then if an entry is found the user is asked to confirm its addition." (interactive "p") + ;; FIXME maybe the body needs rmail-mm decoding, in which case + ;; there is no single buffer with both body and subject, sigh. (with-current-buffer rmail-buffer (let ((subject (mail-fetch-field "subject")) (body (buffer-substring (save-excursion (rfc822-goto-eoh) (point)) (point-max)))) - (when (diary-from-outlook-internal t) + (when (diary-from-outlook-internal subject body t) (when (or noconfirm (y-or-n-p "Snarf diary entry? ")) - (diary-from-outlook-internal) + (diary-from-outlook-internal subject body) (message "Diary entry added")))))) (defun diary-from-outlook (&optional noconfirm) ------------------------------------------------------------ revno: 102525 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 02:37:23 +0000 message: nnmail.el (nnmail-expiry-target-group): Protect against degenerate results from -accept-article. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 02:31:57 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 02:37:23 +0000 @@ -1,5 +1,10 @@ 2010-11-26 Lars Magne Ingebrigtsen + * nnmail.el (nnmail-expiry-target-group): Protect against degenerate + results from -accept-article. + + * shr-color.el: Require cl when compiling. + * nnheader.el (nnheader-update-marks-actions): Fix typo in last checkin. === modified file 'lisp/gnus/nnmail.el' --- lisp/gnus/nnmail.el 2010-11-01 06:21:44 +0000 +++ lisp/gnus/nnmail.el 2010-11-26 02:37:23 +0000 @@ -1916,7 +1916,8 @@ (when (or (gnus-request-group target) (gnus-request-create-group target)) (let ((group-art (gnus-request-accept-article target nil t t))) - (when (consp group-art) + (when (and (consp group-art) + (cdr group-art)) (gnus-group-mark-article-read target (cdr group-art)))))))) (defun nnmail-fancy-expiry-target (group) === modified file 'lisp/gnus/shr-color.el' --- lisp/gnus/shr-color.el 2010-11-25 14:51:51 +0000 +++ lisp/gnus/shr-color.el 2010-11-26 02:37:23 +0000 @@ -27,6 +27,7 @@ ;;; Code: (require 'color) +(eval-when-compile (require 'cl)) (defgroup shr-color nil "Simple HTML Renderer colors" ------------------------------------------------------------ revno: 102524 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 02:31:57 +0000 message: gnus-art.el (gnus-url-mailto): Unfold URLs before using them. nnheader.el (nnheader-update-marks-actions): Fix typo in last checkin. shr-color.el: Require cl when compiling. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 02:17:55 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 02:31:57 +0000 @@ -1,5 +1,10 @@ 2010-11-26 Lars Magne Ingebrigtsen + * nnheader.el (nnheader-update-marks-actions): Fix typo in last + checkin. + + * gnus-art.el (gnus-url-mailto): Unfold URLs before using them. + * nnimap.el (nnimap-request-set-mark): Add is "+", not "-". * gnus-sum.el (gnus-summary-push-marks-to-backend): Use 'set instead of === modified file 'lisp/gnus/gnus-art.el' --- lisp/gnus/gnus-art.el 2010-11-22 11:33:06 +0000 +++ lisp/gnus/gnus-art.el 2010-11-26 02:31:57 +0000 @@ -8146,6 +8146,7 @@ (defun gnus-url-mailto (url) ;; Send mail to someone + (setq url (replace-regexp-in-string "\n" " " url)) (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) (let (to args subject func) === modified file 'lisp/gnus/nnheader.el' --- lisp/gnus/nnheader.el 2010-11-26 02:11:40 +0000 +++ lisp/gnus/nnheader.el 2010-11-26 02:31:57 +0000 @@ -1089,12 +1089,12 @@ mark (cond ((eq what 'add) - (gnus-range-add (cdr (assoc mark backend-marks)) range) - ((eq what 'del) - (gnus-remove-from-range - (cdr (assoc mark backend-marks)) range)) - ((eq what 'set) - range))) + (gnus-range-add (cdr (assoc mark backend-marks)) range)) + ((eq what 'del) + (gnus-remove-from-range + (cdr (assoc mark backend-marks)) range)) + ((eq what 'set) + range)) backend-marks))))) backend-marks) ------------------------------------------------------------ revno: 102523 committer: Lars Magne Ingebrigtsen branch nick: trunk timestamp: Fri 2010-11-26 03:28:03 +0100 message: * mail/rfc2368.el (rfc2368-parse-mailto-url): Unfold URLs before parsing them. This makes mailto:...?subject=foo\nbar work. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-11-25 04:43:56 +0000 +++ lisp/ChangeLog 2010-11-26 02:28:03 +0000 @@ -1,3 +1,8 @@ +2010-11-26 Lars Magne Ingebrigtsen + + * mail/rfc2368.el (rfc2368-parse-mailto-url): Unfold URLs before + parsing them. This makes mailto:...?subject=foo\nbar work. + 2010-11-25 Stefan Monnier * vc/diff.el (diff): Fix last change. === modified file 'lisp/mail/rfc2368.el' --- lisp/mail/rfc2368.el 2010-01-13 08:35:10 +0000 +++ lisp/mail/rfc2368.el 2010-11-26 02:28:03 +0000 @@ -92,13 +92,11 @@ calling this function." (let ((case-fold-search t) prequery query headers-alist) - + (setq mailto-url (replace-regexp-in-string "\n" " " mailto-url)) (if (string-match rfc2368-mailto-regexp mailto-url) (progn - (setq prequery (match-string rfc2368-mailto-prequery-index mailto-url)) - (setq query (match-string rfc2368-mailto-query-index mailto-url)) @@ -131,10 +129,8 @@ headers-alist) - (error "Failed to match a mailto: url")) - )) + (error "Failed to match a mailto: url")))) (provide 'rfc2368) -;; arch-tag: ea804934-ad96-4f69-957b-857a76e4fd95 ;;; rfc2368.el ends here ------------------------------------------------------------ revno: 102522 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 02:17:55 +0000 message: nnimap.el (nnimap-request-set-mark): Add is "+", not "-". diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 02:11:40 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 02:17:55 +0000 @@ -1,5 +1,7 @@ 2010-11-26 Lars Magne Ingebrigtsen + * nnimap.el (nnimap-request-set-mark): Add is "+", not "-". + * gnus-sum.el (gnus-summary-push-marks-to-backend): Use 'set instead of 'add and 'delete to set backend marks. === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-26 02:11:40 +0000 +++ lisp/gnus/nnimap.el 2010-11-26 02:17:55 +0000 @@ -928,6 +928,7 @@ flags)) (deffoo nnimap-request-set-mark (group actions &optional server) + (debug) (when (nnimap-possibly-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) @@ -943,7 +944,7 @@ (nnimap-article-ranges range) (cond ((eq action 'del) "-") - ((eq action 'add) "-") + ((eq action 'add) "+") ((eq action 'set) "")) (mapconcat #'identity flags " "))))))) ;; Wait for the last command to complete to avoid later ------------------------------------------------------------ revno: 102521 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 02:11:40 +0000 message: nnml.el, nnfolder.el, nntp.el (*-request-set-mark): Extend syntax with 'set. nnheader.el, nntp.el, nnfolder.el, nnml.el (*-request-set-mark): Refactor out nnheader-update-marks-actions and use it throughout. nnmaildir.el (nnmaildir-request-set-mark): Be explicit about 'set. gnus-sum.el (gnus-summary-push-marks-to-backend): Use 'set instead of 'add and 'delete to set backend marks. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 01:27:37 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 02:11:40 +0000 @@ -1,5 +1,18 @@ 2010-11-26 Lars Magne Ingebrigtsen + * gnus-sum.el (gnus-summary-push-marks-to-backend): Use 'set instead of + 'add and 'delete to set backend marks. + + * nnmaildir.el (nnmaildir-request-set-mark): Be explicit about 'set. + + * nnheader.el (nnheader-update-marks-actions): Refactor out. + + * nntp.el (nntp-request-set-mark): Use it. + + * nnfolder.el (nnfolder-request-set-mark): Ditto. + + * nnml.el (nnml-request-set-mark): Ditto. + * nnimap.el (nnimap-last-response-string): Remove the unfolding -- it introduces regressions in article selection. (nnimap-find-uid-response): New function. @@ -7,6 +20,13 @@ (nnimap-request-move-article): Use the UID returned, if any. (nnimap-get-groups): Reimplement to work with folded lines. (nnimap-find-uid-response): The UID is the last element in the list. + (nnimap-request-set-mark): Extend syntax with 'set. + + * nnml.el (nnml-request-set-mark): Ditto. + + * nnfolder.el (nnfolder-request-set-mark): Ditto. + + * nntp.el (nntp-request-set-mark): Ditto. 2010-11-25 Katsumi Yamaoka === modified file 'lisp/gnus/gnus-sum.el' --- lisp/gnus/gnus-sum.el 2010-11-25 11:14:14 +0000 +++ lisp/gnus/gnus-sum.el 2010-11-26 02:11:40 +0000 @@ -9948,23 +9948,18 @@ (gnus-set-mode-line 'summary))) (defun gnus-summary-push-marks-to-backend (article) - (let ((add nil) - (delete nil) + (let ((set nil) (marks gnus-article-mark-lists)) - (if (memq article gnus-newsgroup-unreads) - (push 'read add) - (push 'read delete)) + (when (memq article gnus-newsgroup-unreads) + (push 'read set)) (while marks - (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) - (if (memq article (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))) - (push (cdar marks) add) - (push (cdar marks) delete))) + (when (and (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks)))))) + (push (cdar marks) set)) (pop marks)) - (gnus-request-set-mark gnus-newsgroup-name - `(((,article) add ,add) - ((,article) del ,delete))))) + (gnus-request-set-mark gnus-newsgroup-name `(((,article) set ,set))))) (defun gnus-summary-copy-article (&optional n to-newsgroup select-method) "Copy the current article to some other group. === modified file 'lisp/gnus/nnfolder.el' --- lisp/gnus/nnfolder.el 2010-10-11 23:29:33 +0000 +++ lisp/gnus/nnfolder.el 2010-11-26 02:11:40 +0000 @@ -1186,19 +1186,7 @@ (nnfolder-open-server server)) (unless nnfolder-marks-is-evil (nnfolder-open-marks group server) - (dolist (action actions) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) nil - "Unknown request-set-mark action: %s" what) - (dolist (mark marks) - (setq nnfolder-marks (gnus-update-alist-soft - mark - (funcall (if (eq what 'add) 'gnus-range-add - 'gnus-remove-from-range) - (cdr (assoc mark nnfolder-marks)) range) - nnfolder-marks))))) + (setq nnfolder-marks (nnheader-update-marks-actions nnfolder-marks actions)) (nnfolder-save-marks group server)) nil) === modified file 'lisp/gnus/nnheader.el' --- lisp/gnus/nnheader.el 2010-11-23 22:24:15 +0000 +++ lisp/gnus/nnheader.el 2010-11-26 02:11:40 +0000 @@ -1078,6 +1078,26 @@ (truncate nnheader-read-timeout)) 1000)))) +(defun nnheader-update-marks-actions (backend-marks actions) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (dolist (mark marks) + (setq backend-marks + (gnus-update-alist-soft + mark + (cond + ((eq what 'add) + (gnus-range-add (cdr (assoc mark backend-marks)) range) + ((eq what 'del) + (gnus-remove-from-range + (cdr (assoc mark backend-marks)) range)) + ((eq what 'set) + range))) + backend-marks))))) + backend-marks) + (when (featurep 'xemacs) (require 'nnheaderxm)) === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-26 01:27:37 +0000 +++ lisp/gnus/nnimap.el 2010-11-26 02:11:40 +0000 @@ -941,9 +941,10 @@ (setq sequence (nnimap-send-command "UID STORE %s %sFLAGS.SILENT (%s)" (nnimap-article-ranges range) - (if (eq action 'del) - "-" - "+") + (cond + ((eq action 'del) "-") + ((eq action 'add) "-") + ((eq action 'set) "")) (mapconcat #'identity flags " "))))))) ;; Wait for the last command to complete to avoid later ;; syncronisation problems with the stream. === modified file 'lisp/gnus/nnmaildir.el' --- lisp/gnus/nnmaildir.el 2010-10-11 23:29:33 +0000 +++ lisp/gnus/nnmaildir.el 2010-11-26 02:11:40 +0000 @@ -1590,7 +1590,7 @@ (nnmaildir--nlist-iterate nlist ranges (cond ((eq 'del (cadr action)) del-action) ((eq 'add (cadr action)) add-action) - (t set-action)))) + ((eq 'set (cadr action)) set-action)))) nil))) (defun nnmaildir-close-group (gname &optional server) === modified file 'lisp/gnus/nnml.el' --- lisp/gnus/nnml.el 2010-09-26 13:25:35 +0000 +++ lisp/gnus/nnml.el 2010-11-26 02:11:40 +0000 @@ -1033,19 +1033,7 @@ (nnml-possibly-change-directory group server) (unless nnml-marks-is-evil (nnml-open-marks group server) - (dolist (action actions) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) nil - "Unknown request-set-mark action: %s" what) - (dolist (mark marks) - (setq nnml-marks (gnus-update-alist-soft - mark - (funcall (if (eq what 'add) 'gnus-range-add - 'gnus-remove-from-range) - (cdr (assoc mark nnml-marks)) range) - nnml-marks))))) + (setq nnml-marks (nnheader-update-marks-actions nnml-marks actions)) (nnml-save-marks group server)) nil) === modified file 'lisp/gnus/nntp.el' --- lisp/gnus/nntp.el 2010-11-01 06:13:43 +0000 +++ lisp/gnus/nntp.el 2010-11-26 02:11:40 +0000 @@ -1118,19 +1118,7 @@ nntp-marks-file-name) (nntp-possibly-create-directory group server) (nntp-open-marks group server) - (dolist (action actions) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) nil - "Unknown request-set-mark action: %s" what) - (dolist (mark marks) - (setq nntp-marks (gnus-update-alist-soft - mark - (funcall (if (eq what 'add) 'gnus-range-add - 'gnus-remove-from-range) - (cdr (assoc mark nntp-marks)) range) - nntp-marks))))) + (setq nntp-marks (nnheader-update-marks-actions nntp-marks actions)) (nntp-save-marks group server)) nil) ------------------------------------------------------------ revno: 102520 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 01:27:37 +0000 message: nnimap.el (nnimap-find-uid-response): The UID is the last element in the list. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 01:14:40 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 01:27:37 +0000 @@ -6,6 +6,7 @@ (nnimap-request-accept-article): Use the UID returned, if any. (nnimap-request-move-article): Use the UID returned, if any. (nnimap-get-groups): Reimplement to work with folded lines. + (nnimap-find-uid-response): The UID is the last element in the list. 2010-11-25 Katsumi Yamaoka === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-26 01:14:40 +0000 +++ lisp/gnus/nnimap.el 2010-11-26 01:27:37 +0000 @@ -984,7 +984,7 @@ group message-id))))))))) (defun nnimap-find-uid-response (name list) - (let ((result (nth 2 (nnimap-find-response-element name list)))) + (let ((result (car (last (nnimap-find-response-element name list))))) (and result (string-to-number result)))) ------------------------------------------------------------ revno: 102519 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 01:14:40 +0000 message: nnimap.el: Use the UID returned when copying and accepting articles, instead of searching for the ID (on the servers that support it). nnimap.el (nnimap-get-groups): Reimplement to work with folded lines. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-26 00:45:03 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 01:14:40 +0000 @@ -2,6 +2,10 @@ * nnimap.el (nnimap-last-response-string): Remove the unfolding -- it introduces regressions in article selection. + (nnimap-find-uid-response): New function. + (nnimap-request-accept-article): Use the UID returned, if any. + (nnimap-request-move-article): Use the UID returned, if any. + (nnimap-get-groups): Reimplement to work with folded lines. 2010-11-25 Katsumi Yamaoka === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-26 00:45:03 +0000 +++ lisp/gnus/nnimap.el 2010-11-26 01:14:40 +0000 @@ -800,8 +800,9 @@ (when (car result) (nnimap-delete-article article) (cons internal-move-group - (nnimap-find-article-by-message-id - internal-move-group message-id)))) + (or (nnimap-find-uid-response "COPYUID" (cadr result)) + (nnimap-find-article-by-message-id + internal-move-group message-id))))) ;; Move the article to a different method. (let ((result (eval accept-form))) (when result @@ -978,7 +979,22 @@ (nnheader-message 7 "%s" (nnheader-get-report-string 'nnimap)) nil) (cons group - (nnimap-find-article-by-message-id group message-id)))))))) + (or (nnimap-find-uid-response "APPENDUID" (car result)) + (nnimap-find-article-by-message-id + group message-id))))))))) + +(defun nnimap-find-uid-response (name list) + (let ((result (nth 2 (nnimap-find-response-element name list)))) + (and result + (string-to-number result)))) + +(defun nnimap-find-response-element (name list) + (let (result) + (dolist (elem list) + (when (and (consp elem) + (equal name (car elem))) + (setq result elem))) + result)) (deffoo nnimap-request-replace-article (article group buffer) (let (group-art) @@ -997,15 +1013,22 @@ (replace-match "\r\n" t t))) (defun nnimap-get-groups () - (let ((result (nnimap-command "LIST \"\" \"*\"")) + (erase-buffer) + (let ((sequence (nnimap-send-command "LIST \"\" \"*\"")) groups) - (when (car result) - (dolist (line (cdr result)) - (when (and (equal (car line) "LIST") - (not (and (caadr line) - (string-match "noselect" (caadr line))))) - (push (car (last line)) groups))) - (nreverse groups)))) + (nnimap-wait-for-response sequence) + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) + (goto-char (point-min)) + (nnimap-unfold-quoted-lines) + (goto-char (point-min)) + (while (search-forward "* LIST " nil t) + (let ((flags (read (current-buffer))) + (separator (read (current-buffer))) + (group (read (current-buffer)))) + (unless (member '%NoSelect flags) + (push group groups)))) + (nreverse groups))) (deffoo nnimap-request-list (&optional server) (nnimap-possibly-change-group nil server) ------------------------------------------------------------ revno: 102518 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2010-11-26 00:45:03 +0000 message: nnimap.el (nnimap-last-response-string): Remove the unfolding -- it introduces regressions in article selection. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 23:43:16 +0000 +++ lisp/gnus/ChangeLog 2010-11-26 00:45:03 +0000 @@ -1,3 +1,8 @@ +2010-11-26 Lars Magne Ingebrigtsen + + * nnimap.el (nnimap-last-response-string): Remove the unfolding -- it + introduces regressions in article selection. + 2010-11-25 Katsumi Yamaoka * message.el (message-called-interactively-p): A temporary macro. === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-25 23:43:16 +0000 +++ lisp/gnus/nnimap.el 2010-11-26 00:45:03 +0000 @@ -1613,13 +1613,6 @@ (save-excursion (forward-line 1) (let ((end (point))) - ;; Unfold quoted {num} lines, if they exist. - (when (search-backward "}" nil t) - (save-restriction - (narrow-to-region (point-min) end) - (goto-char (point-min)) - (nnimap-unfold-quoted-lines) - (goto-char (setq end (point-max))))) (forward-line -1) (when (not (bobp)) (forward-line -1) ------------------------------------------------------------ revno: 102517 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 23:43:16 +0000 message: nnimap.el (nnimap-last-response-string): Fix last unfolding fix. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 23:20:19 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 23:43:16 +0000 @@ -7,6 +7,7 @@ * nnimap.el (nnimap-unfold-quoted-lines): Refactor out. (nnimap-last-response-string): Unfold quoted lines, if they exist. + (nnimap-last-response-string): Fix last unfolding fix. 2010-11-25 Katsumi Yamaoka === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-25 23:05:10 +0000 +++ lisp/gnus/nnimap.el 2010-11-25 23:43:16 +0000 @@ -180,7 +180,14 @@ (when (eobp) (return))) (setq article (match-string 1)) - (nnimap-unfold-quoted-lines) + ;; Unfold quoted {number} strings. + (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n" + (1+ (line-end-position)) t) + (setq size (string-to-number (match-string 1))) + (delete-region (+ (match-beginning 0) 2) (point)) + (setq string (buffer-substring (point) (+ (point) size))) + (delete-region (point) (+ (point) size)) + (insert (format "%S" string))) (setq bytes (nnimap-get-length) lines nil) (beginning-of-line) @@ -212,12 +219,13 @@ (defun nnimap-unfold-quoted-lines () ;; Unfold quoted {number} strings. - (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r\n" - (1+ (line-end-position)) t) - (setq size (string-to-number (match-string 1))) - (delete-region (+ (match-beginning 0) 2) (point)) - (setq string (delete-region (point) (+ (point) size))) - (insert (format "%S" string)))) + (let (size string) + (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t) + (setq size (string-to-number (match-string 1))) + (delete-region (1+ (match-beginning 0)) (point)) + (setq string (buffer-substring (point) (+ (point) size))) + (delete-region (point) (+ (point) size)) + (insert (format "%S" string))))) (defun nnimap-get-length () (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t) @@ -1607,11 +1615,11 @@ (let ((end (point))) ;; Unfold quoted {num} lines, if they exist. (when (search-backward "}" nil t) - (save-excursion - (save-restriction - (narrow-to-region (point-min) end) - (goto-char (point-min)) - (nnimap-unfold-quoted-lines)))) + (save-restriction + (narrow-to-region (point-min) end) + (goto-char (point-min)) + (nnimap-unfold-quoted-lines) + (goto-char (setq end (point-max))))) (forward-line -1) (when (not (bobp)) (forward-line -1) ------------------------------------------------------------ revno: 102516 committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 23:20:19 +0000 message: message.el (message-called-interactively-p): A temporary macro. message.el (message-goto-body): Use it temporarily. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 23:05:10 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 23:20:19 +0000 @@ -1,3 +1,8 @@ +2010-11-25 Katsumi Yamaoka + + * message.el (message-called-interactively-p): A temporary macro. + (message-goto-body): Use it temporarily. + 2010-11-25 Lars Magne Ingebrigtsen * nnimap.el (nnimap-unfold-quoted-lines): Refactor out. === modified file 'lisp/gnus/message.el' --- lisp/gnus/message.el 2010-11-24 22:54:47 +0000 +++ lisp/gnus/message.el 2010-11-25 23:20:19 +0000 @@ -3047,10 +3047,22 @@ (interactive) (message-position-on-field "Summary" "Subject")) +(eval-when-compile + (defmacro message-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))))) + (defun message-goto-body () "Move point to the beginning of the message body." (interactive) - (when (and (called-interactively-p 'any) + (when (and (message-called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) (goto-char (point-min)) ------------------------------------------------------------ revno: 102515 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 23:05:10 +0000 message: nnimap.el (nnimap-unfold-quoted-lines): Refactor out. nnimap.el (nnimap-last-response-string): Unfold quoted lines, if they exist. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 14:51:51 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 23:05:10 +0000 @@ -1,3 +1,8 @@ +2010-11-25 Lars Magne Ingebrigtsen + + * nnimap.el (nnimap-unfold-quoted-lines): Refactor out. + (nnimap-last-response-string): Unfold quoted lines, if they exist. + 2010-11-25 Katsumi Yamaoka * shr.el (shr-insert): Fix the way to fold lines. === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-24 22:54:47 +0000 +++ lisp/gnus/nnimap.el 2010-11-25 23:05:10 +0000 @@ -180,13 +180,7 @@ (when (eobp) (return))) (setq article (match-string 1)) - ;; Unfold quoted {number} strings. - (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r\n" - (1+ (line-end-position)) t) - (setq size (string-to-number (match-string 1))) - (delete-region (+ (match-beginning 0) 2) (point)) - (setq string (delete-region (point) (+ (point) size))) - (insert (format "%S" string))) + (nnimap-unfold-quoted-lines) (setq bytes (nnimap-get-length) lines nil) (beginning-of-line) @@ -216,6 +210,15 @@ (insert ".") (forward-line 1))))) +(defun nnimap-unfold-quoted-lines () + ;; Unfold quoted {number} strings. + (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r\n" + (1+ (line-end-position)) t) + (setq size (string-to-number (match-string 1))) + (delete-region (+ (match-beginning 0) 2) (point)) + (setq string (delete-region (point) (+ (point) size))) + (insert (format "%S" string)))) + (defun nnimap-get-length () (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t) (string-to-number (match-string 1)))) @@ -1602,6 +1605,13 @@ (save-excursion (forward-line 1) (let ((end (point))) + ;; Unfold quoted {num} lines, if they exist. + (when (search-backward "}" nil t) + (save-excursion + (save-restriction + (narrow-to-region (point-min) end) + (goto-char (point-min)) + (nnimap-unfold-quoted-lines)))) (forward-line -1) (when (not (bobp)) (forward-line -1) ------------------------------------------------------------ revno: 102514 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2010-11-25 16:59:30 -0500 message: * diff.el (diff): Fix it for good, hopefully, this time. diff: === modified file 'lisp/vc/diff.el' --- lisp/vc/diff.el 2010-11-25 04:43:56 +0000 +++ lisp/vc/diff.el 2010-11-25 21:59:30 +0000 @@ -84,14 +84,13 @@ interactively for diff switches. Otherwise, the switches specified in `diff-switches' are passed to the diff command." (interactive - (let* ((newf (buffer-file-name)) - (oldf (file-newest-backup newf))) - (setq newf (if (and newf (file-exists-p newf)) + (let* ((newf (if (and buffer-file-name (file-exists-p buffer-file-name)) (read-file-name (concat "Diff new file (default " - (file-name-nondirectory newf) "): ") - nil newf t) + (file-name-nondirectory buffer-file-name) "): ") + nil buffer-file-name t) (read-file-name "Diff new file: " nil nil t))) + (oldf (file-newest-backup newf))) (setq oldf (if (and oldf (file-exists-p oldf)) (read-file-name (concat "Diff original file (default " ------------------------------------------------------------ revno: 102513 committer: Eli Zaretskii branch nick: trunk timestamp: Thu 2010-11-25 22:28:14 +0200 message: Fixing bug #7474 also fixes #7481. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2010-11-25 18:38:09 +0000 +++ src/ChangeLog 2010-11-25 20:28:14 +0000 @@ -2,7 +2,7 @@ * xdisp.c (set_cursor_from_row): Don't forget to consider the `cursor' property of the first character in overlay strings. - (Bug#7474) + (Bug#7474) (Bug#7481) 2010-11-24 Jan Djärv ------------------------------------------------------------ revno: 102512 committer: Eli Zaretskii branch nick: trunk timestamp: Thu 2010-11-25 20:38:09 +0200 message: Fix bug #7474 with cursor positioning in overlay strings. xdisp.c (set_cursor_from_row): Don't forget to consider the `cursor' property of the first character in overlay strings. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2010-11-24 14:52:14 +0000 +++ src/ChangeLog 2010-11-25 18:38:09 +0000 @@ -1,3 +1,9 @@ +2010-11-25 Eli Zaretskii + + * xdisp.c (set_cursor_from_row): Don't forget to consider the + `cursor' property of the first character in overlay strings. + (Bug#7474) + 2010-11-24 Jan Djärv * nsterm.m (NSLeftControlKeyMask, NSLeftCommandKeyMask) === modified file 'src/xdisp.c' --- src/xdisp.c 2010-11-19 16:34:22 +0000 +++ src/xdisp.c 2010-11-25 18:38:09 +0000 @@ -12943,7 +12943,7 @@ if (tem) cursor = glyph; - for (glyph += incr; + for ( ; (row->reversed_p ? glyph > stop : glyph < stop) && EQ (glyph->object, str); glyph += incr) ------------------------------------------------------------ revno: 102511 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 14:51:51 +0000 message: shr.el (shr-insert): Fix the way to fold lines. shr-color.el (shr-color->hexadecimal): Use color-rgb->hex color.el: Rename from color-lab.el (color-rgb->hex): Add. (color-complement): Add. (color-complement-hex): Add. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 11:14:14 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 14:51:51 +0000 @@ -1,5 +1,16 @@ +2010-11-25 Katsumi Yamaoka + + * shr.el (shr-insert): Fix the way to fold lines. + 2010-11-25 Julien Danjou + * shr-color.el (shr-color->hexadecimal): Use color-rgb->hex + + * color.el: Rename from color-lab.el + (color-rgb->hex): Add. + (color-complement): Add. + (color-complement-hex): Add. + * gnus-sum.el (gnus-summary-widget-forward): Add, and bind to [tab]. 2010-11-25 Lars Magne Ingebrigtsen === renamed file 'lisp/gnus/color-lab.el' => 'lisp/gnus/color.el' --- lisp/gnus/color-lab.el 2010-11-24 12:56:50 +0000 +++ lisp/gnus/color.el 2010-11-25 14:51:51 +0000 @@ -1,4 +1,4 @@ -;;; color-lab.el --- Color manipulation laboratory routines -*- coding: utf-8; -*- +;;; color.el --- Color manipulation laboratory routines -*- coding: utf-8; -*- ;; Copyright (C) 2010 Free Software Foundation, Inc. @@ -34,7 +34,24 @@ (unless (boundp 'float-pi) (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...)."))) -(defun rgb->hsv (red green blue) +(defun color-rgb->hex (red green blue) + "Return hexadecimal notation for RED GREEN BLUE color. +RED GREEN BLUE must be values between [0,1]." + (format "#%02x%02x%02x" + (* red 255) (* green 255) (* blue 255))) + +(defun color-complement (color) + "Return the color that is the complement of COLOR." + (let ((color (color-rgb->normalize color))) + (list (- 1.0 (car color)) + (- 1.0 (cadr color)) + (- 1.0 (caddr color))))) + +(defun color-complement-hex (color) + "Return the color that is the complement of COLOR, in hexadecimal format." + (apply 'color-rgb->hex (color-complement color))) + +(defun color-rgb->hsv (red green blue) "Convert RED GREEN BLUE values to HSV representation. Hue is in radian. Saturation and values are between 0 and 1." (let* ((r (float red)) @@ -61,12 +78,12 @@ (- 1 (/ min max))) (/ max 255.0)))) -(defun rgb->hsl (red green blue) +(defun color-rgb->hsl (red green blue) "Convert RED GREEN BLUE colors to their HSL representation. -RED, GREEN and BLUE must be between 0 and 255." - (let* ((r (/ red 255.0)) - (g (/ green 255.0)) - (b (/ blue 255.0)) +RED, GREEN and BLUE must be between [0,1]." + (let* ((r red) + (g green) + (b blue) (max (max r g b)) (min (min r g b)) (delta (- max min)) @@ -89,9 +106,9 @@ (/ delta (+ max min)))) l))) -(defun rgb->xyz (red green blue) +(defun color-rgb->xyz (red green blue) "Converts RED GREEN BLUE colors to CIE XYZ representation. -RED, BLUE and GREEN must be between 0 and 1." +RED, BLUE and GREEN must be between [0,1]." (let ((r (if (<= red 0.04045) (/ red 12.95) (expt (/ (+ red 0.055) 1.055) 2.4))) @@ -105,8 +122,8 @@ (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b)) (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b))))) -(defun xyz->rgb (X Y Z) - "Converts CIE XYZ colors to RGB." +(defun color-xyz->rgb (X Y Z) + "Converts CIE X Y Z colors to RGB." (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z))) (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z))) (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z)))) @@ -120,68 +137,68 @@ (* 12.92 b) (- (* 1.055 (expt b (/ 1 2.4))) 0.055))))) -(defconst color-lab-d65-xyz '(0.950455 1.0 1.088753) +(defconst color-d65-xyz '(0.950455 1.0 1.088753) "D65 white point in CIE XYZ.") -(defconst color-lab-ε (/ 216 24389.0)) -(defconst color-lab-κ (/ 24389 27.0)) +(defconst color-cie-ε (/ 216 24389.0)) +(defconst color-cie-κ (/ 24389 27.0)) -(defun xyz->lab (X Y Z &optional white-point) +(defun color-xyz->lab (X Y Z &optional white-point) "Converts CIE XYZ to CIE L*a*b*. WHITE-POINT can be specified as (X Y Z) white point to use. If -none is set, `color-lab-d65-xyz' is used." - (destructuring-bind (Xr Yr Zr) (or white-point color-lab-d65-xyz) +none is set, `color-d65-xyz' is used." + (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz) (let* ((xr (/ X Xr)) (yr (/ Y Yr)) (zr (/ Z Zr)) - (fx (if (> xr color-lab-ε) + (fx (if (> xr color-cie-ε) (expt xr (/ 1 3.0)) - (/ (+ (* color-lab-κ xr) 16) 116.0))) - (fy (if (> yr color-lab-ε) + (/ (+ (* color-cie-κ xr) 16) 116.0))) + (fy (if (> yr color-cie-ε) (expt yr (/ 1 3.0)) - (/ (+ (* color-lab-κ yr) 16) 116.0))) - (fz (if (> zr color-lab-ε) + (/ (+ (* color-cie-κ yr) 16) 116.0))) + (fz (if (> zr color-cie-ε) (expt zr (/ 1 3.0)) - (/ (+ (* color-lab-κ zr) 16) 116.0)))) + (/ (+ (* color-cie-κ zr) 16) 116.0)))) (list (- (* 116 fy) 16) ; L (* 500 (- fx fy)) ; a (* 200 (- fy fz)))))) ; b -(defun lab->xyz (L a b &optional white-point) +(defun color-lab->xyz (L a b &optional white-point) "Converts CIE L*a*b* to CIE XYZ. WHITE-POINT can be specified as (X Y Z) white point to use. If -none is set, `color-lab-d65-xyz' is used." - (destructuring-bind (Xr Yr Zr) (or white-point color-lab-d65-xyz) +none is set, `color-d65-xyz' is used." + (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz) (let* ((fy (/ (+ L 16) 116.0)) (fz (- fy (/ b 200.0))) (fx (+ (/ a 500.0) fy)) - (xr (if (> (expt fx 3.0) color-lab-ε) + (xr (if (> (expt fx 3.0) color-cie-ε) (expt fx 3.0) - (/ (- (* fx 116) 16) color-lab-κ))) - (yr (if (> L (* color-lab-κ color-lab-ε)) + (/ (- (* fx 116) 16) color-cie-κ))) + (yr (if (> L (* color-cie-κ color-cie-ε)) (expt (/ (+ L 16) 116.0) 3.0) - (/ L color-lab-κ))) - (zr (if (> (expt fz 3) color-lab-ε) + (/ L color-cie-κ))) + (zr (if (> (expt fz 3) color-cie-ε) (expt fz 3.0) - (/ (- (* 116 fz) 16) color-lab-κ)))) + (/ (- (* 116 fz) 16) color-cie-κ)))) (list (* xr Xr) ; X (* yr Yr) ; Y (* zr Zr))))) ; Z -(defun rgb->lab (red green blue) +(defun color-rgb->lab (red green blue) "Converts RGB to CIE L*a*b*." - (apply 'xyz->lab (rgb->xyz red green blue))) + (apply 'color-xyz->lab (color-rgb->xyz red green blue))) -(defun rgb->normalize (color) +(defun color-rgb->normalize (color) "Normalize a RGB color to values between [0,1]." (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color))) -(defun lab->rgb (L a b) +(defun color-lab->rgb (L a b) "Converts CIE L*a*b* to RGB." - (apply 'xyz->rgb (lab->xyz L a b))) + (apply 'color-xyz->rgb (color-lab->xyz L a b))) -(defun color-lab-ciede2000 (color1 color2 &optional kL kC kH) +(defun color-cie-de2000 (color1 color2 &optional kL kC kH) "Computes the CIEDE2000 color distance between COLOR1 and COLOR2. Colors must be in CIE L*a*b* format." (destructuring-bind (L₁ a₁ b₁) color1 @@ -246,6 +263,6 @@ (expt (/ ΔH′ (* Sh kH)) 2.0) (* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH))))))))) -(provide 'color-lab) +(provide 'color) -;;; color-lab.el ends here +;;; color.el ends here === modified file 'lisp/gnus/shr-color.el' --- lisp/gnus/shr-color.el 2010-11-25 07:46:51 +0000 +++ lisp/gnus/shr-color.el 2010-11-25 14:51:51 +0000 @@ -26,7 +26,7 @@ ;;; Code: -(require 'color-lab) +(require 'color) (defgroup shr-color nil "Simple HTML Renderer colors" @@ -258,7 +258,7 @@ (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) (destructuring-bind (r g b) (shr-color-hsl-to-rgb-fractions h s l) - (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255))))) + (color-rgb->hex r g b)))) ;; Color names ((cdr (assoc-string color shr-color-html-colors-alist t))) ;; Unrecognized color :( @@ -324,15 +324,15 @@ new background color will not be computed. Only the foreground color will be adapted to be visible on BG." ;; Convert fg and bg to CIE Lab - (let ((fg-norm (rgb->normalize fg)) - (bg-norm (rgb->normalize bg))) + (let ((fg-norm (color-rgb->normalize fg)) + (bg-norm (color-rgb->normalize bg))) (if (or (null fg-norm) (null bg-norm)) (list bg fg) - (let* ((fg-lab (apply 'rgb->lab fg-norm)) - (bg-lab (apply 'rgb->lab bg-norm)) + (let* ((fg-lab (apply 'color-rgb->lab fg-norm)) + (bg-lab (apply 'color-rgb->lab bg-norm)) ;; Compute color distance using CIE DE 2000 - (fg-bg-distance (color-lab-ciede2000 fg-lab bg-lab)) + (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) ;; Compute luminance distance (substract L component) (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) (if (and (>= fg-bg-distance shr-color-visible-distance-min) @@ -350,10 +350,10 @@ bg (apply 'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'lab->rgb bg-lab)))) + (apply 'color-lab->rgb bg-lab)))) (apply 'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'lab->rgb fg-lab)))))))))) + (apply 'color-lab->rgb fg-lab)))))))))) (provide 'shr-color) === modified file 'lisp/gnus/shr.el' --- lisp/gnus/shr.el 2010-11-25 01:13:37 +0000 +++ lisp/gnus/shr.el 2010-11-25 14:51:51 +0000 @@ -254,7 +254,7 @@ (while (and (> (current-column) shr-width) (progn (setq found (shr-find-fill-point)) - (not (eolp)))) + (not (or (bolp) (eolp))))) (when (eq (preceding-char) ? ) (delete-char -1)) (insert "\n") ------------------------------------------------------------ revno: 102510 author: Julien Danjou committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 11:14:14 +0000 message: gnus-sum.el (gnus-summary-widget-forward): Add, and bind to [tab]. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 07:46:51 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 11:14:14 +0000 @@ -1,3 +1,7 @@ +2010-11-25 Julien Danjou + + * gnus-sum.el (gnus-summary-widget-forward): Add, and bind to [tab]. + 2010-11-25 Lars Magne Ingebrigtsen * shr-color.el (shr-color-visible): Don't bug out if the colour names === modified file 'lisp/gnus/gnus-sum.el' --- lisp/gnus/gnus-sum.el 2010-11-24 22:54:47 +0000 +++ lisp/gnus/gnus-sum.el 2010-11-25 11:14:14 +0000 @@ -1903,6 +1903,7 @@ "a" gnus-summary-post-news "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article + [tab] gnus-summary-widget-forward "t" gnus-summary-toggle-header "g" gnus-summary-show-article "l" gnus-summary-goto-last-article @@ -2066,6 +2067,7 @@ "W" gnus-warp-to-article "g" gnus-summary-show-article "s" gnus-summary-isearch-article + [tab] gnus-summary-widget-forward "P" gnus-summary-print-article "S" gnus-sticky-article "M" gnus-mailing-list-insinuate @@ -9082,6 +9084,15 @@ (t (error "Couldn't select virtual nndoc group"))))) +(defun gnus-summary-widget-forward (arg) + "Move point to the next field or button in the article. +With optional ARG, move across that many fields." + (interactive "p") + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (select-window (gnus-get-buffer-window gnus-article-buffer)) + (widget-forward arg)) + (defun gnus-summary-isearch-article (&optional regexp-p) "Do incremental search forward on the current article. If REGEXP-P (the prefix) is non-nil, do regexp isearch." ------------------------------------------------------------ revno: 102509 author: Lars Magne Ingebrigtsen committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 07:46:51 +0000 message: shr-color.el (shr-color-visible): Don't bug out if the colour names don't exist. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 05:09:25 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 07:46:51 +0000 @@ -1,3 +1,8 @@ +2010-11-25 Lars Magne Ingebrigtsen + + * shr-color.el (shr-color-visible): Don't bug out if the colour names + don't exist. + 2010-11-25 Katsumi Yamaoka * mml.el (mml-preview): Make sure to bind gnus-displaying-mime to nil, === modified file 'lisp/gnus/shr-color.el' --- lisp/gnus/shr-color.el 2010-11-24 22:54:47 +0000 +++ lisp/gnus/shr-color.el 2010-11-25 07:46:51 +0000 @@ -324,29 +324,36 @@ new background color will not be computed. Only the foreground color will be adapted to be visible on BG." ;; Convert fg and bg to CIE Lab - (let* ((fg-lab (apply 'rgb->lab (rgb->normalize fg))) - (bg-lab (apply 'rgb->lab (rgb->normalize bg))) - ;; Compute color distance using CIE DE 2000 - (fg-bg-distance (color-lab-ciede2000 fg-lab bg-lab)) - ;; Compute luminance distance (substract L component) - (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) - (if (and (>= fg-bg-distance shr-color-visible-distance-min) - (>= luminance-distance shr-color-visible-luminance-min)) - (list bg fg) - ;; Not visible, try to change luminance to make them visible - (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 - shr-color-visible-luminance-min - fixed-background))) - (unless fixed-background - (setcar bg-lab (car Ls))) - (setcar fg-lab (cadr Ls)) - (list - (if fixed-background - bg - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab)))) - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb fg-lab)))))))) + (let ((fg-norm (rgb->normalize fg)) + (bg-norm (rgb->normalize bg))) + (if (or (null fg-norm) + (null bg-norm)) + (list bg fg) + (let* ((fg-lab (apply 'rgb->lab fg-norm)) + (bg-lab (apply 'rgb->lab bg-norm)) + ;; Compute color distance using CIE DE 2000 + (fg-bg-distance (color-lab-ciede2000 fg-lab bg-lab)) + ;; Compute luminance distance (substract L component) + (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) + (if (and (>= fg-bg-distance shr-color-visible-distance-min) + (>= luminance-distance shr-color-visible-luminance-min)) + (list bg fg) + ;; Not visible, try to change luminance to make them visible + (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 + shr-color-visible-luminance-min + fixed-background))) + (unless fixed-background + (setcar bg-lab (car Ls))) + (setcar fg-lab (cadr Ls)) + (list + (if fixed-background + bg + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) + (apply 'lab->rgb bg-lab)))) + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) + (apply 'lab->rgb fg-lab)))))))))) (provide 'shr-color) ------------------------------------------------------------ revno: 102508 committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 05:09:25 +0000 message: mml.el (mml-preview): Make sure to bind gnus-displaying-mime to nil, assuming that article displaying or another mml-preview may be interrupted for an error or for the like. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-25 01:13:37 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 05:09:25 +0000 @@ -1,5 +1,9 @@ 2010-11-25 Katsumi Yamaoka + * mml.el (mml-preview): Make sure to bind gnus-displaying-mime to nil, + assuming that article displaying or another mml-preview may be + interrupted for an error or for the like. + * shr.el (shr-get-background): Fix argument name. 2010-11-24 Lars Magne Ingebrigtsen === modified file 'lisp/gnus/mml.el' --- lisp/gnus/mml.el 2010-10-22 04:30:27 +0000 +++ lisp/gnus/mml.el 2010-11-25 05:09:25 +0000 @@ -1509,7 +1509,8 @@ (mm-disable-multibyte) (insert s))) (let ((gnus-newsgroup-charset (car message-posting-charset)) - gnus-article-prepare-hook gnus-original-article-buffer) + gnus-article-prepare-hook gnus-original-article-buffer + gnus-displaying-mime) (run-hooks 'gnus-article-decode-hook) (let ((gnus-newsgroup-name "dummy") (gnus-newsrc-hashtb (or gnus-newsrc-hashtb ------------------------------------------------------------ revno: 102507 committer: Stefan Monnier branch nick: trunk timestamp: Wed 2010-11-24 23:43:56 -0500 message: * lisp/vc/diff.el (diff): Fix last change. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-11-24 16:39:51 +0000 +++ lisp/ChangeLog 2010-11-25 04:43:56 +0000 @@ -1,3 +1,7 @@ +2010-11-25 Stefan Monnier + + * vc/diff.el (diff): Fix last change. + 2010-11-24 Stefan Monnier * emacs-lisp/pcase.el: Improve pcase-let. Use "pcase--" prefix. === modified file 'lisp/vc/diff.el' --- lisp/vc/diff.el 2010-11-22 19:22:03 +0000 +++ lisp/vc/diff.el 2010-11-25 04:43:56 +0000 @@ -84,8 +84,8 @@ interactively for diff switches. Otherwise, the switches specified in `diff-switches' are passed to the diff command." (interactive - (let ((newf (buffer-file-name)) - (oldf (file-newest-backup newf))) + (let* ((newf (buffer-file-name)) + (oldf (file-newest-backup newf))) (setq newf (if (and newf (file-exists-p newf)) (read-file-name (concat "Diff new file (default " ------------------------------------------------------------ revno: 102506 committer: Katsumi Yamaoka branch nick: trunk timestamp: Thu 2010-11-25 01:13:37 +0000 message: shr.el (shr-get-background): Fix argument name. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-24 22:54:47 +0000 +++ lisp/gnus/ChangeLog 2010-11-25 01:13:37 +0000 @@ -1,3 +1,7 @@ +2010-11-25 Katsumi Yamaoka + + * shr.el (shr-get-background): Fix argument name. + 2010-11-24 Lars Magne Ingebrigtsen * gnus-cache.el (gnus-summary-insert-cached-articles): Use it. === modified file 'lisp/gnus/shr.el' --- lisp/gnus/shr.el 2010-11-24 22:54:47 +0000 +++ lisp/gnus/shr.el 2010-11-25 01:13:37 +0000 @@ -522,7 +522,7 @@ (defun shr-get-background (pos) "Return background color at POS." - (dolist (overlay (overlays-in start (1+ start))) + (dolist (overlay (overlays-in pos (1+ pos))) (let ((background (plist-get (overlay-get overlay 'face) :background))) (when background ------------------------------------------------------------ revno: 102505 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Wed 2010-11-24 22:54:47 +0000 message: Merge changes made in Gnus trunk. shr-color.el (shr-color-visible): Really return original background if fixed. shr.el (shr-insert-color-overlay): Replace deprecated syntax. shr.el (shr-tag-body, shr-descend): Add background support. shr.el (shr-tag-title): Add. gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes this function to return incorrect results. shr.el (shr-parse-style): Drop !important from styles. message.el (message-goto-body): Remove the <#secure special-casing, which is too special. mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes something or other in Emacs 23, and is backwards compatible. message.el (message-goto-body): Use called-interactively-p. message.el (message-in-body-p): message-goto-body returns point. nnimap.el (nnimap-request-move-article): It's no longer necessary to clear marks before moving, since they're synced from the Gnus side first. gnus-sum.el (gnus-summary-push-marks-to-backend): New function. gnus-sum.el (gnus-summary-move-article): Copy over all marks before moving, so that IMAP doesn't think a new article has arrived. message.el (message-goto-body): called-interactively-p needs a parameter, so use `any'. gnus-cache.el (gnus-summary-insert-cached-articles): Use it. gnus-sum.el (gnus-summary-include-articles): New function. shr.el (shr-tag-table, shr-render-td): Add bgcolor support. shr-color.el (shr-color-visible): Fix docstring. shr.el (shr-insert-background-overlay): Fix typo. shr.el (shr-render-td): Copy the background before rendering. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-24 12:56:50 +0000 +++ lisp/gnus/ChangeLog 2010-11-24 22:54:47 +0000 @@ -1,5 +1,64 @@ 2010-11-24 Lars Magne Ingebrigtsen + * gnus-cache.el (gnus-summary-insert-cached-articles): Use it. + + * gnus-sum.el (gnus-summary-include-articles): New function. + + * message.el (message-goto-body): called-interactively-p needs a + parameter, so use `any'. + + * nnimap.el (nnimap-request-move-article): It's no longer necessary to + clear marks before moving, since they're synced from the Gnus side + first. + + * gnus-sum.el (gnus-summary-push-marks-to-backend): New function. + (gnus-summary-move-article): Copy over all marks before moving, so that + IMAP doesn't think a new article has arrived. + +2010-11-24 Julien Danjou + + * shr.el (shr-insert-background-overlay): Fix typo. + (shr-render-td): Copy the background before rendering. + + * shr-color.el (shr-color-visible): Fix docstring. + + * shr.el (shr-tag-table): Add bgcolor support. + (shr-render-td): Add bgcolor support. + (shr-get-background): Add. + (shr-insert-foreground-overlay): Use shr-get-background. + + * message.el (message-goto-body): Use called-interactively-p. + (message-in-body-p): message-goto-body returns point. + +2010-11-24 Lars Magne Ingebrigtsen + + * mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes + Fixes something or other in Emacs 23, and is backwards compatible. + + * message.el (message-goto-body): Remove the <#secure special-casing, + which is too special. + + * shr.el (shr-parse-style): Drop !important from styles. + +2010-11-24 Daniel Schoepe (tiny change) + + * gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes + this function to return incorrect results when calling it with an + explicit article argument different from + (gnus-summary-article-number). + +2010-11-24 Julien Danjou + + * shr.el (shr-insert-color-overlay): Replace deprecated syntax. + (shr-tag-body): Add background support. + (shr-descend): Add background support. + (shr-tag-title): Add. + + * shr-color.el (shr-color-visible): Really return original background + if fixed. + +2010-11-24 Lars Magne Ingebrigtsen + * shr.el (shr-color-check): Protect against non-existant colour names. 2010-11-24 Julien Danjou @@ -46,7 +105,8 @@ * shr.el (shr-parse-style): Replace \n with space in style parsing. - * shr-color.el (shr-color-hsl-to-rgb-fractions): Use shr-color-hue-to-rgb. + * shr-color.el (shr-color-hsl-to-rgb-fractions): Use + shr-color-hue-to-rgb. (shr-color->hexadecimal): Call shr-color-hsl-to-rgb-fractions. 2010-11-23 Lars Magne Ingebrigtsen === modified file 'lisp/gnus/gnus-cache.el' --- lisp/gnus/gnus-cache.el 2010-10-11 23:29:33 +0000 +++ lisp/gnus/gnus-cache.el 2010-11-24 22:54:47 +0000 @@ -383,9 +383,14 @@ "Insert all the articles cached for this group into the current buffer." (interactive) (let ((gnus-verbose (max 6 gnus-verbose))) - (if (not gnus-newsgroup-cached) - (gnus-message 3 "No cached articles for this group") - (gnus-summary-goto-subjects gnus-newsgroup-cached)))) + (cond + ((not gnus-newsgroup-cached) + (gnus-message 3 "No cached articles for this group")) + ;; This is faster if there are few articles to insert. + ((< (length gnus-newsgroup-cached) 20) + (gnus-summary-goto-subjects gnus-newsgroup-cached)) + (t + (gnus-summary-include-articles gnus-newsgroup-cached))))) (defun gnus-summary-limit-include-cached () "Limit the summary buffer to articles that are cached." === modified file 'lisp/gnus/gnus-sum.el' --- lisp/gnus/gnus-sum.el 2010-11-15 23:45:55 +0000 +++ lisp/gnus/gnus-sum.el 2010-11-24 22:54:47 +0000 @@ -8500,6 +8500,18 @@ (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit)) (gnus-summary-position-point))) +(defun gnus-summary-include-articles (articles) + "Fetch the headers for ARTICLES and then display the summary lines." + (let ((gnus-inhibit-demon t) + (gnus-agent nil) + (gnus-read-all-available-headers t)) + (setq gnus-newsgroup-headers + (gnus-merge + 'list gnus-newsgroup-headers + (gnus-fetch-headers articles nil t) + 'gnus-article-sort-by-number)) + (gnus-summary-limit (append articles gnus-newsgroup-limit)))) + (defun gnus-summary-limit-exclude-dormant () "Hide all dormant articles." (interactive) @@ -9705,6 +9717,9 @@ articles) (while articles (setq article (pop articles)) + ;; Set any marks that may have changed in the summary buffer. + (when gnus-preserve-marks + (gnus-summary-push-marks-to-backend article)) (let ((gnus-newsgroup-original-name gnus-newsgroup-name) (gnus-article-original-subject (mail-header-subject @@ -9921,6 +9936,25 @@ (gnus-summary-position-point) (gnus-set-mode-line 'summary))) +(defun gnus-summary-push-marks-to-backend (article) + (let ((add nil) + (delete nil) + (marks gnus-article-mark-lists)) + (if (memq article gnus-newsgroup-unreads) + (push 'read add) + (push 'read delete)) + (while marks + (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (if (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + (push (cdar marks) add) + (push (cdar marks) delete))) + (pop marks)) + (gnus-request-set-mark gnus-newsgroup-name + `(((,article) add ,add) + ((,article) del ,delete))))) + (defun gnus-summary-copy-article (&optional n to-newsgroup select-method) "Copy the current article to some other group. If TO-NEWSGROUP is string, do not prompt for a newsgroup to copy to. @@ -11232,6 +11266,7 @@ (mail-header-subject (gnus-data-header (car data))))) (t nil))) (end-point (save-excursion + (goto-char (gnus-data-pos (car data))) (if (gnus-summary-go-to-next-thread) (point) (point-max)))) articles) === modified file 'lisp/gnus/message.el' --- lisp/gnus/message.el 2010-11-10 23:16:01 +0000 +++ lisp/gnus/message.el 2010-11-24 22:54:47 +0000 @@ -3047,10 +3047,10 @@ (interactive) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body (&optional interactivep) +(defun message-goto-body () "Move point to the beginning of the message body." - (interactive (list t)) - (when (and interactivep + (interactive) + (when (and (called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) (goto-char (point-min)) @@ -3059,7 +3059,7 @@ (defun message-in-body-p () "Return t if point is in the message body." - (let ((body (save-excursion (message-goto-body) (point)))) + (let ((body (save-excursion (message-goto-body)))) (>= (point) body))) (defun message-goto-eoh () === modified file 'lisp/gnus/mm-util.el' --- lisp/gnus/mm-util.el 2010-11-01 06:39:01 +0000 +++ lisp/gnus/mm-util.el 2010-11-24 22:54:47 +0000 @@ -903,7 +903,7 @@ "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is non-nil. This is a no-op in XEmacs." - (set-buffer-multibyte t))) + (set-buffer-multibyte 'to))) (if (featurep 'xemacs) (defalias 'mm-disable-multibyte 'ignore) === modified file 'lisp/gnus/nnimap.el' --- lisp/gnus/nnimap.el 2010-11-21 22:46:16 +0000 +++ lisp/gnus/nnimap.el 2010-11-24 22:54:47 +0000 @@ -783,9 +783,6 @@ (if internal-move-group (let ((result (with-current-buffer (nnimap-buffer) - ;; Clear all flags before moving. - (nnimap-send-command "UID STORE %d FLAGS.SILENT ()" - article) (nnimap-command "UID COPY %d %S" article (utf7-encode internal-move-group t))))) === modified file 'lisp/gnus/shr-color.el' --- lisp/gnus/shr-color.el 2010-11-24 11:32:22 +0000 +++ lisp/gnus/shr-color.el 2010-11-24 22:54:47 +0000 @@ -318,8 +318,8 @@ (defun shr-color-visible (bg fg &optional fixed-background) "Check that BG and FG colors are visible if they are drawn on each other. -Return t if they are. If they are too similar, two new colors are -returned instead. +Return (bg fg) if they are. If they are too similar, two new +colors are returned instead. If FIXED-BACKGROUND is set, and if the color are not visible, a new background color will not be computed. Only the foreground color will be adapted to be visible on BG." @@ -337,11 +337,14 @@ (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 shr-color-visible-luminance-min fixed-background))) - (setcar bg-lab (car Ls)) + (unless fixed-background + (setcar bg-lab (car Ls))) (setcar fg-lab (cadr Ls)) (list - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab))) + (if fixed-background + bg + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab)))) (apply 'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb fg-lab)))))))) === modified file 'lisp/gnus/shr.el' --- lisp/gnus/shr.el 2010-11-24 11:32:22 +0000 +++ lisp/gnus/shr.el 2010-11-24 22:54:47 +0000 @@ -201,7 +201,10 @@ (funcall function (cdr dom)) (shr-generic (cdr dom))) (when (consp style) - (shr-insert-color-overlay (cdr (assq 'color style)) start (point))))) + (shr-insert-background-overlay (cdr (assq 'background-color style)) + start) + (shr-insert-foreground-overlay (cdr (assq 'color style)) + start (point))))) (defun shr-generic (cont) (dolist (sub cont) @@ -494,23 +497,65 @@ (autoload 'shr-color-visible "shr-color") (autoload 'shr-color->hexadecimal "shr-color") -(defun shr-color-check (fg &optional bg) - "Check that FG is visible on BG." - (let ((hex-color (shr-color->hexadecimal fg))) - (when hex-color - (shr-color-visible (or (shr-color->hexadecimal bg) - (frame-parameter nil 'background-color)) - hex-color (not bg))))) - -(defun shr-insert-color-overlay (color start end) - (when color - (let ((new-color (cadr (shr-color-check color)))) - (when new-color - (overlay-put (make-overlay start end) 'face - (cons 'foreground-color new-color)))))) + +(defun shr-color-check (fg bg) + "Check that FG is visible on BG. +Returns (fg bg) with corrected values. +Returns nil if the colors that would be used are the default +ones, in case fg and bg are nil." + (when (or fg bg) + (let ((fixed (cond ((null fg) 'fg) + ((null bg) 'bg)))) + ;; Convert colors to hexadecimal, or set them to default. + (let ((fg (or (shr-color->hexadecimal fg) + (frame-parameter nil 'foreground-color))) + (bg (or (shr-color->hexadecimal bg) + (frame-parameter nil 'background-color)))) + (cond ((eq fixed 'bg) + ;; Only return the new fg + (list nil (cadr (shr-color-visible bg fg t)))) + ((eq fixed 'fg) + ;; Invert args and results and return only the new bg + (list (cadr (shr-color-visible fg bg t)) nil)) + (t + (shr-color-visible bg fg))))))) + +(defun shr-get-background (pos) + "Return background color at POS." + (dolist (overlay (overlays-in start (1+ start))) + (let ((background (plist-get (overlay-get overlay 'face) + :background))) + (when background + (return background))))) + +(defun shr-insert-foreground-overlay (fg start end) + (when fg + (let ((bg (shr-get-background start))) + (let ((new-colors (shr-color-check fg bg))) + (when new-colors + (overlay-put (make-overlay start end) 'face + (list :foreground (cadr new-colors)))))))) + +(defun shr-insert-background-overlay (bg start) + "Insert an overlay with background color BG at START. +The overlay has rear-advance set to t, so it will be used when +text will be inserted at start." + (when bg + (let ((new-colors (shr-color-check nil bg))) + (when new-colors + (overlay-put (make-overlay start start nil nil t) 'face + (list :background (car new-colors))))))) ;;; Tag-specific rendering rules. +(defun shr-tag-body (cont) + (let ((start (point)) + (fgcolor (cdr (assq :fgcolor cont))) + (bgcolor (cdr (assq :bgcolor cont)))) + (shr-insert-background-overlay bgcolor start) + (shr-generic cont) + (shr-insert-foreground-overlay fgcolor start (point)))) + (defun shr-tag-p (cont) (shr-ensure-paragraph) (shr-indent) @@ -554,6 +599,8 @@ (cadr elem)) (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem))) (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem)))) + (when (string-match " *!important\\'" value) + (setq value (substring value 0 (match-beginning 0)))) (push (cons (intern name obarray) value) plist))))) @@ -703,11 +750,14 @@ (shr-ensure-newline) (insert (make-string shr-width shr-hr-line) "\n")) +(defun shr-tag-title (cont) + (shr-heading cont 'bold 'underline)) + (defun shr-tag-font (cont) (let ((start (point)) (color (cdr (assq :color cont)))) (shr-generic cont) - (shr-insert-color-overlay color start (point)))) + (shr-insert-foreground-overlay color start (point)))) ;;; Table rendering algorithm. @@ -755,9 +805,11 @@ (header (cdr (assq 'thead cont))) (body (or (cdr (assq 'tbody cont)) cont)) (footer (cdr (assq 'tfoot cont))) + (bgcolor (cdr (assq :bgcolor cont))) (nheader (if header (shr-max-columns header))) (nbody (if body (shr-max-columns body))) (nfooter (if footer (shr-max-columns footer)))) + (shr-insert-background-overlay bgcolor (point)) (shr-tag-table-1 (nconc (if caption `((tr (td ,@caption)))) @@ -900,44 +952,48 @@ (nreverse trs))) (defun shr-render-td (cont width fill) - (with-temp-buffer - (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) - (if cache - (insert cache) - (let ((shr-width width) - (shr-indentation 0)) - (shr-generic cont)) - (delete-region - (point) - (+ (point) - (skip-chars-backward " \t\n"))) - (push (cons (cons width cont) (buffer-string)) - shr-content-cache))) - (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (when fill - (goto-char (point-min)) - ;; If the buffer is totally empty, then put a single blank - ;; line here. - (if (zerop (buffer-size)) - (insert (make-string width ? )) - ;; Otherwise, fill the buffer. - (while (not (eobp)) - (end-of-line) - (when (> (- width (current-column)) 0) - (insert (make-string (- width (current-column)) ? ))) - (forward-line 1)))) - (if fill - (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - (shr-collect-overlays)) - (list max - (shr-natural-width)))))) + (let ((background (shr-get-background (point)))) + (with-temp-buffer + (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) + (if cache + (insert cache) + (shr-insert-background-overlay (or (cdr (assq :bgcolor cont)) + background) + (point)) + (let ((shr-width width) + (shr-indentation 0)) + (shr-generic cont)) + (delete-region + (point) + (+ (point) + (skip-chars-backward " \t\n"))) + (push (cons (cons width cont) (buffer-string)) + shr-content-cache))) + (goto-char (point-min)) + (let ((max 0)) + (while (not (eobp)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (when fill + (goto-char (point-min)) + ;; If the buffer is totally empty, then put a single blank + ;; line here. + (if (zerop (buffer-size)) + (insert (make-string width ? )) + ;; Otherwise, fill the buffer. + (while (not (eobp)) + (end-of-line) + (when (> (- width (current-column)) 0) + (insert (make-string (- width (current-column)) ? ))) + (forward-line 1)))) + (if fill + (list max + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (shr-collect-overlays)) + (list max + (shr-natural-width))))))) (defun shr-natural-width () (goto-char (point-min)) ------------------------------------------------------------ revno: 102504 committer: Stefan Monnier branch nick: trunk timestamp: Wed 2010-11-24 11:39:51 -0500 message: * lisp/emacs-lisp/pcase.el: Improve pcase-let. Use "pcase--" prefix. (pcase--dontcare-upats): New var. (pcase-let, pcase-let*): Generate better code. Accept the same bodies as `let'. (pcase-dolist): New macro. (pcase--trivial-upat-p): New helper function. (pcase--expand): Strip leading "(let nil" if any. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-11-24 06:34:12 +0000 +++ lisp/ChangeLog 2010-11-24 16:39:51 +0000 @@ -1,3 +1,13 @@ +2010-11-24 Stefan Monnier + + * emacs-lisp/pcase.el: Improve pcase-let. Use "pcase--" prefix. + (pcase--dontcare-upats): New var. + (pcase-let, pcase-let*): Generate better code. + Accept the same bodies as `let'. + (pcase-dolist): New macro. + (pcase--trivial-upat-p): New helper function. + (pcase--expand): Strip leading "(let nil" if any. + 2010-11-24 Lars Magne Ingebrigtsen * mail/mailclient.el (browse-url): Require. === modified file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 2010-11-12 01:35:06 +0000 +++ lisp/emacs-lisp/pcase.el 2010-11-24 16:39:51 +0000 @@ -31,7 +31,7 @@ ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). ;; But better would be if we could define new ways to match by having the -;; extension provide its own `pcase-split-' thingy. +;; extension provide its own `pcase--split-' thingy. ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. @@ -46,6 +46,8 @@ ;; over and over again. (defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) +(defconst pcase--dontcare-upats '(t _ dontcare)) + ;;;###autoload (defmacro pcase (exp &rest cases) "Perform ML-style pattern matching on EXP. @@ -78,39 +80,61 @@ (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. (or (gethash (cons exp cases) pcase-memoize) (puthash (cons exp cases) - (pcase-expand exp cases) + (pcase--expand exp cases) pcase-memoize))) ;;;###autoload -(defmacro pcase-let* (bindings body) +(defmacro pcase-let* (bindings &rest body) "Like `let*' but where you can use `pcase' patterns for bindings. BODY should be an expression, and BINDINGS should be a list of bindings of the form (UPAT EXP)." (declare (indent 1) (debug let)) - (if (null bindings) body + (cond + ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body))) + ((pcase--trivial-upat-p (caar bindings)) + `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body))) + (t `(pcase ,(cadr (car bindings)) - (,(caar bindings) (pcase-let* ,(cdr bindings) ,body)) - ;; FIXME: In many cases `dontcare' would be preferable, so maybe we - ;; should have `let' and `elet', like we have `case' and `ecase'. - (t (error "Pattern match failure in `pcase-let'"))))) + (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body)) + ;; We can either signal an error here, or just use `dontcare' which + ;; generates more efficient code. In practice, if we use `dontcare' we + ;; will still often get an error and the few cases where we don't do not + ;; matter that much, so it's a better choice. + (dontcare nil))))) ;;;###autoload -(defmacro pcase-let (bindings body) +(defmacro pcase-let (bindings &rest body) "Like `let' but where you can use `pcase' patterns for bindings. -BODY should be an expression, and BINDINGS should be a list of bindings +BODY should be a list of expressions, and BINDINGS should be a list of bindings of the form (UPAT EXP)." (declare (indent 1) (debug let)) (if (null (cdr bindings)) - `(pcase-let* ,bindings ,body) - (setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings)) - `(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding))) - bindings) - (pcase-let* - ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding))) - bindings) - ,body)))) - -(defun pcase-expand (exp cases) + `(pcase-let* ,bindings ,@body) + (let ((matches '())) + (dolist (binding (prog1 bindings (setq bindings nil))) + (cond + ((memq (car binding) pcase--dontcare-upats) + (push (cons (make-symbol "_") (cdr binding)) bindings)) + ((pcase--trivial-upat-p (car binding)) (push binding bindings)) + (t + (let ((tmpvar (make-symbol (format "x%d" (length bindings))))) + (push (cons tmpvar (cdr binding)) bindings) + (push (list (car binding) tmpvar) matches))))) + `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) + +(defmacro pcase-dolist (spec &rest body) + (if (pcase--trivial-upat-p (car spec)) + `(dolist ,spec ,@body) + (let ((tmpvar (make-symbol "x"))) + `(dolist (,tmpvar ,@(cdr spec)) + (pcase-let* ((,(car spec) ,tmpvar)) + ,@body))))) + + +(defun pcase--trivial-upat-p (upat) + (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) + +(defun pcase--expand (exp cases) (let* ((defs (if (symbolp exp) '() (let ((sym (make-symbol "x"))) (prog1 `((,sym ,exp)) (setq exp sym))))) @@ -153,23 +177,24 @@ (mapcar #'car vars))) `(funcall ,res ,@args))))))) (main - (pcase-u + (pcase--u (mapcar (lambda (case) `((match ,exp . ,(car case)) ,(apply-partially - (if (pcase-small-branch-p (cdr case)) + (if (pcase--small-branch-p (cdr case)) ;; Don't bother sharing multiple ;; occurrences of this leaf since it's small. #'pcase-codegen codegen) (cdr case)))) cases)))) - `(let ,defs ,main))) + (if (null defs) main + `(let ,defs ,main)))) (defun pcase-codegen (code vars) `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) ,@code)) -(defun pcase-small-branch-p (code) +(defun pcase--small-branch-p (code) (and (= 1 (length code)) (or (not (consp (car code))) (let ((small t)) @@ -179,15 +204,15 @@ ;; Try to use `cond' rather than a sequence of `if's, so as to reduce ;; the depth of the generated tree. -(defun pcase-if (test then else) +(defun pcase--if (test then else) (cond - ((eq else :pcase-dontcare) then) + ((eq else :pcase--dontcare) then) ((eq (car-safe else) 'if) (if (equal test (nth 1 else)) ;; Doing a test a second time: get rid of the redundancy. - ;; FIXME: ideally, this should never happen because the pcase-split-* - ;; functions should have eliminated such things, but pcase-split-member - ;; is imprecise, so in practice it does happen occasionally. + ;; FIXME: ideally, this should never happen because the pcase--split-* + ;; funs should have eliminated such things, but pcase--split-member + ;; is imprecise, so in practice it can happen occasionally. `(if ,test ,then ,@(nthcdr 3 else)) `(cond (,test ,then) (,(nth 1 else) ,(nth 2 else)) @@ -198,7 +223,7 @@ ,@(remove (assoc test else) (cdr else)))) (t `(if ,test ,then ,else)))) -(defun pcase-upat (qpattern) +(defun pcase--upat (qpattern) (cond ((eq (car-safe qpattern) '\,) (cadr qpattern)) (t (list '\` qpattern)))) @@ -221,7 +246,7 @@ ;; canonicalize them to one form over another, but we do occasionally ;; turn one into the other. -(defun pcase-u (branches) +(defun pcase--u (branches) "Expand matcher for rules BRANCHES. Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. @@ -232,12 +257,12 @@ (or MATCH ...)" (when (setq branches (delq nil branches)) (destructuring-bind (match code &rest vars) (car branches) - (pcase-u1 (list match) code vars (cdr branches))))) + (pcase--u1 (list match) code vars (cdr branches))))) -(defun pcase-and (match matches) +(defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) -(defun pcase-split-match (sym splitter match) +(defun pcase--split-match (sym splitter match) (case (car match) ((match) (if (not (eq sym (cadr match))) @@ -246,20 +271,21 @@ (cond ;; Hoist `or' and `and' patterns to `or' and `and' matches. ((memq (car-safe pat) '(or and)) - (pcase-split-match sym splitter - (cons (car pat) - (mapcar (lambda (alt) - `(match ,sym . ,alt)) - (cdr pat))))) + (pcase--split-match sym splitter + (cons (car pat) + (mapcar (lambda (alt) + `(match ,sym . ,alt)) + (cdr pat))))) (t (let ((res (funcall splitter (cddr match)))) (cons (or (car res) match) (or (cdr res) match)))))))) ((or and) (let ((then-alts '()) (else-alts '()) - (neutral-elem (if (eq 'or (car match)) :pcase-fail :pcase-succeed)) - (zero-elem (if (eq 'or (car match)) :pcase-succeed :pcase-fail))) + (neutral-elem (if (eq 'or (car match)) + :pcase--fail :pcase--succeed)) + (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail))) (dolist (alt (cdr match)) - (let ((split (pcase-split-match sym splitter alt))) + (let ((split (pcase--split-match sym splitter alt))) (unless (eq (car split) neutral-elem) (push (car split) then-alts)) (unless (eq (cdr split) neutral-elem) @@ -274,50 +300,50 @@ (t (cons (car match) (nreverse else-alts))))))) (t (error "Uknown MATCH %s" match)))) -(defun pcase-split-rest (sym splitter rest) +(defun pcase--split-rest (sym splitter rest) (let ((then-rest '()) (else-rest '())) (dolist (branch rest) (let* ((match (car branch)) (code&vars (cdr branch)) (splitted - (pcase-split-match sym splitter match))) - (unless (eq (car splitted) :pcase-fail) + (pcase--split-match sym splitter match))) + (unless (eq (car splitted) :pcase--fail) (push (cons (car splitted) code&vars) then-rest)) - (unless (eq (cdr splitted) :pcase-fail) + (unless (eq (cdr splitted) :pcase--fail) (push (cons (cdr splitted) code&vars) else-rest)))) (cons (nreverse then-rest) (nreverse else-rest)))) -(defun pcase-split-consp (syma symd pat) +(defun pcase--split-consp (syma symd pat) (cond ;; A QPattern for a cons, can only go the `then' side. ((and (eq (car-safe pat) '\`) (consp (cadr pat))) (let ((qpat (cadr pat))) - (cons `(and (match ,syma . ,(pcase-upat (car qpat))) - (match ,symd . ,(pcase-upat (cdr qpat)))) - :pcase-fail))) + (cons `(and (match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat)))) + :pcase--fail))) ;; A QPattern but not for a cons, can only go the `else' side. - ((eq (car-safe pat) '\`) (cons :pcase-fail nil)))) + ((eq (car-safe pat) '\`) (cons :pcase--fail nil)))) -(defun pcase-split-equal (elem pat) +(defun pcase--split-equal (elem pat) (cond ;; The same match will give the same result. ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) - (cons :pcase-succeed :pcase-fail)) + (cons :pcase--succeed :pcase--fail)) ;; A different match will fail if this one succeeds. ((and (eq (car-safe pat) '\`) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase-fail nil)))) + (cons :pcase--fail nil)))) -(defun pcase-split-member (elems pat) - ;; Based on pcase-split-equal. +(defun pcase--split-member (elems pat) + ;; Based on pcase--split-equal. (cond ;; The same match (or a match of membership in a superset) will ;; give the same result, but we don't know how to check it. ;; (??? - ;; (cons :pcase-succeed nil)) + ;; (cons :pcase--succeed nil)) ;; A match for one of the elements may succeed or fail. ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) nil) @@ -326,26 +352,26 @@ ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase-fail nil)))) + (cons :pcase--fail nil)))) -(defun pcase-split-pred (upat pat) +(defun pcase--split-pred (upat pat) ;; FIXME: For predicates like (pred (> a)), two such predicates may ;; actually refer to different variables `a'. (if (equal upat pat) - (cons :pcase-succeed :pcase-fail))) + (cons :pcase--succeed :pcase--fail))) -(defun pcase-fgrep (vars sexp) +(defun pcase--fgrep (vars sexp) "Check which of the symbols VARS appear in SEXP." (let ((res '())) (while (consp sexp) - (dolist (var (pcase-fgrep vars (pop sexp))) + (dolist (var (pcase--fgrep vars (pop sexp))) (unless (memq var res) (push var res)))) (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) res)) ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. -(defun pcase-u1 (matches code vars rest) +(defun pcase--u1 (matches code vars rest) "Return code that runs CODE (with VARS) if MATCHES match. and otherwise defers to REST which is a list of branches of the form \(ELSE-MATCH ELSE-CODE . ELSE-VARS)." @@ -356,11 +382,11 @@ ;; between matches. So we don't bother trying to reorder anything. (cond ((null matches) (funcall code vars)) - ((eq :pcase-fail (car matches)) (pcase-u rest)) - ((eq :pcase-succeed (car matches)) - (pcase-u1 (cdr matches) code vars rest)) + ((eq :pcase--fail (car matches)) (pcase--u rest)) + ((eq :pcase--succeed (car matches)) + (pcase--u1 (cdr matches) code vars rest)) ((eq 'and (caar matches)) - (pcase-u1 (append (cdar matches) (cdr matches)) code vars rest)) + (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest)) ((eq 'or (caar matches)) (let* ((alts (cdar matches)) (var (if (eq (caar alts) 'match) (cadr (car alts)))) @@ -375,65 +401,65 @@ (push (cddr alt) simples) (push alt others)))) (cond - ((null alts) (error "Please avoid it") (pcase-u rest)) + ((null alts) (error "Please avoid it") (pcase--u rest)) ((> (length simples) 1) ;; De-hoist the `or' MATCH into an `or' pattern that will be ;; turned into a `memq' below. - (pcase-u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) - code vars - (if (null others) rest - (cons (list* - (pcase-and (if (cdr others) - (cons 'or (nreverse others)) - (car others)) - (cdr matches)) - code vars) - rest)))) + (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) + code vars + (if (null others) rest + (cons (list* + (pcase--and (if (cdr others) + (cons 'or (nreverse others)) + (car others)) + (cdr matches)) + code vars) + rest)))) (t - (pcase-u1 (cons (pop alts) (cdr matches)) code vars - (if (null alts) (progn (error "Please avoid it") rest) - (cons (list* - (pcase-and (if (cdr alts) - (cons 'or alts) (car alts)) - (cdr matches)) - code vars) - rest))))))) + (pcase--u1 (cons (pop alts) (cdr matches)) code vars + (if (null alts) (progn (error "Please avoid it") rest) + (cons (list* + (pcase--and (if (cdr alts) + (cons 'or alts) (car alts)) + (cdr matches)) + code vars) + rest))))))) ((eq 'match (caar matches)) (destructuring-bind (op sym &rest upat) (pop matches) (cond - ((memq upat '(t _)) (pcase-u1 matches code vars rest)) - ((eq upat 'dontcare) :pcase-dontcare) + ((memq upat '(t _)) (pcase--u1 matches code vars rest)) + ((eq upat 'dontcare) :pcase--dontcare) ((functionp upat) (error "Feature removed, use (pred %s)" upat)) ((memq (car-safe upat) '(guard pred)) (destructuring-bind (then-rest &rest else-rest) - (pcase-split-rest - sym (apply-partially 'pcase-split-pred upat) rest) - (pcase-if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) - `(,(cadr upat) ,sym) - (let* ((exp (cadr upat)) - ;; `vs' is an upper bound on the vars we need. - (vs (pcase-fgrep (mapcar #'car vars) exp)) - (call (cond - ((eq 'guard (car upat)) exp) - ((functionp exp) `(,exp ,sym)) - (t `(,@exp ,sym))))) - (if (null vs) - call - ;; Let's not replace `vars' in `exp' since it's - ;; too difficult to do it right, instead just - ;; let-bind `vars' around `exp'. - `(let ,(mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs) - ;; FIXME: `vars' can capture `sym'. E.g. - ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) - ,call)))) - (pcase-u1 matches code vars then-rest) - (pcase-u else-rest)))) + (pcase--split-rest + sym (apply-partially #'pcase--split-pred upat) rest) + (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) + `(,(cadr upat) ,sym) + (let* ((exp (cadr upat)) + ;; `vs' is an upper bound on the vars we need. + (vs (pcase--fgrep (mapcar #'car vars) exp)) + (call (cond + ((eq 'guard (car upat)) exp) + ((functionp exp) `(,exp ,sym)) + (t `(,@exp ,sym))))) + (if (null vs) + call + ;; Let's not replace `vars' in `exp' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `exp'. + `(let ,(mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs) + ;; FIXME: `vars' can capture `sym'. E.g. + ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) + ,call)))) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) ((symbolp upat) - (pcase-u1 matches code (cons (cons upat sym) vars) rest)) + (pcase--u1 matches code (cons (cons upat sym) vars) rest)) ((eq (car-safe upat) '\`) - (pcase-q1 sym (cadr upat) matches code vars rest)) + (pcase--q1 sym (cadr upat) matches code vars rest)) ((eq (car-safe upat) 'or) (let ((all (> (length (cdr upat)) 1)) (memq-fine t)) @@ -448,47 +474,48 @@ ;; Use memq for (or `a `b `c `d) rather than a big tree. (let ((elems (mapcar 'cadr (cdr upat)))) (destructuring-bind (then-rest &rest else-rest) - (pcase-split-rest - sym (apply-partially 'pcase-split-member elems) rest) - (pcase-if `(,(if memq-fine #'memq #'member) ,sym ',elems) - (pcase-u1 matches code vars then-rest) - (pcase-u else-rest)))) - (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars - (append (mapcar (lambda (upat) - `((and (match ,sym . ,upat) ,@matches) - ,code ,@vars)) - (cddr upat)) - rest))))) + (pcase--split-rest + sym (apply-partially #'pcase--split-member elems) rest) + (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) + (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars + (append (mapcar (lambda (upat) + `((and (match ,sym . ,upat) ,@matches) + ,code ,@vars)) + (cddr upat)) + rest))))) ((eq (car-safe upat) 'and) - (pcase-u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) (cdr upat)) - matches) - code vars rest)) + (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) + (cdr upat)) + matches) + code vars rest)) ((eq (car-safe upat) 'not) ;; FIXME: The implementation below is naive and results in ;; inefficient code. - ;; To make it work right, we would need to turn pcase-u1's + ;; To make it work right, we would need to turn pcase--u1's ;; `code' and `vars' into a single argument of the same form as ;; `rest'. We would also need to split this new `then-rest' argument ;; for every test (currently we don't bother to do it since ;; it's only useful for odd patterns like (and `(PAT1 . PAT2) ;; `(PAT3 . PAT4)) which the programmer can easily rewrite ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). - (pcase-u1 `((match ,sym . ,(cadr upat))) - (lexical-let ((rest rest)) - ;; FIXME: This codegen is not careful to share its - ;; code if used several times: code blow up is likely. - (lambda (vars) - ;; `vars' will likely contain bindings which are - ;; not always available in other paths to - ;; `rest', so there' no point trying to pass - ;; them down. - (pcase-u rest))) - vars - (list `((and . ,matches) ,code . ,vars)))) + (pcase--u1 `((match ,sym . ,(cadr upat))) + (lexical-let ((rest rest)) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest))) + vars + (list `((and . ,matches) ,code . ,vars)))) (t (error "Unknown upattern `%s'" upat))))) (t (error "Incorrect MATCH %s" (car matches))))) -(defun pcase-q1 (sym qpat matches code vars rest) +(defun pcase--q1 (sym qpat matches code vars rest) "Return code that runs CODE if SYM matches QPAT and if MATCHES match. and if not, defers to REST which is a list of branches of the form \(OTHER_MATCH OTHER-CODE . OTHER-VARS)." @@ -502,22 +529,23 @@ (let ((syma (make-symbol "xcar")) (symd (make-symbol "xcdr"))) (destructuring-bind (then-rest &rest else-rest) - (pcase-split-rest sym (apply-partially 'pcase-split-consp syma symd) - rest) - (pcase-if `(consp ,sym) - `(let ((,syma (car ,sym)) - (,symd (cdr ,sym))) - ,(pcase-u1 `((match ,syma . ,(pcase-upat (car qpat))) - (match ,symd . ,(pcase-upat (cdr qpat))) - ,@matches) - code vars then-rest)) - (pcase-u else-rest))))) + (pcase--split-rest sym + (apply-partially #'pcase--split-consp syma symd) + rest) + (pcase--if `(consp ,sym) + `(let ((,syma (car ,sym)) + (,symd (cdr ,sym))) + ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat))) + ,@matches) + code vars then-rest)) + (pcase--u else-rest))))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) (destructuring-bind (then-rest &rest else-rest) - (pcase-split-rest sym (apply-partially 'pcase-split-equal qpat) rest) - (pcase-if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) - (pcase-u1 matches code vars then-rest) - (pcase-u else-rest)))) + (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) + (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) (t (error "Unkown QPattern %s" qpat)))) ------------------------------------------------------------ revno: 102503 committer: Jan D. branch nick: trunk timestamp: Wed 2010-11-24 15:52:14 +0100 message: nsterm.m (keyDown): Compare Left key masks exactly (Bug#7458). diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2010-11-24 07:50:08 +0000 +++ src/ChangeLog 2010-11-24 14:52:14 +0000 @@ -2,7 +2,8 @@ * nsterm.m (NSLeftControlKeyMask, NSLeftCommandKeyMask) (NSLeftAlternateKeyMask): New defines. - (keyDown): Parse left and right keys separatly (Bug#7458). + (keyDown): Parse left and right keys separately (Bug#7458). + Compare Left key masks exactly (Bug#7458). 2010-11-23 Eli Zaretskii === modified file 'src/nsterm.m' --- src/nsterm.m 2010-11-24 07:50:08 +0000 +++ src/nsterm.m 2010-11-24 14:52:14 +0000 @@ -4451,7 +4451,7 @@ ? ns_command_modifier : ns_right_command_modifier); - if (flags & NSLeftCommandKeyMask) + if ((flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask) { emacs_event->modifiers |= parse_solitary_modifier (ns_command_modifier); @@ -4494,7 +4494,7 @@ ? ns_control_modifier : ns_right_control_modifier); - if (flags & NSLeftControlKeyMask) + if ((flags & NSLeftControlKeyMask) == NSLeftControlKeyMask) emacs_event->modifiers |= parse_solitary_modifier (ns_control_modifier); @@ -4521,7 +4521,7 @@ : ns_right_alternate_modifier); } - if (flags & NSLeftAlternateKeyMask) /* default = meta */ + if ((flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask) /* default = meta */ { if ((NILP (ns_alternate_modifier) || EQ (ns_alternate_modifier, Qnone)) ------------------------------------------------------------ revno: 102502 author: Julien Danjou committer: Katsumi Yamaoka branch nick: trunk timestamp: Wed 2010-11-24 12:56:50 +0000 message: color-lab: Require 'cl when compiling. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-24 11:32:22 +0000 +++ lisp/gnus/ChangeLog 2010-11-24 12:56:50 +0000 @@ -4,6 +4,8 @@ 2010-11-24 Julien Danjou + * color-lab.el: Require 'cl when compiling. + * shr.el (shr-insert-color-overlay): Remove specific rgb() check. * shr-color.el (shr-color->hexadecimal): Only return the hexadecimal === modified file 'lisp/gnus/color-lab.el' --- lisp/gnus/color-lab.el 2010-11-24 11:32:22 +0000 +++ lisp/gnus/color-lab.el 2010-11-24 12:56:50 +0000 @@ -26,6 +26,9 @@ ;;; Code: +(eval-when-compile + (require 'cl)) + ;; Emacs < 23.3 (eval-and-compile (unless (boundp 'float-pi) ------------------------------------------------------------ revno: 102501 author: Gnus developers committer: Katsumi Yamaoka branch nick: trunk timestamp: Wed 2010-11-24 11:32:22 +0000 message: color-lab.el: Fix all expt calls to use float type. shr-color.el: only return hexadecimal part of colors. shr.el: Protect against non-existant colour names. diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2010-11-24 06:50:28 +0000 +++ lisp/gnus/ChangeLog 2010-11-24 11:32:22 +0000 @@ -1,3 +1,16 @@ +2010-11-24 Lars Magne Ingebrigtsen + + * shr.el (shr-color-check): Protect against non-existant colour names. + +2010-11-24 Julien Danjou + + * shr.el (shr-insert-color-overlay): Remove specific rgb() check. + + * shr-color.el (shr-color->hexadecimal): Only return the hexadecimal + matched part. + + * color-lab.el: Fix all expt calls to use float type. + 2010-11-24 Katsumi Yamaoka * shr.el (shr-insert-color-overlay): Pass rgb(rrr, ggg, bbb) type color === modified file 'lisp/gnus/color-lab.el' --- lisp/gnus/color-lab.el 2010-11-24 01:28:37 +0000 +++ lisp/gnus/color-lab.el 2010-11-24 11:32:22 +0000 @@ -153,14 +153,14 @@ (let* ((fy (/ (+ L 16) 116.0)) (fz (- fy (/ b 200.0))) (fx (+ (/ a 500.0) fy)) - (xr (if (> (expt fx 3) color-lab-ε) - (expt fx 3) + (xr (if (> (expt fx 3.0) color-lab-ε) + (expt fx 3.0) (/ (- (* fx 116) 16) color-lab-κ))) (yr (if (> L (* color-lab-κ color-lab-ε)) - (expt (/ (+ L 16) 116.0) 3) + (expt (/ (+ L 16) 116.0) 3.0) (/ L color-lab-κ))) (zr (if (> (expt fz 3) color-lab-ε) - (expt fz 3) + (expt fz 3.0) (/ (- (* 116 fz) 16) color-lab-κ)))) (list (* xr Xr) ; X (* yr Yr) ; Y @@ -186,14 +186,14 @@ (let* ((kL (or kL 1)) (kC (or kC 1)) (kH (or kH 1)) - (C₁ (sqrt (+ (expt a₁ 2) (expt b₁ 2)))) - (C₂ (sqrt (+ (expt a₂ 2) (expt b₂ 2)))) + (C₁ (sqrt (+ (expt a₁ 2.0) (expt b₁ 2.0)))) + (C₂ (sqrt (+ (expt a₂ 2.0) (expt b₂ 2.0)))) (C̄ (/ (+ C₁ C₂) 2.0)) - (G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7) (+ (expt C̄ 7) (expt 25 7))))))) + (G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7.0) (+ (expt C̄ 7.0) (expt 25 7.0))))))) (a′₁ (* (+ 1 G) a₁)) (a′₂ (* (+ 1 G) a₂)) - (C′₁ (sqrt (+ (expt a′₁ 2) (expt b₁ 2)))) - (C′₂ (sqrt (+ (expt a′₂ 2) (expt b₂ 2)))) + (C′₁ (sqrt (+ (expt a′₁ 2.0) (expt b₁ 2.0)))) + (C′₂ (sqrt (+ (expt a′₂ 2.0) (expt b₂ 2.0)))) (h′₁ (if (and (= b₁ 0) (= a′₁ 0)) 0 (let ((v (atan b₁ a′₁))) @@ -232,15 +232,15 @@ (* 0.24 (cos (* h̄′ 2))) (* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6)))) (- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63))))))) - (Δθ (* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25)) 2))))) - (Rc (* 2 (sqrt (/ (expt C̄′ 7) (+ (expt C̄′ 7) (expt 25 7)))))) - (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2)) (sqrt (+ 20 (expt (- L̄′ 50) 2)))))) + (Δθ (* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25)) 2.0))))) + (Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0)))))) + (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0)) (sqrt (+ 20 (expt (- L̄′ 50) 2.0)))))) (Sc (+ 1 (* C̄′ 0.045))) (Sh (+ 1 (* 0.015 C̄′ T))) (Rt (- (* (sin (* Δθ 2)) Rc)))) - (sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2) - (expt (/ ΔC′ (* Sc kC)) 2) - (expt (/ ΔH′ (* Sh kH)) 2) + (sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2.0) + (expt (/ ΔC′ (* Sc kC)) 2.0) + (expt (/ ΔH′ (* Sh kH)) 2.0) (* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH))))))))) (provide 'color-lab) === modified file 'lisp/gnus/shr-color.el' --- lisp/gnus/shr-color.el 2010-11-24 06:22:51 +0000 +++ lisp/gnus/shr-color.el 2010-11-24 11:32:22 +0000 @@ -231,10 +231,10 @@ (when color (cond ;; Hexadecimal color: #abc or #aabbcc - ((string-match-p - "#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?" + ((string-match + "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" color) - color) + (match-string 1 color)) ;; rgb() or rgba() colors ((or (string-match "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" === modified file 'lisp/gnus/shr.el' --- lisp/gnus/shr.el 2010-11-24 06:50:28 +0000 +++ lisp/gnus/shr.el 2010-11-24 11:32:22 +0000 @@ -496,18 +496,18 @@ (autoload 'shr-color->hexadecimal "shr-color") (defun shr-color-check (fg &optional bg) "Check that FG is visible on BG." - (shr-color-visible (or (shr-color->hexadecimal bg) - (frame-parameter nil 'background-color)) - (shr-color->hexadecimal fg) (not bg))) + (let ((hex-color (shr-color->hexadecimal fg))) + (when hex-color + (shr-color-visible (or (shr-color->hexadecimal bg) + (frame-parameter nil 'background-color)) + hex-color (not bg))))) (defun shr-insert-color-overlay (color start end) (when color - (when (and (not (string-match "\\`rgb([^\)]+)\\'" color)) - (string-match " " color)) - (setq color (car (split-string color)))) - (let ((overlay (make-overlay start end))) - (overlay-put overlay 'face (cons 'foreground-color - (cadr (shr-color-check color))))))) + (let ((new-color (cadr (shr-color-check color)))) + (when new-color + (overlay-put (make-overlay start end) 'face + (cons 'foreground-color new-color)))))) ;;; Tag-specific rendering rules. ------------------------------------------------------------ revno: 102500 committer: Jan D. branch nick: trunk timestamp: Wed 2010-11-24 08:50:08 +0100 message: Bug 7458: Make key press like Left + right ctrl work when right is not control. Ditto Alt and Command. * src/nsterm.m (NSLeftControlKeyMask, NSLeftCommandKeyMask) (NSLeftAlternateKeyMask): New defines. (keyDown): Parse left and right keys separatly. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2010-11-23 20:27:22 +0000 +++ src/ChangeLog 2010-11-24 07:50:08 +0000 @@ -1,3 +1,9 @@ +2010-11-24 Jan Djärv + + * nsterm.m (NSLeftControlKeyMask, NSLeftCommandKeyMask) + (NSLeftAlternateKeyMask): New defines. + (keyDown): Parse left and right keys separatly (Bug#7458). + 2010-11-23 Eli Zaretskii * intervals.c (temp_set_point_both): Define before calling, to === modified file 'src/nsterm.m' --- src/nsterm.m 2010-11-21 13:09:34 +0000 +++ src/nsterm.m 2010-11-24 07:50:08 +0000 @@ -233,9 +233,12 @@ /* Convert modifiers in a NeXTSTEP event to emacs style modifiers. */ #define NS_FUNCTION_KEY_MASK 0x800000 -#define NSRightAlternateKeyMask (0x000040 | NSAlternateKeyMask) +#define NSLeftControlKeyMask (0x000001 | NSControlKeyMask) #define NSRightControlKeyMask (0x002000 | NSControlKeyMask) +#define NSLeftCommandKeyMask (0x000008 | NSCommandKeyMask) #define NSRightCommandKeyMask (0x000010 | NSCommandKeyMask) +#define NSLeftAlternateKeyMask (0x000020 | NSAlternateKeyMask) +#define NSRightAlternateKeyMask (0x000040 | NSAlternateKeyMask) #define EV_MODIFIERS(e) \ ((([e modifierFlags] & NSHelpKeyMask) ? \ hyper_modifier : 0) \ @@ -4419,7 +4422,7 @@ code = ([[theEvent charactersIgnoringModifiers] length] == 0) ? 0 : [[theEvent charactersIgnoringModifiers] characterAtIndex: 0]; /* (Carbon way: [theEvent keyCode]) */ - + /* is it a "function key"? */ fnKeysym = ns_convert_key (code); if (fnKeysym) @@ -4442,15 +4445,16 @@ if (flags & NSShiftKeyMask) emacs_event->modifiers |= shift_modifier; - if (flags & NSCommandKeyMask) + if ((flags & NSRightCommandKeyMask) == NSRightCommandKeyMask) + emacs_event->modifiers |= parse_solitary_modifier + (EQ (ns_right_command_modifier, Qleft) + ? ns_command_modifier + : ns_right_command_modifier); + + if (flags & NSLeftCommandKeyMask) { - if ((flags & NSRightCommandKeyMask) == NSRightCommandKeyMask - && !EQ (ns_right_command_modifier, Qleft)) - emacs_event->modifiers |= parse_solitary_modifier - (ns_right_command_modifier); - else - emacs_event->modifiers |= parse_solitary_modifier - (ns_command_modifier); + emacs_event->modifiers |= parse_solitary_modifier + (ns_command_modifier); /* if super (default), take input manager's word so things like dvorak / qwerty layout work */ @@ -4484,30 +4488,43 @@ } } - if (flags & NSControlKeyMask) - { - if ((flags & NSRightControlKeyMask) == NSRightControlKeyMask - && !EQ (ns_right_control_modifier, Qleft)) - emacs_event->modifiers |= parse_solitary_modifier - (ns_right_control_modifier); - else - emacs_event->modifiers |= parse_solitary_modifier - (ns_control_modifier); - } + if ((flags & NSRightControlKeyMask) == NSRightControlKeyMask) + emacs_event->modifiers |= parse_solitary_modifier + (EQ (ns_right_control_modifier, Qleft) + ? ns_control_modifier + : ns_right_control_modifier); + + if (flags & NSLeftControlKeyMask) + emacs_event->modifiers |= parse_solitary_modifier + (ns_control_modifier); if (flags & NS_FUNCTION_KEY_MASK && !fnKeysym) emacs_event->modifiers |= parse_solitary_modifier (ns_function_modifier); - if (!EQ (ns_right_alternate_modifier, Qleft) - && ((flags & NSRightAlternateKeyMask) == NSRightAlternateKeyMask)) - { - emacs_event->modifiers |= parse_solitary_modifier - (ns_right_alternate_modifier); - } - else if (flags & NSAlternateKeyMask) /* default = meta */ - { - if ((NILP (ns_alternate_modifier) || EQ (ns_alternate_modifier, Qnone)) + if ((flags & NSRightAlternateKeyMask) == NSRightAlternateKeyMask) + { + if ((NILP (ns_right_alternate_modifier) + || EQ (ns_right_alternate_modifier, Qnone)) + && !fnKeysym) + { /* accept pre-interp alt comb */ + if ([[theEvent characters] length] > 0) + code = [[theEvent characters] characterAtIndex: 0]; + /*HACK: clear lone shift modifier to stop next if from firing */ + if (emacs_event->modifiers == shift_modifier) + emacs_event->modifiers = 0; + } + else + emacs_event->modifiers |= parse_solitary_modifier + (EQ (ns_right_alternate_modifier, Qleft) + ? ns_alternate_modifier + : ns_right_alternate_modifier); + } + + if (flags & NSLeftAlternateKeyMask) /* default = meta */ + { + if ((NILP (ns_alternate_modifier) + || EQ (ns_alternate_modifier, Qnone)) && !fnKeysym) { /* accept pre-interp alt comb */ if ([[theEvent characters] length] > 0)