-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 "<URL:" & ">"
- ;; 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)))))
+(defun thing-at-point-url-at-point (&optional lax bounds)
+ "Return the URL around or before point.
+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 <nobody>.
+
+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 <url:...> 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 <foo@bar>, 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 <FOO>, 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))
+ (ignore-errors
+ ;; 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)))
+ (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)))