Now on revision 111678. ------------------------------------------------------------ revno: 111678 committer: Glenn Morris branch nick: trunk timestamp: Mon 2013-02-04 21:12:58 -0500 message: * lisp/profiler.el (profiler-report-mode-map): Add a restart menu entry. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-02-05 02:03:51 +0000 +++ lisp/ChangeLog 2013-02-05 02:12:58 +0000 @@ -1,5 +1,7 @@ 2013-02-05 Glenn Morris + * profiler.el (profiler-report-mode-map): Add a restart menu entry. + * play/gamegrid.el (gamegrid-add-score-with-update-game-score): Fix directory creation in fallback case. === modified file 'lisp/profiler.el' --- lisp/profiler.el 2013-01-25 04:41:39 +0000 +++ lisp/profiler.el 2013-02-05 02:12:58 +0000 @@ -466,6 +466,8 @@ ["Write Profile..." profiler-report-write-profile :active t :help "Write current profile to a file"] "--" + ["Start Profiler" profiler-start :active (not (profiler-running-p)) + :help "Start profiling"] ["Stop Profiler" profiler-stop :active (profiler-running-p) :help "Stop profiling"] ["New Report" profiler-report :active (profiler-running-p) ------------------------------------------------------------ revno: 111677 committer: Glenn Morris branch nick: trunk timestamp: Mon 2013-02-04 21:06:53 -0500 message: Fix indentation in previous diff: === modified file 'lisp/play/gamegrid.el' --- lisp/play/gamegrid.el 2013-02-05 02:03:51 +0000 +++ lisp/play/gamegrid.el 2013-02-05 02:06:53 +0000 @@ -509,10 +509,11 @@ (unless (file-exists-p (directory-file-name gamegrid-user-score-file-directory)) (make-directory gamegrid-user-score-file-directory t)) - (let ((f (expand-file-name file gamegrid-user-score-file-directory))) - (unless (file-exists-p f) + (let ((f (expand-file-name file + gamegrid-user-score-file-directory))) + (unless (file-exists-p f) (write-region "" nil f nil 'silent nil 'excl)) - (gamegrid-add-score-with-update-game-score-1 file f score)))))) + (gamegrid-add-score-with-update-game-score-1 file f score)))))) (defun gamegrid-add-score-with-update-game-score-1 (file target score) (let ((default-directory "/") ------------------------------------------------------------ revno: 111676 committer: Glenn Morris branch nick: trunk timestamp: Mon 2013-02-04 21:03:51 -0500 message: gamegrid-add-score-with-update-game-score fix * lisp/play/gamegrid.el (gamegrid-add-score-with-update-game-score): Fix directory creation in fallback case. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-02-04 21:23:15 +0000 +++ lisp/ChangeLog 2013-02-05 02:03:51 +0000 @@ -1,3 +1,8 @@ +2013-02-05 Glenn Morris + + * play/gamegrid.el (gamegrid-add-score-with-update-game-score): + Fix directory creation in fallback case. + 2013-02-04 Thierry Volpiatto * vc/vc.el (vc-next-action): Fix inf-loop (bug#13610). === modified file 'lisp/play/gamegrid.el' --- lisp/play/gamegrid.el 2013-01-02 16:13:04 +0000 +++ lisp/play/gamegrid.el 2013-02-05 02:03:51 +0000 @@ -505,15 +505,13 @@ (make-directory gamegrid-user-score-file-directory t)) (gamegrid-add-score-insecure file score gamegrid-user-score-file-directory)) - (t (let ((f (expand-file-name - gamegrid-user-score-file-directory))) - (when (file-writable-p f) - (unless (eq (car-safe (file-attributes f)) - t) - (make-directory f)) - (setq f (expand-file-name file f)) + (t + (unless (file-exists-p + (directory-file-name gamegrid-user-score-file-directory)) + (make-directory gamegrid-user-score-file-directory t)) + (let ((f (expand-file-name file gamegrid-user-score-file-directory))) (unless (file-exists-p f) - (write-region "" nil f nil 'silent nil 'excl))) + (write-region "" nil f nil 'silent nil 'excl)) (gamegrid-add-score-with-update-game-score-1 file f score)))))) (defun gamegrid-add-score-with-update-game-score-1 (file target score) ------------------------------------------------------------ revno: 111675 fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=13610 author: Thierry Volpiatto committer: Stefan Monnier branch nick: trunk timestamp: Mon 2013-02-04 16:23:15 -0500 message: * lisp/vc/vc.el (vc-next-action): Fix inf-loop. (vc-update-change-log): Use dolist. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-02-04 12:02:25 +0000 +++ lisp/ChangeLog 2013-02-04 21:23:15 +0000 @@ -1,3 +1,8 @@ +2013-02-04 Thierry Volpiatto + + * vc/vc.el (vc-next-action): Fix inf-loop (bug#13610). + (vc-update-change-log): Use dolist. + 2013-02-04 Chong Yidong * thingatpt.el: Rewrite the URL detection routines, absorbing some @@ -10,13 +15,13 @@ (thing-at-point-newsgroup-heads) (thing-at-point-default-mail-uri-scheme): New variables. (thing-at-point-bounds-of-url-at-point): Rewrite. Use ffap's - method to find the possible bounds of the URI at point. New - optional argument to find ill-formed URIs. + method to find the possible bounds of the URI at point. + New optional argument to find ill-formed URIs. (thing-at-point-url-at-point): Rewrite. New arguments for finding ill-formed URIs. Use thing-at-point-bounds-of-url-at-point, and the scheme-adding heuristics from ffap-url-at-point. - (thing-at-point--bounds-of-well-formed-url): New function. Do - parens matching to decide whether to include parens in the URI + (thing-at-point--bounds-of-well-formed-url): New function. + Do parens matching to decide whether to include parens in the URI (Bug#9153). * ffap.el: Require thingatpt. @@ -41,8 +46,8 @@ (tramp-handle-insert-file-contents): Use `visit' when inserting the local copy. - * net/tramp-sh.el (tramp-sh-handle-set-visited-file-modtime): Use - `remote-file-name-inhibit-cache'. + * net/tramp-sh.el (tramp-sh-handle-set-visited-file-modtime): + Use `remote-file-name-inhibit-cache'. 2013-02-03 Stefan Monnier === modified file 'lisp/vc/vc.el' --- lisp/vc/vc.el 2013-01-06 02:58:57 +0000 +++ lisp/vc/vc.el 2013-02-04 21:23:15 +0000 @@ -1079,15 +1079,13 @@ ;; If a buffer has unsaved changes, a checkout would discard those ;; changes, so treat the buffer as having unlocked changes. (when (and (not (eq model 'implicit)) (eq state 'up-to-date)) - (let ((files files)) - (while files - (let ((buffer (get-file-buffer (car files)))) - (and buffer - (buffer-modified-p buffer) - (setq state 'unlocked-changes - files nil)))))) + (dolist (file files) + (let ((buffer (get-file-buffer file))) + (and buffer + (buffer-modified-p buffer) + (setq state 'unlocked-changes))))) - ;; Do the right thing + ;; Do the right thing. (cond ((eq state 'missing) (error "Fileset files are missing, so cannot be operated on")) @@ -2667,14 +2665,11 @@ (cond ((consp current-prefix-arg) ;C-u (list buffer-file-name)) (current-prefix-arg ;Numeric argument. - (let ((files nil) - (buffers (buffer-list)) - file) - (while buffers - (setq file (buffer-file-name (car buffers))) - (and file (vc-backend file) - (setq files (cons file files))) - (setq buffers (cdr buffers))) + (let ((files nil)) + (dolist (buffer (buffer-list)) + (let ((file (buffer-file-name buffer))) + (and file (vc-backend file) + (setq files (cons file files))))) files)) (t ;; Don't supply any filenames to backend; this means ------------------------------------------------------------ revno: 111674 committer: Paul Eggert branch nick: trunk timestamp: Mon 2013-02-04 08:33:30 -0800 message: * fileio.c (Qchoose_write_coding_system): Now static. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-02-04 15:39:55 +0000 +++ src/ChangeLog 2013-02-04 16:33:30 +0000 @@ -1,3 +1,7 @@ +2013-02-04 Paul Eggert + + * fileio.c (Qchoose_write_coding_system): Now static. + 2013-02-04 Eli Zaretskii * xdisp.c (window_buffer_changed): region_showing can be negative, === modified file 'src/fileio.c' --- src/fileio.c 2013-02-02 19:18:00 +0000 +++ src/fileio.c 2013-02-04 16:33:30 +0000 @@ -251,7 +251,7 @@ static Lisp_Object Qset_file_acl; static Lisp_Object Qfile_newer_than_file_p; Lisp_Object Qinsert_file_contents; -Lisp_Object Qchoose_write_coding_system; +static Lisp_Object Qchoose_write_coding_system; Lisp_Object Qwrite_region; static Lisp_Object Qverify_visited_file_modtime; static Lisp_Object Qset_visited_file_modtime; ------------------------------------------------------------ revno: 111673 fixes bugs: http://debbugs.gnu.org/13623 http://debbugs.gnu.org/13626 committer: Eli Zaretskii branch nick: trunk timestamp: Mon 2013-02-04 17:39:55 +0200 message: Fix bugs #13623 and 13626 caused by changes in revision 111647. src/xdisp.c (window_buffer_changed): region_showing can be negative, which still means region is being displayed. (redisplay_internal): Resurrect code that forced redisplay of the whole window when showing region and the mark has changed. Record the new mark position to allow redisplay optimizations. (display_line): If it->region_beg_charpos is non-zero, set the window's region_showing member to -1. src/window.h (struct window) : Declare ptrdiff_t, not bitfield of 1 bit. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-02-03 16:45:37 +0000 +++ src/ChangeLog 2013-02-04 15:39:55 +0000 @@ -1,3 +1,16 @@ +2013-02-04 Eli Zaretskii + + * xdisp.c (window_buffer_changed): region_showing can be negative, + which still means region is being displayed. + (redisplay_internal): Resurrect code that forced redisplay of the + whole window when showing region and the mark has changed. Record + the new mark position to allow redisplay optimizations. + (display_line): If it->region_beg_charpos is non-zero, set the + window's region_showing member to -1. (Bug#13623) (Bug#13626) + + * window.h (struct window) : Declare ptrdiff_t, + not bitfield of 1 bit. + 2013-02-03 Daniel Colascione * emacs.c: Use execvp, not execv, when DAEMON_MUST_EXEC, so that === modified file 'src/window.h' --- src/window.h 2013-02-01 07:23:18 +0000 +++ src/window.h 2013-02-04 15:39:55 +0000 @@ -333,13 +333,15 @@ the frame image that window_end_pos did not get onto the frame. */ unsigned window_end_valid : 1; - /* Nonzero if we have highlighted the region (or any part of it). */ - unsigned region_showing : 1; - /* Amount by which lines of this window are scrolled in y-direction (smooth scrolling). */ int vscroll; + /* If we have highlighted the region (or any part of it), the mark + position or -1 (the latter is used by the iterator for internal + purposes); otherwise zero. */ + ptrdiff_t region_showing; + /* Z_BYTE - buffer position of the last glyph in the current matrix of W. Should be nonnegative, and only valid if window_end_valid is nonzero. */ ptrdiff_t window_end_bytepos; === modified file 'src/xdisp.c' --- src/xdisp.c 2013-02-01 07:23:18 +0000 +++ src/xdisp.c 2013-02-04 15:39:55 +0000 @@ -10753,7 +10753,7 @@ return (((BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)) != w->last_had_star) || ((!NILP (Vtransient_mark_mode) && !NILP (BVAR (b, mark_active))) - != w->region_showing)); + != (w->region_showing != 0))); } /* Nonzero if W has %c in its mode line and mode line should be updated. */ @@ -13016,6 +13016,17 @@ clear_garbaged_frames (); } + /* If showing the region, and mark has changed, we must redisplay + the whole window. The assignment to this_line_start_pos prevents + the optimization directly below this if-statement. */ + if (((!NILP (Vtransient_mark_mode) + && !NILP (BVAR (XBUFFER (w->buffer), mark_active))) + != (w->region_showing > 0)) + || (w->region_showing + && w->region_showing + != XINT (Fmarker_position (BVAR (XBUFFER (w->buffer), mark))))) + CHARPOS (this_line_start_pos) = 0; + /* Optimize the case that only the line containing the cursor in the selected window has changed. Variables starting with this_ are set in display_line and record information about the line @@ -13228,6 +13239,8 @@ ++clear_image_cache_count; #endif + w->region_showing = XINT (Fmarker_position (BVAR (XBUFFER (w->buffer), mark))); + /* Build desired matrices, and update the display. If consider_all_windows_p is non-zero, do it for all windows on all frames. Otherwise do it for selected_window, only. */ @@ -19120,7 +19133,7 @@ } /* Is IT->w showing the region? */ - it->w->region_showing = it->region_beg_charpos > 0; + it->w->region_showing = it->region_beg_charpos > 0 ? -1 : 0; /* Clear the result glyph row and enable it. */ prepare_desired_row (row); ------------------------------------------------------------ revno: 111672 fixes bug: http://debbugs.gnu.org/5673 committer: Chong Yidong branch nick: trunk timestamp: Mon 2013-02-04 20:02:25 +0800 message: Merge FFAP's URI-detection code into thingatpt.el. * lisp/ffap.el: Require thingatpt. (ffap-url-at-point): Delegate URI detection to thing-at-point. All URI-valid characters are now recognized. (ffap-string-at-point): Use use-region-p. (ffap-url-regexp): Extra character is handled by thing-at-point. (ffap-string-at-point-mode-alist): Allow parentheses. (ffap-newsgroup-regexp, ffap-newsgroup-heads, ffap-newsgroup-p): Convert to aliases; code moved to thingatpt.el. (ffap-gnus-hook): Use setq-local. * lisp/thingatpt.el: Rewrite the URL detection routines, absorbing some code from ffap.el. (thing-at-point-beginning-of-url-regexp): New var. (thing-at-point-uri-schemes): Update list of URI schemes. (thing-at-point-url-regexp): Variable deleted. (thing-at-point-markedup-url-regexp): Disallow newlines. (thing-at-point-newsgroup-regexp) (thing-at-point-newsgroup-heads) (thing-at-point-default-mail-uri-scheme): New variables. (thing-at-point-bounds-of-url-at-point): Rewrite. Use ffap's method to find the possible bounds of the URI at point. New optional argument to find ill-formed URIs. (thing-at-point-url-at-point): Rewrite. New arguments for finding ill-formed URIs. Use thing-at-point-bounds-of-url-at-point, and the scheme-adding heuristics from ffap-url-at-point. (thing-at-point--bounds-of-well-formed-url): New function. Do parens matching to decide whether to include parens in the URI * test/automated/thingatpt.el: New file. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-02-04 07:46:22 +0000 +++ lisp/ChangeLog 2013-02-04 12:02:25 +0000 @@ -1,3 +1,34 @@ +2013-02-04 Chong Yidong + + * thingatpt.el: Rewrite the URL detection routines, absorbing some + code from ffap.el. + (thing-at-point-beginning-of-url-regexp): New var. + (thing-at-point-uri-schemes): Update list of URI schemes. + (thing-at-point-url-regexp): Variable deleted. + (thing-at-point-markedup-url-regexp): Disallow newlines. + (thing-at-point-newsgroup-regexp) + (thing-at-point-newsgroup-heads) + (thing-at-point-default-mail-uri-scheme): New variables. + (thing-at-point-bounds-of-url-at-point): Rewrite. Use ffap's + method to find the possible bounds of the URI at point. New + optional argument to find ill-formed URIs. + (thing-at-point-url-at-point): Rewrite. New arguments for finding + ill-formed URIs. Use thing-at-point-bounds-of-url-at-point, and + the scheme-adding heuristics from ffap-url-at-point. + (thing-at-point--bounds-of-well-formed-url): New function. Do + parens matching to decide whether to include parens in the URI + (Bug#9153). + + * ffap.el: Require thingatpt. + (ffap-url-at-point): Delegate URI detection to thing-at-point. + All URI-valid characters are now recognized (Bug#5673). + (ffap-string-at-point): Use use-region-p. + (ffap-url-regexp): Extra character is handled by thing-at-point. + (ffap-string-at-point-mode-alist): Allow parentheses. + (ffap-newsgroup-regexp, ffap-newsgroup-heads, ffap-newsgroup-p): + Convert to aliases; code moved to thingatpt.el. + (ffap-gnus-hook): Use setq-local. + 2013-02-04 Glenn Morris * emacs-lisp/ert.el (ert--explain-format-atom): === modified file 'lisp/ffap.el' --- lisp/ffap.el 2013-01-11 23:08:55 +0000 +++ lisp/ffap.el 2013-02-04 12:02:25 +0000 @@ -106,6 +106,7 @@ ;;; Code: (require 'url-parse) +(require 'thingatpt) (define-obsolete-variable-alias 'ffap-version 'emacs-version "23.2") @@ -178,16 +179,14 @@ :group 'ffap) (defvar ffap-url-regexp - ;; Could just use `url-nonrelative-link' of w3, if loaded. - ;; This regexp is not exhaustive, it just matches common cases. (concat "\\(" "news\\(post\\)?:\\|mailto:\\|file:" ; no host ok "\\|" "\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://" ; needs host - "\\)." ; require one more character - ) - "Regexp matching URLs. Use nil to disable URL features in ffap.") + "\\)") + "Regexp matching the beginning of a URI, for FFAP. +If the value is nil, disable URL-matching features in ffap.") (defcustom ffap-foo-at-bar-prefix "mailto" "Presumed URL prefix type of strings like \"\". @@ -571,38 +570,9 @@ (ffap-ftp-regexp (ffap-host-to-filename mach)) )) -(defvar ffap-newsgroup-regexp "^[[:lower:]]+\\.[-+[:lower:]_0-9.]+$" - "Strings not matching this fail `ffap-newsgroup-p'.") -(defvar ffap-newsgroup-heads ; entirely inadequate - '("alt" "comp" "gnu" "misc" "news" "sci" "soc" "talk") - "Used by `ffap-newsgroup-p' if gnus is not running.") - -(defun ffap-newsgroup-p (string) - "Return STRING if it looks like a newsgroup name, else nil." - (and - (string-match ffap-newsgroup-regexp string) - (let ((htbs '(gnus-active-hashtb gnus-newsrc-hashtb gnus-killed-hashtb)) - (heads ffap-newsgroup-heads) - htb ret) - (while htbs - (setq htb (car htbs) htbs (cdr htbs)) - (condition-case nil - (progn - ;; errs: htb symbol may be unbound, or not a hash-table. - ;; gnus-gethash is just a macro for intern-soft. - (and (symbol-value htb) - (intern-soft string (symbol-value htb)) - (setq ret string htbs nil)) - ;; If we made it this far, gnus is running, so ignore "heads": - (setq heads nil)) - (error nil))) - (or ret (not heads) - (let ((head (string-match "\\`\\([[:lower:]]+\\)\\." string))) - (and head (setq head (substring string 0 (match-end 1))) - (member head heads) - (setq ret string)))) - ;; Is there ever a need to modify string as a newsgroup name? - ret))) +(defvaralias 'ffap-newsgroup-regexp 'thing-at-point-newsgroup-regexp) +(defvaralias 'ffap-newsgroup-heads 'thing-at-point-newsgroup-heads) +(defalias 'ffap-newsgroup-p 'thing-at-point-newsgroup-p) (defsubst ffap-url-p (string) "If STRING looks like an URL, return it (maybe improved), else nil." @@ -1017,7 +987,7 @@ ;; * no commas (good for latex) (file "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:") ;; An url, or maybe a email/news message-id: - (url "--:=&?$+@-Z_[:alpha:]~#,%;*" "^[:alnum:]" ":;.,!?") + (url "--:=&?$+@-Z_[:alpha:]~#,%;*()!'" "^[0-9a-zA-Z]" ":;.,!?") ;; Find a string that does *not* contain a colon: (nocolon "--9$+<>@-Z_[:alpha:]~" "<@" "@>;.,!?") ;; A machine: @@ -1031,7 +1001,7 @@ Function `ffap-string-at-point' uses the data fields as follows: 1. find a maximal string of CHARS around point, 2. strip BEG chars before point from the beginning, -3. Strip END chars after point from the end.") +3. strip END chars after point from the end.") (defvar ffap-string-at-point nil ;; Added at suggestion of RHOGEE (for ff-paths), 7/24/95. @@ -1050,22 +1020,22 @@ (or (assq (or mode major-mode) ffap-string-at-point-mode-alist) (assq 'file ffap-string-at-point-mode-alist)))) (pt (point)) - (str - (if (and transient-mark-mode mark-active) - (buffer-substring - (setcar ffap-string-at-point-region (region-beginning)) - (setcar (cdr ffap-string-at-point-region) (region-end))) - (buffer-substring - (save-excursion - (skip-chars-backward (car args)) - (skip-chars-forward (nth 1 args) pt) - (setcar ffap-string-at-point-region (point))) - (save-excursion - (skip-chars-forward (car args)) - (skip-chars-backward (nth 2 args) pt) - (setcar (cdr ffap-string-at-point-region) (point))))))) - (set-text-properties 0 (length str) nil str) - (setq ffap-string-at-point str))) + (beg (if (use-region-p) + (region-beginning) + (save-excursion + (skip-chars-backward (car args)) + (skip-chars-forward (nth 1 args) pt) + (point)))) + (end (if (use-region-p) + (region-end) + (save-excursion + (skip-chars-forward (car args)) + (skip-chars-backward (nth 2 args) pt) + (point))))) + (setq ffap-string-at-point + (buffer-substring-no-properties + (setcar ffap-string-at-point-region beg) + (setcar (cdr ffap-string-at-point-region) end))))) (defun ffap-string-around () ;; Sometimes useful to decide how to treat a string. @@ -1098,35 +1068,15 @@ (defun ffap-url-at-point () "Return URL from around point if it exists, or nil." - ;; Could use w3's url-get-url-at-point instead. Both handle "URL:", - ;; ignore non-relative links, trim punctuation. The other will - ;; actually look back if point is in whitespace, but I would rather - ;; ffap be less aggressive in such situations. (when ffap-url-regexp (or (and (eq major-mode 'w3-mode) ; In a w3 buffer button? (w3-view-this-url t)) - ;; Is there a reason not to strip trailing colon? - (let ((name (ffap-string-at-point 'url))) - (cond - ((string-match "^url:" name) (setq name (substring name 4))) - ((and (string-match "\\`[^:@]+@[^:@]+[[:alnum:]]\\'" name) - ;; "foo@bar": could be "mailto" or "news" (a Message-ID). - ;; Without "<>" it must be "mailto". Otherwise could be - ;; either, so consult `ffap-foo-at-bar-prefix'. - (let ((prefix (if (and (equal (ffap-string-around) "<>") - ;; Expect some odd characters: - (string-match "[$.0-9].*[$.0-9].*@" name)) - ;; Could be news: - ffap-foo-at-bar-prefix - "mailto"))) - (and prefix (setq name (concat prefix ":" name)))))) - ((ffap-newsgroup-p name) (setq name (concat "news:" name))) - ((and (string-match "\\`[[:alnum:]]+\\'" name) ; - (equal (ffap-string-around) "<>") - ;; (ffap-user-p name): - (not (string-match "~" (expand-file-name (concat "~" name))))) - (setq name (concat "mailto:" name))) - ((ffap-url-p name))))))) + (let ((thing-at-point-beginning-of-url-regexp ffap-url-regexp) + (thing-at-point-default-mail-scheme ffap-foo-at-bar-prefix)) + (thing-at-point-url-at-point t + (if (use-region-p) + (cons (region-beginning) + (region-end)))))))) (defvar ffap-gopher-regexp "^.*\\<\\(Type\\|Name\\|Path\\|Host\\|Port\\) *= *\\(.*\\) *$" @@ -1763,7 +1713,8 @@ (defun ffap-gnus-hook () "Bind `ffap-gnus-next' and `ffap-gnus-menu' to M-l and M-m, resp." - (set (make-local-variable 'ffap-foo-at-bar-prefix) "news") ; message-id's + ;; message-id's + (setq-local thing-at-point-default-mail-uri-scheme "news") ;; Note "l", "L", "m", "M" are taken: (local-set-key "\M-l" 'ffap-gnus-next) (local-set-key "\M-m" 'ffap-gnus-menu)) === modified file 'lisp/thingatpt.el' --- lisp/thingatpt.el 2013-01-01 09:11:05 +0000 +++ lisp/thingatpt.el 2013-02-04 12:02:25 +0000 @@ -232,7 +232,7 @@ (put 'defun 'end-op 'end-of-defun) (put 'defun 'forward-op 'end-of-defun) -;; Filenames and URLs www.com/foo%32bar +;; Filenames (defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:" "Characters allowable in filenames.") @@ -248,94 +248,224 @@ (forward-char) (goto-char (point-min))))) +;; URIs + +(defvar thing-at-point-beginning-of-url-regexp nil + "Regexp matching the beginning of a well-formed URI. +If nil, construct the regexp from `thing-at-point-uri-schemes'.") + (defvar thing-at-point-url-path-regexp "[^]\t\n \"'<>[^`{}]*[^]\t\n \"'<>[^`{}.,;]+" - "A regular expression probably matching the host and filename or e-mail part of a URL.") + "Regexp matching the host and filename or e-mail part of a URL.") (defvar thing-at-point-short-url-regexp (concat "[-A-Za-z0-9]+\\.[-A-Za-z0-9.]+" thing-at-point-url-path-regexp) - "A regular expression probably matching a URL without an access scheme. -Hostname matching is stricter in this case than for -``thing-at-point-url-regexp''.") + "Regexp matching a URI without a scheme component.") (defvar thing-at-point-uri-schemes ;; Officials from http://www.iana.org/assignments/uri-schemes.html - '("ftp://" "http://" "gopher://" "mailto:" "news:" "nntp:" - "telnet://" "wais://" "file:/" "prospero:" "z39.50s:" "z39.50r:" - "cid:" "mid:" "vemmi:" "service:" "imap:" "nfs:" "acap:" "rtsp:" - "tip:" "pop:" "data:" "dav:" "opaquelocktoken:" "sip:" "tel:" "fax:" - "modem:" "ldap:" "https://" "soap.beep:" "soap.beeps:" "urn:" "go:" - "afs:" "tn3270:" "mailserver:" - "crid:" "dict:" "dns:" "dtn:" "h323:" "im:" "info:" "ipp:" - "iris.beep:" "mtqp:" "mupdate:" "pres:" "sips:" "snmp:" "tag:" - "tftp:" "xmlrpc.beep:" "xmlrpc.beeps:" "xmpp:" - ;; Compatibility - "snews:" "irc:" "mms://" "mmsh://") - "Uniform Resource Identifier (URI) Schemes.") - -(defvar thing-at-point-url-regexp - (concat "\\<\\(" (mapconcat 'identity thing-at-point-uri-schemes "\\|") "\\)" - thing-at-point-url-path-regexp) - "A regular expression probably matching a complete URL.") - -(defvar thing-at-point-markedup-url-regexp - "]+>" - "A regular expression matching a URL marked up per RFC1738. -This may contain whitespace (including newlines) .") + '("aaa://" "about:" "acap://" "apt:" "bzr://" "bzr+ssh://" + "attachment:/" "chrome://" "cid:" "content://" "crid://" "cvs://" + "data:" "dav:" "dict://" "doi:" "dns:" "dtn:" "feed:" "file:/" + "finger://" "fish://" "ftp://" "geo:" "git://" "go:" "gopher://" + "h323:" "http://" "https://" "im:" "imap://" "info:" "ipp:" + "irc://" "irc6://" "ircs://" "iris.beep:" "jar:" "ldap://" + "ldaps://" "mailto:" "mid:" "mtqp://" "mupdate://" "news:" + "nfs://" "nntp://" "opaquelocktoken:" "pop://" "pres:" + "resource://" "rmi://" "rsync://" "rtsp://" "rtspu://" "service:" + "sftp://" "sip:" "sips:" "smb://" "sms:" "snmp://" "soap.beep://" + "soap.beeps://" "ssh://" "svn://" "svn+ssh://" "tag:" "tel:" + "telnet://" "tftp://" "tip://" "tn3270://" "udp://" "urn:" + "uuid:" "vemmi://" "webcal://" "xri://" "xmlrpc.beep://" + "xmlrpc.beeps://" "z39.50r://" "z39.50s://" "xmpp:" + ;; Compatibility + "fax:" "mms://" "mmsh://" "modem:" "prospero:" "snews:" + "wais://") + "List of URI schemes recognized by `thing-at-point-url-at-point'. +Each string in this list should correspond to the start of a +URI's scheme component, up to and including the trailing // if +the scheme calls for that to be present.") + +(defvar thing-at-point-markedup-url-regexp "\n]+\\)>" + "Regexp matching a URL marked up per RFC1738. +This kind of markup was formerly recommended as a way to indicate +URIs, but as of RFC 3986 it is no longer recommended. +Subexpression 1 should contain the delimited URL.") + +(defvar thing-at-point-newsgroup-regexp + "\\`[[:lower:]]+\\.[-+[:lower:]_0-9.]+\\'" + "Regexp matching a newsgroup name.") + +(defvar thing-at-point-newsgroup-heads + '("alt" "comp" "gnu" "misc" "news" "sci" "soc" "talk") + "Used by `thing-at-point-newsgroup-p' if gnus is not running.") + +(defvar thing-at-point-default-mail-uri-scheme "mailto" + "Default scheme for ill-formed URIs that look like . +If nil, do not give such URIs a scheme.") (put 'url 'bounds-of-thing-at-point 'thing-at-point-bounds-of-url-at-point) -(defun thing-at-point-bounds-of-url-at-point () - (let ((strip (thing-at-point-looking-at - thing-at-point-markedup-url-regexp))) ;; (url "") short - (if (or strip - (thing-at-point-looking-at thing-at-point-url-regexp) - ;; Access scheme omitted? - ;; (setq short (thing-at-point-looking-at - ;; thing-at-point-short-url-regexp)) - ) - (let ((beginning (match-beginning 0)) - (end (match-end 0))) - (when strip - (setq beginning (+ beginning 5)) - (setq end (- end 1))) - (cons beginning end))))) + +(defun thing-at-point-bounds-of-url-at-point (&optional lax) + "Return a cons cell containing the start and end of the URI at point. +Try to find a URI using `thing-at-point-markedup-url-regexp'. +If that fails, try with `thing-at-point-beginning-of-url-regexp'. +If that also fails, and optional argument LAX is non-nil, return +the bounds of a possible ill-formed URI (one lacking a scheme)." + ;; Look for the old markup. If found, use it. + (or (thing-at-point--bounds-of-markedup-url) + ;; Otherwise, find the bounds within which a URI may exist. The + ;; method is similar to `ffap-string-at-point'. Note that URIs + ;; may contain parentheses but may not contain spaces (RFC3986). + (let* ((allowed-chars "--:=&?$+@-Z_[:alpha:]~#,%;*()!'") + (skip-before "^[0-9a-zA-Z]") + (skip-after ":;.,!?") + (pt (point)) + (beg (save-excursion + (skip-chars-backward allowed-chars) + (skip-chars-forward skip-before pt) + (point))) + (end (save-excursion + (skip-chars-forward allowed-chars) + (skip-chars-backward skip-after pt) + (point)))) + (or (thing-at-point--bounds-of-well-formed-url beg end pt) + (if lax (cons beg end)))))) + +(defun thing-at-point--bounds-of-markedup-url () + (when thing-at-point-markedup-url-regexp + (let ((case-fold-search t) + (pt (point)) + (beg (line-beginning-position)) + (end (line-end-position)) + found) + (save-excursion + (goto-char beg) + (while (and (not found) + (<= (point) pt) + (< (point) end)) + (and (re-search-forward thing-at-point-markedup-url-regexp + end 1) + (> (point) pt) + (setq found t)))) + (if found + (cons (match-beginning 1) (match-end 1)))))) + +(defun thing-at-point--bounds-of-well-formed-url (beg end pt) + (save-excursion + (goto-char beg) + (let (url-beg paren-end regexp) + (save-restriction + (narrow-to-region beg end) + ;; The scheme component must either match at BEG, or have no + ;; other alphanumerical ASCII characters before it. + (setq regexp (concat "\\(?:\\`\\|[^a-zA-Z0-9]\\)\\(" + (or thing-at-point-beginning-of-url-regexp + (regexp-opt thing-at-point-uri-schemes)) + "\\)")) + (and (re-search-forward regexp end t) + ;; URI must have non-empty contents. + (< (point) end) + (setq url-beg (match-beginning 1)))) + (when url-beg + ;; If there is an open paren before the URI, truncate to the + ;; matching close paren. + (and (> url-beg (point-min)) + (eq (car-safe (syntax-after (1- url-beg))) 4) + (save-restriction + (narrow-to-region (1- url-beg) (min end (point-max))) + (setq paren-end (ignore-errors + (scan-lists (1- url-beg) 1 0)))) + (not (blink-matching-check-mismatch (1- url-beg) paren-end)) + (setq end (1- paren-end))) + (cons url-beg end))))) (put 'url 'thing-at-point 'thing-at-point-url-at-point) -(defun thing-at-point-url-at-point () + +(defun thing-at-point-url-at-point (&optional lax bounds) "Return the URL around or before point. - -Search backwards for the start of a URL ending at or after point. If -no URL found, return nil. The access scheme will be prepended if -absent: \"mailto:\" if the string contains \"@\", \"ftp://\" if it -starts with \"ftp\" and not \"ftp:/\", or \"http://\" by default." - - (let ((url "") short strip) - (if (or (setq strip (thing-at-point-looking-at - thing-at-point-markedup-url-regexp)) - (thing-at-point-looking-at thing-at-point-url-regexp) - ;; Access scheme omitted? - (setq short (thing-at-point-looking-at - thing-at-point-short-url-regexp))) - (progn - (setq url (buffer-substring-no-properties (match-beginning 0) - (match-end 0))) - (and strip (setq url (substring url 5 -1))) ; Drop "" - ;; strip whitespace - (while (string-match "[ \t\n\r]+" url) - (setq url (replace-match "" t t url))) - (and short (setq url (concat (cond ((string-match "^[a-zA-Z]+:" url) - ;; already has a URL scheme. - "") - ((string-match "@" url) - "mailto:") - ;; e.g. ftp.swiss... or ftp-swiss... - ((string-match "^ftp" url) - "ftp://") - (t "http://")) - url))) - (if (string-equal "" url) - nil - url))))) +If no URL is found, return nil. + +If optional argument LAX is non-nil, look for URLs that are not +well-formed, such as foo@bar or . + +If optional arguments BOUNDS are non-nil, it should be a cons +cell of the form (START . END), containing the beginning and end +positions of the URI. Otherwise, these positions are detected +automatically from the text around point. + +If the scheme component is absent, either because a URI delimited +with lacks one, or because an ill-formed URI was found +with LAX or BEG and END, try to add a scheme in the returned URI. +The scheme is chosen heuristically: \"mailto:\" if the address +looks like an email address, \"ftp://\" if it starts with +\"ftp\", etc." + (unless bounds + (setq bounds (thing-at-point-bounds-of-url-at-point lax))) + (when (and bounds (< (car bounds) (cdr bounds))) + (let ((str (buffer-substring-no-properties (car bounds) (cdr bounds)))) + ;; If there is no scheme component, try to add one. + (unless (string-match "\\`[a-zA-Z][-a-zA-Z0-9+.]*:" str) + (or + ;; If the URI has the form , treat it according to + ;; `thing-at-point-default-mail-uri-scheme'. If there are + ;; no angle brackets, it must be mailto. + (when (string-match "\\`[^:@]+@[-.0-9=&?$+A-Z_a-z~#,%;*]" str) + (let ((scheme (if (and (eq (char-before (car bounds)) ?<) + (eq (char-after (cdr bounds)) ?>)) + thing-at-point-default-mail-uri-scheme + "mailto"))) + (if scheme + (setq str (concat scheme ":" str))))) + ;; If the string is like , where FOO is an existing user + ;; name on the system, treat that as an email address. + (and (string-match "\\`[[:alnum:]]+\\'" str) + (eq (char-before (car bounds)) ?<) + (eq (char-after (cdr bounds)) ?>) + (not (string-match "~" (expand-file-name (concat "~" str)))) + (setq str (concat "mailto:" str))) + ;; If it looks like news.example.com, treat it as news. + (if (thing-at-point-newsgroup-p str) + (setq str (concat "news:" str))) + ;; If it looks like ftp.example.com. treat it as ftp. + (if (string-match "\\`ftp\\." str) + (setq str (concat "ftp://" str))) + ;; If it looks like www.example.com. treat it as http. + (if (string-match "\\`www\\." str) + (setq str (concat "http://" str))) + ;; Otherwise, it just isn't a URI. + (setq str nil))) + str))) + +(defun thing-at-point-newsgroup-p (string) + "Return STRING if it looks like a newsgroup name, else nil." + (and + (string-match thing-at-point-newsgroup-regexp string) + (let ((htbs '(gnus-active-hashtb gnus-newsrc-hashtb gnus-killed-hashtb)) + (heads thing-at-point-newsgroup-heads) + htb ret) + (while htbs + (setq htb (car htbs) htbs (cdr htbs)) + (condition-case nil + (progn + ;; errs: htb symbol may be unbound, or not a hash-table. + ;; gnus-gethash is just a macro for intern-soft. + (and (symbol-value htb) + (intern-soft string (symbol-value htb)) + (setq ret string htbs nil)) + ;; If we made it this far, gnus is running, so ignore "heads": + (setq heads nil)) + (error nil))) + (or ret (not heads) + (let ((head (string-match "\\`\\([[:lower:]]+\\)\\." string))) + (and head (setq head (substring string 0 (match-end 1))) + (member head heads) + (setq ret string)))) + ret))) + +(put 'url 'end-op (lambda () (end-of-thing 'url))) + +(put 'url 'beginning-op (lambda () (end-of-thing 'url))) ;; The normal thingatpt mechanism doesn't work for complex regexps. ;; This should work for almost any regexp wherever we are in the @@ -372,19 +502,6 @@ (goto-char match) (looking-at regexp))))) -(put 'url 'end-op - (lambda () - (let ((bounds (thing-at-point-bounds-of-url-at-point))) - (if bounds - (goto-char (cdr bounds)) - (error "No URL here"))))) -(put 'url 'beginning-op - (lambda () - (let ((bounds (thing-at-point-bounds-of-url-at-point))) - (if bounds - (goto-char (car bounds)) - (error "No URL here"))))) - ;; Email addresses (defvar thing-at-point-email-regexp "?" === modified file 'test/ChangeLog' --- test/ChangeLog 2013-02-03 08:55:45 +0000 +++ test/ChangeLog 2013-02-04 12:02:25 +0000 @@ -1,3 +1,7 @@ +2013-02-04 Chong Yidong + + * automated/thingatpt.el: New file. + 2013-02-03 Chong Yidong * automated/files.el (file-test--do-local-variables-test): Avoid === added file 'test/automated/thingatpt.el' --- test/automated/thingatpt.el 1970-01-01 00:00:00 +0000 +++ test/automated/thingatpt.el 2013-02-04 12:02:25 +0000 @@ -0,0 +1,88 @@ +;;; thingatpt.el --- tests for thing-at-point. + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +(defvar thing-at-point-test-data + '(("http://1.gnu.org" 1 url "http://1.gnu.org") + ("http://2.gnu.org" 6 url "http://2.gnu.org") + ("http://3.gnu.org" 19 url "http://3.gnu.org") + ("https://4.gnu.org" 1 url "https://4.gnu.org") + ("bzr://savannah.gnu.org" 1 url "bzr://savannah.gnu.org") + ("A geo URI (geo:3.14159,-2.71828)." 12 url "geo:3.14159,-2.71828") + ("Visit http://5.gnu.org now." 5 url nil) + ("Visit http://6.gnu.org now." 7 url "http://6.gnu.org") + ("Visit http://7.gnu.org now." 22 url "http://7.gnu.org") + ("Visit http://8.gnu.org now." 22 url "http://8.gnu.org") + ("Visit http://9.gnu.org now." 24 url nil) + ;; Invalid URIs + ("<<<<" 2 url nil) + ("<>" 1 url nil) + ("" 1 url nil) + ("http://" 1 url nil) + ;; Invalid schema + ("foo://www.gnu.org" 1 url nil) + ("foohttp://www.gnu.org" 1 url nil) + ;; Non alphanumeric characters can be found in URIs + ("ftp://example.net/~foo!;#bar=baz&goo=bob" 3 url "ftp://example.net/~foo!;#bar=baz&goo=bob") + ("bzr+ssh://user@example.net:5/a%20d,5" 34 url "bzr+ssh://user@example.net:5/a%20d,5") + ;; markup + ("Url: ..." 8 url "foo://1.example.com") + ("Url: ..." 30 url "foo://2.example.com") + ("Url: ..." 20 url "foo://www.gnu.org/a bc") + ;; Hack used by thing-at-point: drop punctuation at end of URI. + ("Go to http://www.gnu.org, for details" 7 url "http://www.gnu.org") + ("Go to http://www.gnu.org." 24 url "http://www.gnu.org") + ;; Standard URI delimiters + ("Go to \"http://10.gnu.org\"." 8 url "http://10.gnu.org") + ("Go to \"http://11.gnu.org/\"." 26 url "http://11.gnu.org/") + ("Go to now." 8 url "http://12.gnu.org") + ("Go to now." 24 url "http://13.gnu.org") + ;; Parenthesis handling (non-standard) + ("http://example.com/a(b)c" 21 url "http://example.com/a(b)c") + ("http://example.com/a(b)" 21 url "http://example.com/a(b)") + ("(http://example.com/abc)" 2 url "http://example.com/abc") + ("This (http://example.com/a(b))" 7 url "http://example.com/a(b)") + ("This (http://example.com/a(b))" 30 url "http://example.com/a(b)") + ("This (http://example.com/a(b))" 5 url nil) + ("http://example.com/ab)c" 4 url "http://example.com/ab)c") + ;; URL markup, lacking schema + ("" 1 url "mailto:foo@example.com") + ("" 1 url "ftp://ftp.example.net/abc/")) + "List of thing-at-point tests. +Each list element should have the form + + (STRING POS THING RESULT) + +where STRING is a string of buffer contents, POS is the value of +point, THING is a symbol argument for `thing-at-point', and +RESULT should be the result of calling `thing-at-point' from that +position to retrieve THING.") + +(ert-deftest thing-at-point-tests () + "Test the file-local variables implementation." + (dolist (test thing-at-point-test-data) + (with-temp-buffer + (insert (nth 0 test)) + (goto-char (nth 1 test)) + (should (equal (thing-at-point (nth 2 test)) (nth 3 test)))))) + +;;; thingatpt.el ends here ------------------------------------------------------------ revno: 111671 fixes bug: http://debbugs.gnu.org/13543 committer: Glenn Morris branch nick: trunk timestamp: Sun 2013-02-03 23:46:22 -0800 message: ert--explain-format-atom fix for non-characters * lisp/emacs-lisp/ert.el (ert--explain-format-atom): Don't try to print non-characters as characters. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-02-03 16:49:37 +0000 +++ lisp/ChangeLog 2013-02-04 07:46:22 +0000 @@ -1,3 +1,8 @@ +2013-02-04 Glenn Morris + + * emacs-lisp/ert.el (ert--explain-format-atom): + Don't try to print non-characters as characters. (Bug#13543) + 2013-02-03 Michael Albinus * net/tramp.el (tramp-debug-message): Extend function exclude list. === modified file 'lisp/emacs-lisp/ert.el' --- lisp/emacs-lisp/ert.el 2013-01-11 10:40:54 +0000 +++ lisp/emacs-lisp/ert.el 2013-02-04 07:46:22 +0000 @@ -568,7 +568,8 @@ (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." (cl-typecase x - (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (character (list x (format "#x%x" x) (format "?%c" x))) + (fixnum (list x (format "#x%x" x))) (t x))) (defun ert--explain-equal-rec (a b)